Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch kennykb-numerics-branch Excluding Merge-Ins
This is equivalent to a diff from ad35750c6d to 1b902ae45a
2005-10-08
| ||
13:44 | merge updates from HEAD Closed-Leaf check-in: 1b902ae45a user: dgp tags: kennykb-numerics-branch | |
06:43 | more WIDE support check-in: 936ff6a20a user: dgp tags: kennykb-numerics-branch | |
2004-12-02
| ||
19:24 | merge to kennykb-numerics-branch-20041202a check-in: ac3b922388 user: kennykb tags: kennykb-numerics-branch | |
18:40 | workaround for a bug in cygpath that made safe-8.5-8.7 fail check-in: 1f8af3a1ac user: kennykb tags: trunk | |
15:31 | Remove a global mutex/state by using lists instead of hashtables to store the collection of aliases ... check-in: ad35750c6d user: dkf tags: trunk | |
11:10 | Upgrade more of the file to tcltest2, and collect constraint definitions to the top. check-in: 067ebb1583 user: dkf tags: trunk | |
Changes to ChangeLog.
1 2 3 4 5 6 7 8 9 | 2004-12-02 Donal K. Fellows <[email protected]> * generic/tclInterp.c (Alias,Target,Master): Rewrote these so that the aliases that refer to an interpreter are stored in a list and not a hashtable (which was only ever a convenience, and forced the use of a global mutex to generate keys!) [FRQ 1077210] * generic/tclNamesp.c (numNsCreated): Moved into thread-local storage to remove a global mutex. [FRQ 1077210] | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 | 2005-10-08 Don Porter <[email protected]> [kennykb-numerics-branch] Merge updates from HEAD * generic/tclExecute.c: More performance macros and special handling of the wide integer type for performance on 32-bit systems. 2005-10-07 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclExecute.c: Macro GetNumberFromObj() is version of TclGetNumberFromObj() that saves a function call for common uses. * generic/tclInt.h: Made #undef NO_WIDE_TYPE the default on 32-bit systems. Being able to use 64-bit values without leaping to mp_int should help with performance. * generic/tclObj.c: Bug fixes in the #undef NO_WIDE_TYPE * generic/tclExecute.c: configuration. * generic/tclExecute.c: Improved performance of comparison opcodes and bitwise operations and removed yet more dead code. 2005-10-07 Jeff Hobbs <[email protected]> * unix/tclUnixFCmd.c (TraverseUnixTree): Adjust 2004-11-11 change to * tests/fCmd.test (fCmd-20.2): account for NFS special files with a readdir rewind threshold. [Bug 1034337] 2005-10-06 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclExecute.c: Improved performance of INST_RSHIFT and INST_LSHIFT. 2005-10-05 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclExecute.c: Improved performance of INST_MULT, INST_DIV, INST_ADD, and INST_SUB and replaced a "goto... label" with a "break from loop" in TclIncrObj() and removed some dead code. 2005-10-05 Andreas Kupries <[email protected]> * generic/tclPipe.c (TclCreatePipeline): Fixed [SF Tcl Bug 1109294]. Applied the patch provided by David Gravereaux. * doc/CrtChannel.3: Fixed [SF Tcl Bug 1104682], by application of David Welton's patch for it, and added a note about wideSeekProc. * generic/tclIORChan.c (RcClose): Removed unreachable panic/return statements. This fixes the remainder of [SF Tcl Bug 1286256]. 2005-10-05 Jeff Hobbs <[email protected]> * tests/env.test (env-6.1): * win/tclWinPort.h: define USE_PUTENV_FOR_UNSET 1 * generic/tclEnv.c (TclSetEnv, TclUnsetEnv): add USE_PUTENV_FOR_UNSET to existing USE_PUTENV define to account for various systems that have putenv(), but can't unset env vars with it. Note difference between Windows and Linux for actually unsetting the env var (use of '='). Correct the resizing of the environ array. We assume that we are in full ownership, but that's not correct.[Bug 979640] 2005-10-04 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclExecute.c: Updated TclIncrObj() to more efficiently add native long integers. Also updated IllegalExprOperandType and the INST_UMINUS, INST_UPLUS, INST_BITNOT, and INST_TRY_CVT_TO_NUMERIC sections for performance. * generic/tclBasic.c: Updated more callers to make use of TclGetNumberFromObj. Removed some dead code. 2005-10-04 Jeff Hobbs <[email protected]> * win/tclWinSerial.c (SerialSetOptionProc): free argv [Bug 1067708] * tests/http.test: do not URI encode -._~ according * library/http/http.tcl (init): to RFC3986. [Bug 1182373] (aho) * unix/tclLoadShl.c (TclpDlopen): use DYNAMIC_PATH on second shl_load only. [Bug 1204237] * doc/scan.n: scan %[] requires "one or more chars" [Bug 1277503] * tests/winFile.test (getuser): allow valid Windows usernames. [Bug 1311285] * generic/tclParse.c (Tcl_ParseCommand): add code that recognizes {} in addition to {expand} for word expansion (make with -DALLOW_EMPTY_EXPAND). 2005-10-04 Zoran Vasiljevic <[email protected]> * generic/tclIO.c (Tcl_ClearChannelHandlers): now deletes any outstanding timer for the channel. Also, prevents events still in the event queue from triggering on the current channel. * generic/tclTimer.c (Tcl_DeleteTimerHandler): bail out early if passed NULL argument. 2005-10-03 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclBasic.c: Re-implemented ExprRoundFunc and ExprEntierFunc to use TclGetNumberFromObj. * generic/tclInt.h: Added new routine TclGetNumberFromObj to * generic/tclObj.c: provide efficient access to the actual internal rep of a numeric Tcl_Obj without conversions. 2005-10-03 Kevin Kenny <[email protected]> * tools/loadICU.tcl: Changed the file names of message catalogs to lowercase. * tools/makeTestCases.tcl: * library/tzdata/*: Olson's tzdata2005n.tar.gz. Includes new DST rules for USA and a number of changes to other locales. * tests/clock.test: Regenerated for new US DST rules. 2005-09-30 Don Porter <[email protected]> * generic/tclMain.c: Separate encoding conversion of command line arguments from list formatting. [Bug 1306162]. 2005-09-30 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclStringObj.c: Bug fix: Missing cast to large enough integral size before << operations led to broken [format %llx] results. Thanks to Robert Henry for reporting the bug. 2005-09-29 Jeff Hobbs <[email protected]> * doc/mathfunc.n: implementation for TIP #255, expr min/max * library/init.tcl: * tests/info.test, tests/expr-old.test: 2005-09-27 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tcl.h: Changed name of the new Tcl_Obj intrep field * generic/tclObj.c: from "bignumValue" to "ptrAndLongRep" as * generic/tclProc.c: described in TIP 237, and more suitable for other more general uses. 2005-09-27 Donal K. Fellows <[email protected]> * tests/binary.test (binary-14.18): Added test for [Bug 1116542] though the bug itself was already fixed by unrelated changes. 2005-09-26 Kevin Kenny <[email protected]> [kennykb-numerics-branch] Merge updates from HEAD. 2005-09-26 Kevin Kenny <[email protected]> * libtommath/: Updated to release 0.36. * generic/tommath.h: Regenerated. * generic/tclTomMathInterface.h: Added ten missing aliases for mp_* functions to avoid namespace pollution in Tcl's exported symbols. [Bug 1263012] 2005-09-23 Don Porter <[email protected]> [kennykb-numerics-branch] * unix/Makefile.in: Added -DMP_PREC=4 switch to all compiles so * win/Makefile.in: that minimum memory requirements of mp_int's * win/makefile.vc: will not be quite so large. [Bug 1299153]. * generic/tclStrToD.c: Fixed memory leak. [Bug 1299803]. * generic/tclObj.c: 2005-09-20 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclExecute.c: Revise TclIncrObj() to call Tcl_GetBignumAndClearObj. * generic/tcl.decls: Add Tcl_GetBignumAndClearObj. * generic/tclObj.c: * generic/tclDecls.h: make genstubs * generic/tclStubInit.c: 2005-09-16 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclInt.h: Added TclBNInitBigNumFromWideInt() * generic/tclTomMathInterface.c: so that every caller isn't required to duplicate the sign logic to use the unsigned interface. * generic/tclBasic.c: Reduce the number of places where Tcl * generic/tclExecute.c: intrudes into the internal format details * generic/tclObj.c: of the mp_int struct. * generic/tclStrToD.c: * generic/tcLStringObj.c: * generic/tclTomMath.h: Added mp_cmp_d to routines from * unix/Makefile.in: libtommath used by Tcl. * win/Makefile.in: * win/makefile.vc: * libtommath/bn_mp_add_d.c: Bug fix. For mp_add_d(&a, d, &c), when &a has the value -d, then the value &c computed should be zero, but mp_add_d was producing an inconsistent zero value with a sign field of MP_NEG, something like a value of -0, which other routines in libtommath can't handle. * generic/tclExecute.c: Dropped all creation of "bigOne" values and just use tommath routines that accept the value "1" directly. 2005-09-15 Miguel Sofer <[email protected]> * doc/ParseCmd.3: copy/paste fix [Bug 1292427] 2005-09-15 Don Porter <[email protected]> [kennykb-numerics-branch] Merge updates from HEAD. * generic/tclStringObj.c (TclAppendFormattedObjs): Revision to eliminate one round of string copying. * generic/tclBasic.c: More callers of TclObjPrintf and * generic/tclCkalloc.c: TclFormatToErrorInfo. * generic/tclCmdMZ.c: * generic/tclExecute.c: * generic/tclIORChan.c: * generic/tclMain.c: * generic/tclProc.c: * generic/tclTimer.c: * generic/tclUtil.c: * unix/tclUnixFCmd.c * unix/configure: autoconf-2.59 2005-09-15 Donal K. Fellows <[email protected]> * unix/tcl.m4 (SC_TCL_EARLY_FLAGS): Added extra hack to allow Tcl to transparently open large files on RHEL 3. [Bug 1287638] 2005-09-14 Don Porter <[email protected]> * generic/tclStringObj.c: Bug fixes: ObjPrintfVA needed to support "*" fields and needed to interpret precision limits on %s conversions as a maximum number of bytes, not Tcl_UniChars, to take from the (char *) argument. * generic/tclBasic.c: Updated several callers to use * generic/tclCkalloc.c: TclFormatToErrorInfo() and/or * generic/tclCmdAH.c: TclObjPrintf(). * generic/tclCmdIL.c: * generic/tclCmdMZ.c: * generic/tclDictObj.c: * generic/tclExecute.c: * generic/tclIORChan.c: * generic/tclIOUtil.c: * generic/tclNamesp.c: * generic/tclProc.c: * library/init.tcl: Keep [unknown] in sync with errorInfo formatting rules. 2005-09-13 Don Porter <[email protected]> * generic/tclBasic.c: First caller of TclFormatToErrorInfo. * generic/tclInt.h: Using stdarg.h conventions, add more * generic/tclStringObj.c: fixed arguments to TclFormatObj() and TclObjPrintf(). Added new routine TclFormatToErrorInfo(). * generic/tcl.h: Explicitly standardized on the use of stdarg.h * generic/tclBasic.c: conventions for functions with variable number * generic/tclInt.h: of arguments. Support for varargs.h has been * generic/tclPanic.c: implicitly gone for some time now. All * generic/tclResult.c: TCL_VARARGS* macros purged from Tcl sources, * generic/tclStringObj.c: leaving only some deprecated #define's * tools/genStubs.tcl: in tcl.h for the sake of older extensions. * generic/tclDecls.h: make genstubs * doc/AddErrInfo.3: Replaced all documented requirement for use * doc/Eval.3: of TCL_VARARGS_START() with requirement for * doc/Panic.3: use of va_start(). * doc/SetResult.3: * doc/StringObj.3: 2005-09-12 Don Porter <[email protected]> [kennykb-numerics-branch] Merge updates from HEAD. * generic/tclCmdAH.c: Added support for the "ll" width * generic/tclStringObj.c: specifier to [format]. * generic/tclStringObj.c (TclAppendFormattedObjs): Bug fix: make sure %ld formats force the collection of a wide value, when the value could be a different long. 2005-09-09 Andreas Kupries <[email protected]> * generic/tclIORChan.c (RcDecodeEventMask): Added missing type declaration for the parameter 'mask'. This fixes the [SF Tcl Bug 1286256]. The other warning can be removed only by removing the panic/return code. 2005-09-09 Don Porter <[email protected]> [kennykb-numerics-branch] Merge updates from HEAD. 2005-09-09 Kevin Kenny <[email protected]> * generic/tclStringObj.c: Added two missing casts to silence messages from MSVC6. 2005-09-09 Don Porter <[email protected]> * generic/tclInt.h: New internal routine TclObjPrintf() * generic/tclStringObj.c: is similar to TclFormatObj() but accepts arguments in non-Tcl_Obj format. * generic/tclInt.h: New internal routines TclFormatObj() * generic/tclStringObj.c: and TclAppendFormattedObjs() to offer sprintf()-like means to append to Tcl_Obj. Work in progress toward [RFE 572392]. * generic/tclCmdAH.c: Compiler directive NEW_FORMAT when #define'd directs the [format] command to be implemented in terms of the new TclAppendFormattedObjs() routine. 2005-09-08 Donal K. Fellows <[email protected]> TIP#254 IMPLEMENTATION * generic/tclLink.c (LinkTraceProc,ObjValue): Added many new of C var * generic/tcl.h: to link to, making it * doc/LinkVar.3: easier to seamlessly * generic/tclTest.c (TestlinkCmd): couple C code and Tcl * tests/link.test: scripts in an application. [Patch 1242844] 2005-09-07 Don Porter <[email protected]> * generic/tclUtf.c (Tcl_UniCharToUtf): Corrected handling of negative * tests/utf.test (utf-1.5): Tcl_UniChar input value. Incorrect handling was producing byte sequences outside of Tcl's legal internal encoding. [Bug 1283976]. 2005-09-06 Donal K. Fellows <[email protected]> * generic/tclInt.h (List): Added flag to keep track of whether a list * generic/tclListObj.c: with a string rep is provably canonical. * generic/tclUtil.c (Tcl_ConcatObj): Do efficient concatenation and * generic/tclBasic.c (Tcl_EvalObjEx): evaluation when the list is canonical, and not just when the list is pure. This should make the "pure list" hacking introduced in 8.3 much more robust. 2005-09-05 Donal K. Fellows <[email protected]> * generic/tclObj.c (pendingObjDataKey): Added missing 'static' to stop symbol from leaking outside the Tcl library. [Bug 1263012] 2005-09-02 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclScan.c: Bug fix: The %o, %x, %i formats of [scan] must not accept any 0b or 0o prefixes. [scan $s %o] must continue to work even with KILL_OCTAL enabled. * generic/tclInt.h: Added TCL_PARSE_SCAN_PREFIXES to the flags * generic/tclStrToD.c: accepted by TclParseNumber. 2005-09-01 Andreas Kupries <[email protected]> * unix/tclUnixSock.c (InitializeHostName): Synchronized use of static modifier in declaration and definition of function. * unix/tclUnixChan.c (FileTruncateProc): Synchronized use of static modifier in declaration and definition of function. * generic/tclResult.c (ReleaseKeys): Synchronized use of static modifier in declaration and definition of function. * generic/tclListObj.c (NewListIntRep): Synchronized use of static modifier in declaration and definition of function. * generic/tclEncoding.c (InitializeEncodingSearchPath): Synchronized use of static modifier in declaration and definition of function. * generic/tclEncoding.c (FillEncodingFileMap): Synchronized use of static modifier in declaration and definition of function. * generic/tclIORChan.c (RcNewHandle): Synchronized use of static modifier in declaration and definition of function. 2005-09-01 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclObj.c: TclParseNumber calls meant to parse an integer value now pass the TCL_PARSE_INTEGER_ONLY flag. * generic/tclScan.c: Extended [scan] to accept the %lld, %llo, %llx, and %lli formats. Numeric scanning is now done via TclParseNumber calls. * generic/tclInt.h: Extended TclParseNumber to accept new flag * generic/tclStrToD.c: values TCL_PARSE_INTEGER_ONLY, TCL_PARSE_OCTAL_ONLY, and TCL_PARSE_HEXIDECIMAL_ONLY, to give caller more control over the parsing rules. 2005-08-31 Vince Darley <[email protected]> * doc/FileSystem.3: * unix/tclUnixFile.c: * windows/tclWinFile.c: clarify that Tcl_FSMatchInDirectory may be called with a NULL interpreter, and fix the code so this is allowed. Tcl's core itself (tclEncoding.c:FillEncodingFileMap()) calls this with a NULL interpreter. 2005-08-30 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclObj.c: Extended bignum support to include bignums so large they will not pack into a Tcl_Obj. When they outgrow Tcl's string rep length limits, a panic will result. * generic/tclTomMath.h: Added mp_sqrt to routines from * unix/Makefile.in: libtommath used by Tcl. * win/Makefile.in: * win/makefile.vc: * generic/tclBasic.c: Extended sqrt(.) so that range covers the entire double range, accepting as many bignums in the domain as that will allow. 2005-08-29 Andreas Kupries <[email protected]> * library/tm.tcl (::tcl::tm::roots): Accepted Don Porter's patch for [Tcl SF Bug 1189657]. Syncs the implementation to the specification (TIP #189). 2005-08-29 Don Porter <[email protected]> [kennykb-numerics-branch] Merge updates from HEAD. * generic/tclBasic.c: Restored round(.) to the Tcl 8.4 rules. 2005-08-29 Kevin Kenny <[email protected]> * generic/tclBasic.c (ExprMathFunc): Restored "round away from * tests/expr.test (expr-46.*): zero" behaviour to the "round" function. Added test cases for the behavior, including the awkward case of a number whose fractional part is 1/2-1/2ulp. [Bug 1275043] 2005-08-26 Andreas Kupries <[email protected]> * generic/tclIO.c: Moved Tcl_{Cut,Splice}Channel to {Cut,Splice}Channel for internal use, and created new public functions for Tcl_{Cut,Splice}Channel which walk the whole stack of transformations and invoke the necessary thread actions. Added code to Tcl_(Un)StackChannel to properly invoke the thread actions when pushing and popping transformations on/from a channel. 2005-08-26 Donal K. Fellows <[email protected]> * generic/tclNamesp.c (NamespaceEnsembleCmd): Reset the result after creating an ensemble to clear any result object sharing (potentially caused by delete traces) so that we can safely return the name of the ensemble. Previously, this caused crashes in Snit's test suite. 2005-08-25 Donal K. Fellows <[email protected]> * generic/tclListObj.c (UpdateStringOfList): Stop uncontrolled and unsafe crashes from happening when working with very large string representations. [Bug 1267380] * generic/tclExecute.c (TEBC:INST_DICT_LAPPEND): Stop dropping a duplicated object on the floor, which was a memory leak (and a wrong result too). Thanks to Andreas Kupries for reporting this. 2005-08-25 Don Porter <[email protected]> [kennykb-numerics-branch] Merge updates from HEAD * generic/tclExecute.c: Bug fix. INST_RSHIFT: shift of negative values produced incorrect results. * generic/tclExecute.c: Bug fix. INST_*SHIFT opcodes stack management. [expr 0<<6] should be 0, not 6. * generic/tclBasic.c: Extended the domain of round(.) to all non-Inf, non-NaN doubles, using bignums for the result as needed. 2005-08-24 Andreas Kupries <[email protected]> TIP#219 IMPLEMENTATION * doc/SetChanErr.3: ** New File **. Documentation of the new channel API functions. * generic/tcl.decls: Stub declarations of the new channel API. * generic/tclDecls.h: Regenerated * generic/tclStubInit.c: * tclIORChan.c: ** New File **. Implementation of the reflected channel. * generic/tclInt.h: Integration of reflected channel and new error * generic/tclIO.c: propagation into the generic I/O core. * generic/tclIOCmd.c: * generic/tclIO.h: * library/init.tcl: * tests/io.test: Extended testsuite. * tests/ioCmd.test: * tests/chan.test: * generic/tclTest.c: * generic/tclThreadTest.c: * unix/Makefile.in: Integration into the build machinery. * win/Makefile.in: * win/Makefile.vc: 2005-08-24 Kevin Kenny <[email protected]> * generic/tclStrToD.c (Tcl_DoubleDigits): Fixed the corner cases of * tests/binary.test (binary-65.*) formatting floating point numbers with the largest and smallest possible significands, and added test cases for them. 2005-08-24 Kevin Kenny <[email protected]> [kennykb-numerics-branch] * generic/tclExecute.c: Corrected some TRACE bugs that prevented compilation with --enable-symbols=all. * generic/tclStrToD.c: Revised commentary to prepare for a renaming of the file, removed some dead code, and fixed a bug where TclBignumToDouble failed on huge negative numbers. * tests/binary.test (binary-65.*): Added missing 'ieeeFloatingPoint' to large/small significand tests. * tests/expr.test (expr-45.*) Added missing braces around expressions. 2005-08-24 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclBasic.c: Revised implementation of the ceil(.) and * generic/tclInt.h: floor(.) math functions in light of the * generic/tclStrToD.c: revised comparison operators, so that it is always true that ($x <= ceil($x)) and ($x >= floor($x)). The simple approach of "convert to double and call ceil() or floor()" could not guarantee that. * generic/tclExecute.c: Bug fix: TclBignumToDouble return -Inf when appropriate. Removed declarations of removed routines. * generic/tclExecute.c: Revised the type promotion rules of the comparison operators so that they form proper equivalence classes over the set of numeric strings. 2005-08-23 Mo DeJong <[email protected]> * unix/configure.in: * win/configure: Regen. * win/configure.in: Update minimum autoconf version to 2.59. 2005-08-23 Kevin Kenny <[email protected]> [kennykb-numerics-branch] * generic/tclCmdMZ.c (Tcl_StringObjCmd): * generic/tclInt.h: * generic/tclObj.c (Tcl_GetBooleanFromObj, SetDoubleFromAny, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_GetBignumFromObj): * generic/tclParseExpr.c (GetLexeme): * generic/tclScan.c (Tcl_ScanObjCmd): * generic/tclStrToD.c (TclParseNumber): * tests/binary.test (binary-62.1-65.7): * tests/expr.test (expr-40.1-42.1): * scan.test (scan-14.1,14.2): Modified Tcl_ParseNumber to accept an argument to force interpretation as decimal, and modified [scan] to use it. Corrected a bug where Not a Number with hexadecimal information bits returned consistently incorrect values. #ifdef-ed out some code that is needed only for IBM hexadecimal floating point. Fixed bugs in code to handle the corner cases of smallest and largest significands. Added test cases to improve test coverage in generic/tclStrToD.c. Added test cases for 0b notation (TIP #114). Removed TclStrToD, and the static functions that it calls, which are now dead code (TclParseNumber now does all input floating-point conversions.) 2005-08-23 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclStrToD.c: Bug fix: set shift magnitude properly whether we're expanding to mp_int type or not. * generic/tclExecute.c: Bug fix: ACCEPT_NAN under INST_UMINUS. * generic/tclStrToD.c: New macros TIP_114_FORMATS and KILL_OCTAL to configure acceptance of 0o and 0b numbers and rejection of "leading zero as octal". * generic/tclBasic.c: Re-used the guts of int(.) and wide(.) math functions to perform conversions in OldMathFuncProc. * generic/tclBasic.c: Support for ACCEPT_NAN. * generic/tclExecute.c: * generic/tclInt.decls: Restored TclExprFloatError to internal stubs * generic/tclBasic.c: table, and moved definition back to tclExecute.c * generic/tclExecute.c: from tclBasic.c to handle #undef ACCEPT_NAN. * generic/tclIntDecls.h: make genstubs * generic/tclStubInit.c: * generic/tclInt.h: New internal macros TclIsNaN and TclIsInfinite * generic/tclBasic.c: replace the IS_NAN and IS_INF macros scattered * generic/tclExecute.c: here and there. * generic/tclObj.c: * generic/tclStrToD.c: * generic/tclUtil.c: 2005-08-22 Daniel Steffen <[email protected]> * unix/tclConfig.h.in: autoheader-2.59. 2005-08-22 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclInt.h: New ACCEPT_NAN macro to mark code that supports * generic/tclCmdAH.c: or disables accepting of the NaN value at * generic/tclExecute.c: various points. * generic/tclLink.c: * generic/tclStrToD.c: Bug fix. Parsing of +/- Infinity was reversed. * generic/tclTestObj.c: Disabled unused [testconvertobj] command. * generic/tclBasic: Added [expr {entier(.)}]. Rewrote int(.) and wide(.) to use the same guts, accepting all non-Inf doubles as arguments. * generic/tclInt.h: New routine TclInitBignumFromDouble. * generic/tclStrToD.c: Modified to return code and write error message. * generic/tclInt.h: TCL_WIDE_INT_IS_LONG implies NO_WIDE_TYPE. * generic/tclObj.c: Removed now unnecessary tests of the * generic/tclStrToD.c: TCL_WIDE_INT_IS_LONG definition. * generic/tclInt.h: New internal routine TclSetBignumIntRep * generic/tclObj.c: consolidates packing of bignum value into * generic/tclStrToD.c: a Tcl_Obj within one source code file. * tests/expr.test: Corrected the wideIs64bit constraint. * tests/format.test: * tests/scan.test: 2005-08-21 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclInt.h: Moved TclParseInteger to tclUtil.c * generic/tclParseExpr.c: and made it static. * generic/tclUtil.c: * generic/tclInt.decls: Moved TclExprFloatError to tclBasic.c and * generic/tclBasic.c: made it static. * generic/tclExecute.c: * generitc/tclIntDecls.h: make genstubs * generic/tclStubInit.c: * generic/tclExecute.c: errno, IS_NAN, IS_INF, LLD no longer called in this file; dropped/disabled support for them. * generic/tclCompExpr.c: errno no longer used in these files; * generic/tclParseExpr.c: dropped support "hack" for it. * generic/tclStrToD.c: Disabled out of date support "hack" for errno. * generic/tclBasic.c: Eliminated VerifyExprObjType. Initialize errno to zero in OldMathFuncProc. 2005-08-19 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclBasic.c: Updated OldMathFuncProc and ExprAbsFunc to do less invasion into numeric Tcl_Obj internals. Made ExprDoubleFunc, ExprIntFunc, ExprWideFunc, and ExprRoundFunc bignum-aware. Revised ExprSrandFunc error message. * generic/tclProc.c: Wrapped a few tclWideIntType uses in * generic/tclCmdMZ.c: #ifndef NO_WIDE_TYPE. * generic/tclInt.h: #define'd NO_WIDE_TYPE. * generic/tclVar.c: Replaced TclPtrIncrVar and TclPtrIncrWideVar * generic/tclInt.h: with TclPtrIncrObjVar and replaced TclIncrVar2 * generic/tclInt.decls: and TclIncrWideVar2 with TclIncrObjVar2. New routines call on TclIncrObj to do the work. * generic/tclIntDecls.h: make genstubs * generic/tclStubInit.c: * generic/tclCmdIL.c: Rework Tcl_IncrObjCmd and the INST_*INCR* * generic/tclExecute.c: opcodes to use the new routines. 2005-08-18 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclExecute.c: Fixed string rep invalidation bug in * tests/dict.test (dict-11.17): INST_DICT_INCR_IMM rewrite. * generic/tclDictObj.c: DictIncrCmd rewrite to use TclIncrObj. * generic/tclInt.h: TclIncrObj static -> internal * generic/tclExecute.c: 2005-08-17 George Peter Staplin <[email protected]> * generic/tclBasic.c: eliminate a namespace clash caused by BuiltinFuncTable not being static. * generic/tclObj.c: fix a namespace clash caused by a missing static for pendingObjData. 2005-08-17 Kevin Kenny <[email protected]> * generic/tclEvent.c (Tcl_Finalize): Removed a copy-and-paste accident that caused a (mostly harmless) double finalize of the load and filesystem subsystems. * tests/clock.test: Eliminated the bad test clock-43.1, and split clock-50.1 into two tests, with a more permissive check on the error message for an out-of-range value. 2005-08-17 Kevin Kenny <[email protected]> [kennykb-numerics-branch] * generic/tclBasic.c (Tcl_Expr{Long,Double}{,Obj}): Updated to * generic/tclTest.c: deal with * tests/expr-old.test: bignums (well, * tests/expr.test: mostly). Added a missing "errno=0;" in ExprUnaryFunc so that spurious error returns aren't detected. Added test cases for Tcl_Expr* and Tcl_Expr*Obj because there was very poor test coverage in those areas. * generic/tclParseExpr.c: Reworked parsing of numbers to call TclParseNumber rather than trying to do things locally. * generic/tclStrToD.c: Corrected a comment. Changed so that *endPtrPtr does not include any trailing whitespace. 2005-08-17 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclExecute.c: New routine TclIncrObj to centralize the increment operation needed in many places. Updated INST_DICT_INCR_IMM to make use of it. 2005-08-16 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclExecute.c: Made bit shifting opcodes and INST_MOD bignum-aware. * tests/scan.test: Making << bignum-aware means that repeated * tests/string.test: left shifting cannot turn a positive into a negative. Revised [int_range] and [largest_int] utility commands in the test suite that relied on that happening. Without revision they became infinite loops. * generic/tclExecute.c: Made binary bitwise opcodes bignum-aware. * generic/tclTomMath.h: Added mp_or and mp_xor to routines from * unix/Makefile.in: libtommath used by Tcl. * win/Makefile.in: * win/makefile.vc: 2005-08-15 Don Porter <[email protected]> [kennykb-numerics-branch] Updates from HEAD. * generic/tclExecute.c: More revisions to IllegalExprOperandType. Merged INST_BITNOT with INST_UMINUS and make it bignum-aware according to the rule: ~a = -a - 1. Disabled unused code and noted more TODOs. * generic/tclInt.decls: Disabled TclLooksLikeInt() and all callers. * generic/tclUtil.c: * generic/tclCompCmds.c: * generic/tclBasic.c: Rewrite of VerifyExprObjType(). * generic/tclIntDecls.h: make genstubs * generic/tclStubInit.c: * generic/tclExecute.c: Updated execution of comparison bytecodes to be bignum-aware, routing string compares through INST_STR_CMP. 2005-08-14 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclExecute.c: Updated execution of arithmetic bytecodes to be bignum-aware, and to allow calculations on NaN to produce a NaN result. INST_UMINUS updated to call mp_neg. * generic/tclTomMath.h: Added mp_and, mp_expt_d, and mp_neg to * unix/Makefile.in: routines from libtommath used by Tcl. * win/Makefile.in: * win/makefile.vc: 2005-08-13 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclObj.c: Extended Bignum auto-narrowing to auto-narrow to tclWideIntType when appropriate; this helps keep things working as the bytecode execution code is migrated to supporting bignums. * generic/tclExecute.c: Major overhaul of IllegalExprOperandType. Changed several TclNewFooObj() calls to more logically appropriate ones. Added several TODO comments marking opportunies for future work. Made more use of the eePtr->constants. Made INST_UMINUS bignum aware. 2005-08-12 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclExecute.c: Simplify doCondJump. Use eePtr->constants as result of INST_DICT_NEXT, INST_LAND, and INST_LOR. Separate INST_LNOT from INST_UMINUS and simplify. 2004-08-12 Kevin Kenny <[email protected]> * generic/tclClock.c (MktimeObjCmd): * library/clock.tcl (GetSystemTimeZone, LoadZoneinfoFile, ReadZoneinfoFile): * tests/clock.test (clock-50.1): Added functionality to read /etc/localtime if it exists, so that Tcl's time can track system time on Linux even if TZ is not set. Changed ::tcl::clock::Mktime to check for failure, and added a test case that mimics failure but is really success. 2005-08-11 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclExecute.c: Rewrite of INST_LAND/INST_LOR to take advantage of loss of "pure double" issues. Merged INST_UPLUS with INST_TRY_CVT_TO_NUMERIC and updated to use improved rules for impure "double"s as well. * generic/tclStrToD.c: Restored conditional generation of tclWideIntType values by TclParseNumber so that Tcl's not completely broken while bignum calculation support is incomplete. The NO_WIDE_TYPE macro can be used to disable this. * generic/tclBasic.c (ExprAbsFunc): First pass making [expr abs(.)] bignum-aware. 2004-08-11 Kevin Kenny <[email protected]> * generic/tclEvent.c: Eliminated the USE_THREAD_STORAGE * generic/tclInt.h: option (which is on in every build * generic/tclThread.c: generated by the standard configurator). * generic/tclThreadStorage.c: Eliminated the code for thread * unix/configure: specific data without USE_THREAD_STORAGE * unix/tcl.m4: and radically refactored the code * unix/tclConfig.h.in: for USE_THREAD_STORAGE so that it * unix/tclUnixThrd.c: has fewer dependencies on the order * win/configure: of finalization. (Also, made * win/Makefile.in: 'make distclean' on Windows clean * win/rules.vc: just a little bit cleaner.) * win/tcl.m4: * win/tclWinThrd.c: 2005-08-10 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclTomMath.h: Added mp_shrink, mp_to_unsigned_bin, * unix/Makefile.in: mp_to_unsigned_bin_n, and mp_unsigned_bin_size * win/Makefile.in: to routines from libtommath used by Tcl. * win/makefile.vc: * generic/tommath.h: make gentommath_h * generic/tclObj.c: Substantial rewrite to make all number parsing flow through TclParseNumber(). Also established the NO_WIDE_TYPE and BIGNUM_AUTO_NARROW #ifdef's to help track the assumptions of different portions of the code. * generic/tclInt.h: Added NO_WIDE_TYPE #ifdefs 2005-08-10 Kevin Kenny <[email protected]> * generic/tclEvent.c (Tcl_Finalize): Pushed Tcl_FinalizeLoad and Tcl_ResetFilesystem down after Tcl_FinalizeThreadAlloc because we can't unload DLL's until after their TSD keys are finalized. (Note that we'll still see aborts if an unloaded DLL has TSD - that still needs to be fixed. * tests/compExpr-old.test (compExpr-3.8): Made tests conditional on * tests/expr.test (expr-3.8): 'unix' because they get stack overflows on Win32 threaded builds, 2005-08-09 Vince Darley <[email protected]> * generic/tclPathObj.c: fix to [file rootname] bug in optimized code path reported on comp.lang.tcl. 2005-08-08 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclObj.c: Replaced some goto's with loops and started use of BIGNUM_AUTO_NARROW and NO_WIDE_TYPE. 2005-08-06 Donal K. Fellows <[email protected]> * generic/tclThreadStorage.c: Stop exposing the guts of the thread storage system through the internal stubs table. Client code should always use the standard API. 2005-08-05 Don Porter <[email protected]> [kennykb-numerics-branch] * generic/tclObj.c: Rewrote Tcl_GetDoubleFromObj(). 2005-08-05 Donal K. Fellows <[email protected]> * unix/tclUnixInit.c (localeTable): Solaris uses a non-standard name for the cp1251 charset. Thanks to Victor Wagner for reporting this. [Bug 1252475] 2005-08-05 Kevin Kenny <[email protected]> * win/makefile.vc: Removed unused file ldAout.tcl. * win/makefile.bc: [Bug #1244361] * tests/binary.test: Cleaned up testing for scanning of NaN. [Bug #1246264] * generic/tclBasic.c (ExprAbsFunc): Added code to handle the * tests/expr.test (expr-38.1): corner case of applying 'abs' to the smallest 32-bit integer. [Bug #1241572] 2005-08-04 Andreas Kupries <[email protected]> * generic/tclIO.c (CloseChannel): Fixed comment nit, added apparently missing word to complete a sentence. * generic/tclObj.c (Tcl_DbDecrRefCount): Fixed whitespace nit in panic message. 2005-08-04 Don Porter <[email protected]> [kennykb-numerics-branch] Updated from HEAD * generic/tclObj.c: Rewrote Tcl_GetBooleanFromObj() and supporting routines to make use of TclParseNumber. This reduces the potential number of times a string value must be scanned. * generic/tclObj.c: Simplified routines that manage the typeTable. Deleted the UpdateStringOfBoolean() routine, that can never be called. 2005-08-03 Don Porter <[email protected]> * generic/tclCompExpr.c: Untangled some dependencies in the * generic/tclEvent.c: order of finalization routines. * generic/tclInt.h: [Bug 1251399] * generic/tclObj.c: 2005-08-02 Don Porter <[email protected]> [kennykb-numerics-branch] Updated from HEAD 2005-07-30 Daniel Steffen <[email protected]> * unix/tclLoadDyld.c (TclpDlopen, TclpLoadMemory): workarounds for bugs/changes in behaviour in Mac OS X 10.4 Tiger. 2005-07-29 Donal K. Fellows <[email protected]> * generic/tclCmdIL.c (InfoGlobalsCmd): Even in high-speed mode, still have to take care with non-existant variables. [Bug 1247135] 2005-07-28 Mo DeJong <[email protected]> * win/README: Update link to msys_mingw8.zip. 2005-07-28 Don Porter <[email protected]> * tests/compExpr-old.test: Still more conversion of "nonPortable" * tests/error.test: tests into tests with constraints that * tests/expr-old.test: describe the limits of their * tests/expr.test: portability. Also more consolidation * tests/fileName.test: of constraint synonyms. * tests/format.test: wideis64bit, 64bitInts => wideIs64bit * tests/get.test: wideIntegerUnparsed => wideIs32bit * tests/load.test: wideIntExpressions => wideBiggerThanInt * tests/obj.test: * tests/parseExpr.test: Dropped "roundOffBug" constraint that * tests/string.test: protected from buggy sprintf. 2005-07-28 Donal K. Fellows <[email protected]> * generic/tclPipe.c (TclCreatePipeline): Arrange for POSIX systems to * unix/tclUnixPipe.c (TclpOpenFile): use the O_APPEND flag for * tests/exec.test (exec-19.1): files opened in a pipeline like ">>this". Note that Windows cannot support such access; there is no equivalent flag on the handle that can be set at the kernel-call level. The test is unix-specific in every way. [Bug 1245953] 2005-07-27 Don Porter <[email protected]> * generic/tclUtil.c: Converted the $::tcl_precision value to be kept per-thread to prevent different threads from stomping on each others' formatting prescriptions. ***POTENTIAL INCOMPATIBILITY*** Multi-threaded programs that set the value of ::tcl_precision will now have to set it in each thread. * tests/expr.test: Consolidated equivalent constraints into * tests/fileName.test: single definitions and (more precise) names: * tests/get.test: longis32bit, 32bit, !intsAre64bit => longIs32bit * tests/listObj.test: empty => emptyTest; winOnly => win * tests/obj.test: intsAre64bit => longIs64bit Also updated some "nonPortable" tests to use constraints that mark precisely what about them isn't portable, so the tests can run where they work. * library/init.tcl ([unknown]): Corrected return code handling in the portions of [unknown] that expand incomplete commands during interactive operations. [Bug 1214462]. 2005-07-26 Mo DeJong <[email protected]> * unix/configure: Regen. * unix/configure.in: Check for a $prefix/share directory and add it the the package if found. This will check for Tcl packages in /usr/local/share when Tcl is configured with the default dist install. [patch 1231015] 2005-07-26 Don Porter <[email protected]> * generic/tclBasic.c (Tcl_CallWhenDeleted): Converted to use per-thread counter, rather than a process global one that required mutex protection. [RFE 1077194] * generic/tclNamesp.c (TclTeardownNamespace): Re-ordering so that * tests/trace.test (trace-34.4): command delete traces fire while the command still exists. [Bug 1047286] 2005-07-24 Mo DeJong <[email protected]> * unix/configure: Regen. * unix/tcl.m4 (SC_PROG_TCLSH, SC_BUILD_TCLSH): * win/configure: Regen. * win/tcl.m4 (SC_PROG_TCLSH, SC_BUILD_TCLSH): Split confused search for tclsh on PATH and build and install locations into two macros. SC_PROG_TCLSH searches just the PATH. SC_BUILD_TCLSH determines the name of the tclsh executable in the Tcl build directory. [Tcl bug 1160114] [Tcl patch 1244153] 2005-07-23 Don Porter <[email protected]> * library/auto.tcl: Updates to the Tcl script library to make * library/history.tcl: use of Tcl 8.4 features. Forward port of * library/init.tcl: appropriate portions of [Patch 1237755]. * library/package.tcl: * library/safe.tcl: * library/word.tcl: 2005-07-23 Mo DeJong <[email protected]> * tests/string.test: Add string is tests for functionality that was not tested. * win/README: Update msys + mingw URL. Remove old Cygwin + mingw info. 2005-07-23 Miguel Sofer <[email protected]> * generic/tclExecute.c (INST_DICT_*): stop 2 compiler warnings for uninitialised variables. 2005-07-23 Donal K. Fellows <[email protected]> * generic/tclExecute.c (TEBC:INST_DICT_INCR_IMM): Fix the incrementor to work correctly with wide values. 2005-07-21 Donal K. Fellows <[email protected]> * generic/tclCompCmds.c (TclCompileDictCmd): First run at a compiler * generic/tclExecute.c (TclExecuteByteCode): for dictionaries. Also added an instruction to support 'finally'-like clauses, exposed more of the dict guts to the rest of the core, and defined a few tests to exercise more obscure parts of the compiler's operation that were bugs during development. 2005-07-21 Kevin B. Kenny <[email protected]> * library/ldAout.tcl (***REMOVED***): Removed support for ancient * unix/configure: BSD's, IRIX 4, RISCos and * unix/Makefile.in: Ultrix. Removed two files * unix/tcl.m4: whose code is used only on * unix/tclLoadAout.c (***REMOVED***): those antique platforms. ***POTENTIAL INCOMPATIBILITY*** if anyone actually uses those platforms; it is to be noted though, that an error in the installer has actually not caused a necessary file to be installed on those platforms in several releases, and nobody's complained. 2005-07-16 Kevin B. Kenny <[email protected]> * generic/tclStrToD.c (RefineResult): Plugged a stupid memory leak in RefineResult (called from Tcl_StrToD). [Tk Bug 1227781] 2005-07-15 Kevin B. Kenny <[email protected]> * generic/tclClock.c (TclClockLocaltimeObjCmd,ThreadSafeLocalTime): * library/clock.tcl (GuessWindowsTimeZone, ClearCaches): * tests/clock.test (clock-49.1, clock-49.2): Handle correctly the case where localtime() returns NULL to report a conversion error. Also handle the case where the Windows registry contains timezone values that can be mapped to a tzdata file name but the corresponding file does not exist or is corrupted, by falling back on a Posix timezone string instead; this last case will avoid calls to localtime() in starpacks on Windows. [Bug 1237907] 2005-07-14 Donal K. Fellows <[email protected]> * generic/tclCompile.c: Update to follow style guidelines. (TclPrintInstruction): Reorganize to do better printing out of bytecode with far fewer "special hacks" for particular opcodes. * generic/tclCompile.h: Requires two new opcode types. 2005-07-13 Don Porter <[email protected]> * unix/tclUnixSock.c: Use a ProcessGlobalValue to store the * win/tclWinSock.c: value returned by Tcl_GetHostName() ([info hostname]). Also re-order initialization of the value on Windows to favor GetComputerName() over gethostname() as a source of the information. 2005-07-12 Kevin Kenny <[email protected]> [kennykb-numerics-branch] Updated from HEAD * generic/tclCmdMZ.c (Tcl_StringObjCmd): * generic/tclInt.h: * generic/tclObj.c (Tcl_GetDoubleFromObj, SetDoubleFromAny, Tcl_GetIntFromObj, SetIntOrWideFromAny): * generic/tclStrToD.c (TclParseNumber, etc.): * tclTomMathInterface.c (TclBNInitBignumFromWideUInt): * tests/obj.test (obj-1.1, obj-2.2, obj-3.1, obj-3.2): Initial attempt at an implementation of TIP #249, comprising a unified parser and modifications to the Tcl_Get*FromObj routines to use it. Further integration of the parser is necessary and planned. 2005-07-12 Donal K. Fellows <[email protected]> * doc/lsearch.n: Clarify documentation of -exact option; wording was open to misinterpretation by non-English speakers. 2005-07-11 Donal K. Fellows <[email protected]> * generic/tclExecute.c: General style cleanup. 2005-07-08 Mo DeJong <[email protected]> * generic/tclExecute.c (TclExecuteByteCode): Reimplement long and wide type integer division and modulus operations so that the smallest and largest integer values are handled properly. The divide operation is more efficient since it no longer does a modulus or negation and only checks for a remainder when the quotient will be a negative number. The modulus operation is now a bit more complex because of a number of special cases dealing with the smallest and largest integers. * tests/expr.test: Add test cases for division and modulus operations on the smallest and largest integer values for 32 and 64 bit types. [Patch 1230205] 2005-07-06 Don Porter <[email protected]> * generic/tclLink.c: Simplified LinkTraceProc [Bug 1208108]. 2005-07-05 Don Porter <[email protected]> * unix/Makefile.in: Purged use of TCLTESTARGS [RFE 1161550]. * generic/tclUtil.c: Converted TclFormatInt() into a macro. * generic/tclInt.decls: [RFE 1194015] * generic/tclInt.h: * generic/tclIntDecls.h: make genstubs * generic/tclStubInit.c: * generic/tclNamesp.c: Allow for [namespace import] of a command * tests/namespace.test: over a previous [namespace import] of itself without throwing an error. [RFE 1230597] 2005-07-04 Donal K. Fellows <[email protected]> * generic/tclDictObj.c (DictForCmd, DictFilterCmd): Interlocking of dictionary internal representations is now done in the core of the dict iterator. Purge the last attempts at doing it at a higher level as they didn't work and were no longer needed. 2005-07-01 Zoran Vasiljevic <[email protected]> * unix/tclUnixNotfy.c: protect against spurious wake-ups while waiting on the condition variable when tearing down the notifier thread [Bug# 1222872]. 2005-06-28 Mo DeJong <[email protected]> * generic/tclExecute.c (TclExecuteByteCode): When parsing an integer operand for a unary minus expression operator, check for a wide integer that is actually LONG_MIN. If found, convert it back to a long int type. * tests/expr.test: Add constraint for 32bit long int type and 64bit wide int type. Add tests that parse the smallest/largest long int and wide int values. 2004-06-24 Kevin Kenny <[email protected]> * generic/tclEvent.c (Tcl_Finalize): * generic/tclInt.h: * generic/tclPreserve.c (TclFinalizePreserve): Changed the finalization logic so that Tcl_Preserve finalizes after exit handlers run; a lot of code called from Tk's exit handlers presumes that Tcl_Preserve will still work even from an exit handler. 2005-06-24 Don Porter <[email protected]> * library/auto.tcl: Make file safe to re-[source] without destroying registered auto_mkindex_parser hooks. 2005-06-23 Kevin Kenny <[email protected]> * win/tclWinChan.c: More rewriting of __asm__ blocks that implement * win/tclWinFCmd.c: SEH in GCC, because mingw's gcc 3.4.2 is not as forgiving of violations committed by the old code and caused panics. [Bug #1225957] 2005-06-23 Daniel Steffen <[email protected]> * tools/tcltk-man2html.tcl: fixed useversion glob pattern to accept multi-digit patchlevels. 2005-06-22 Don Porter <[email protected]> * win/tclWinFile.c: Potential buffer overflow. [Bug 1225571] Thanks to Pat Thoyts for discovery and fix. 2005-06-22 Kevin Kenny <[email protected]> * generic/tclInt.h: Changed the finalization * generic/tclEvent.c (Tcl_Finalize): logic to defer the * generic/tclIO.c (TclFinalizeIOSubsystem): shutdown of the pipe * unix/tclUnixPipe.c (TclFinalizePipes): management until after * win/tclWinPipe.c (TclFinalizePipes): all channels have been closed, in order to avoid a situation where the Windows PipeCloseProc2 would re-establish the exit handler after exit handlers had already run, corrupting the heap. [Bug #1225727] Also corrected a potential read of uninitialized memory in PipeClose2Proc [Bug #1225044] 2005-06-21 Andreas Kupries <[email protected]> * generic/tclInt.h: Followup to change made on 2005-06-18 by Daniel Steffen. There are compilers (*) who error out on the redefinition of WORDS_BIGENDIAN. We have to undef the previous definition (on the command line) first to make this acceptable. (*): AIX native. 2005-06-21 Kevin B. Kenny <[email protected]> * generic/tclFileName.c: Changed [file split] and [file join] to treat Windows drive letters similarly to ~ syntax and make sure that they appear with "./" in front when they are in intermediate components of the path. [Bug 1194458] * tests/fileName.test: Added test for the above bug. 2005-06-21 Don Porter <[email protected]> * generic/tclBasic.c: Added missing walk of the list of active traces * generic/tclTrace.c: to cleanup references to traces being deleted. * generic/tclInt.h: [Bug 1201035] Made the walk of the active trace * tests/trace.test (trace-34.*): list aware of the direction of trace scanning, so the proper correction can be made. [Bug 1224585] 2005-06-21 Donal K. Fellows <[email protected]> * unix/tcl.m4 (SC_ENABLE_SYMBOLS): Only enable the 'compile' special debugging feature when requested in configure.in; removes irrelevant junk from the configure files of extensions that use Tcl's tcl.m4. 2005-06-20 Donal K. Fellows <[email protected]> * generic/tclCompile.h (INST_PUSH_RETURN_OPTIONS): New opcode to allow * generic/tclCompCmds.c (TclCompileCatchCmd): compilation of TIP90 * generic/tclCompile.c: catch [Bug 1219112] * generic/tclExecute.c (TclExecuteByteCode): * generic/tclCompCmds.c (TclCompileSwitchCmd): Ensure we spill to the command form in all cases where it generates an error. 2005-06-20 Mo DeJong <[email protected]> * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Generate an error if a mode argument like -exact is passed more than once to the switch command. The previous implementation silently accepted invalid switch invocations like [switch -exact -glob $str ...]. * tests/for.test: Check some error cases when invoking continue and break inside a for loop next script. * tests/switch.test: Add checks for shortened version of a mode argument like -exact. Add test for more than one mode argument. Add test for odd case of passing a variable as a body script. 2005-06-18 Daniel Steffen <[email protected]> * generic/tclInt.h: ensure WORDS_BIGENDIAN is defined correctly with fat compiles on Darwin (i.e. ppc and i386 at the same time), the configure AC_C_BIGENDIAN check is not sufficient in this case because a single run of the compiler builds for two architectures with different endianness. * unix/tcl.m4 (Darwin): add -headerpad_max_install_names to LDFLAGS to ensure we can always relocate binaries with install_name_tool. * unix/configure: autoconf-2.59 2005-06-18 Donal K. Fellows <[email protected]> * generic/tclCmdAH.c (Tcl_FormatObjCmd): Fix for [Bug 1154163]; only * tests/format.test: insert 'l' modifier when it is needed. 2005-06-17 Donal K. Fellows <[email protected]> * generic/tclTimer.c (AfterDelay): Split out the code to manage synchronous-delay [after] commands. * tests/interp.test (interp-34.10): Time limits and synch-delay [after] did not mix well... [Bug 1221395] 2005-06-14 Donal K. Fellows <[email protected]> * generic/tclBasic.c (Tcl_DeleteCommandFromToken): Only delete a * tests/namespace.test (namespace-49.2): command from the hashtable on reentrant processing if it has not been already deleted; at least three deletes of the same command are possible. [Bug 1220058] * generic/tclTrace.c (TraceCommandProc): Remove bogus error message creation when traces trigger in situations where the command has already been deleted. 2005-06-13 Vince Darley <[email protected]> * generic/tclFCmd.c: correct fix to file mkdir 2005-06-09, [Bug 1219176] 2005-06-12 Donal K. Fellows <[email protected]> * generic/tclCompCmds.c: Factor out some common idioms into named forms for greater clarity. 2005-06-10 Donal K. Fellows <[email protected]> * doc/chan.n: Fold in the descriptive parts of the documentation for all the commands that [chan] builds on top of. 2005-06-09 Vince Darley <[email protected]> * generic/tclFCmd.c: fix to race condition in file mkdir [Bug 1217375] * doc/glob.n: improve glob documentation [Bug 1190891] 2005-06-09 Donal K. Fellows <[email protected]> * doc/expr.n, doc/mathfunc.n: Fix minor typos [Bug 1211078] and add mention of distinctly-relevant [namespace path] subcommand. 2005-06-07 Don Porter <[email protected]> * generic/tclInt.h: Reduced the Tcl_ObjTypes "index", * generic/tclIndexObj.c: "ensembleCmd", "localVarName", and * generic/tclNamesp.c: "levelReference" to file static scope. * generic/tclProc.c: * generic/tclVar.c: * generic/tclObj.c: Restored registration of the "procbody" Tcl_ObjType, as required by the tclcompiler application. * generic/tclDecls.h: make genstubs * generic/tclStubInit.c: 2005-06-07 Donal K. Fellows <[email protected]> * generic/tclIO.c (Tcl_ChannelTruncateProc): Stop proliferation of * generic/tcl.h: channel type versions * doc/CrtChannel.3: following advice from AKu Bump patchlevel to a4 to distinguish from a3 release. * generic/tclInt.h (INTERP_TRACE_IN_PROGRESS): Add flag so the error * generic/tclIndexObj.c (Tcl_WrongNumArgs): messages from ensembles * generic/tclIOCmd.c (Tcl_ReadObjCmd): can be correct. TIP#208 IMPLEMENTATION * library/init.tcl: Create the chan ensemble. * tests/chan.test: Rudimentary test suite. * doc/chan.n: General documentation. TRUNCATION API (part of TIP#208) * generic/tcl.h, generic/tcl.decls: Declaration of the API. * doc/CrtChannel.3, doc/OpenFileChnl.3: Documentation of the API. * generic/tclBasic.c (Tcl_CreateInterp): Create the mapping into Tcl. * generic/tclIOCmd.c (TclChanTruncateObjCmd): Implementation of Tcl-level truncation API. * generic/tclIO.c (Tcl_TruncateChannel): Generic C-level truncation API implementation. * unix/tclUnixChan.c (FileTruncateProc): Basic implementation of truncating driver. * win/tclWinChan.c (FileTruncateProc): Added implementation of file truncation for Windows. * tests/chan.test (chan-15.2): Added real test of truncation. 2005-06-06 Kevin B. Kenny <[email protected]> * win/tclWin32Dll.c: Corrected another buglet in the assembly code for stack probing on Win32/gcc. [Bug #1213678] * generic/tclObj,c: Added missing 'static' on definition of UpdateStringOfBignum, and removed a 'switch' on a 'long long' operand (which HP-UX native 'cc' seems unable to handle). [Bug #1215775] 2005-06-04 Jeff Hobbs <[email protected]> *** 8.5a3 TAGGED FOR RELEASE *** * unix/Makefile.in (dist): add libtommath 2005-06-03 Donal K. Fellows <[email protected]> * library/parray.tcl (parray): Only generate the sorted list of element names once. Thanks to Andreas Leitgeb for spotting this. 2005-06-03 Daniel Steffen <[email protected]> * macosx/Makefile: fixed 'embedded' target. 2005-06-02 Jeff Hobbs <[email protected]> * unix/Makefile.in (html): add BUILD_HTML_FLAGS optional var * tools/tcltk-man2html.tcl: add a --useversion to prevent confusion when multiple Tcl source dirs exist. 2005-06-01 Don Porter <[email protected]> * generic/tclBasic.c: For compatibility with earlier Tcl releases, * generic/tclResult.c: when a command procedure simply does a * generic/tclTest.c: "return TCL_RETURN;" we must interpret that * tests/result.test: the same as "return Tcl_SetReturnOptions(interp, Tcl_NewObj());" [Bug 1209759]. 2005-06-01 Donal K. Fellows <[email protected]> * generic/tclCompCmds.c (TclCompileSwitchCmd): Allow compilation of -nocase -glob [switch]es (only one we know how to compile). TIP#241 IMPLEMENTATION from Joe Mistachkin * generic/tclCmdIL.c (Tcl_LsearchObjCmd, Tcl_LsortObjCmd): * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Implementation of -nocase option for [lsearch], [lsort] and [switch] commands. * win/tclWinPort.h: Win uses nonstandard function names... * tests/cmdIL.test, tests/lsearch.test, tests/switch.test: Tests * doc/lsearch.n, doc/lsort.n, doc/switch.n: Docs * generic/tclCompCmds.c (TclCompileLindexCmd): Compile the most common case of [lindex] more efficiently. * unix/tclUnixNotfy.c (Tcl_FinalizeNotifier): Pass the correct number of arguments to Tcl_JoinThread. 2005-05-31 Donal K. Fellows <[email protected]> * unix/configure.in, unix/tcl.m4: Standardize generation of help messages to always use AC_HELP_STRING and always (except for --with-tcl and --with-tk, where the default is complex) say what the default is. 2005-05-31 Zoran Vasiljevic <[email protected]> * unix/tclUnixNotfy.c: the notifier thread is now created as joinable thread and it is properly joined in Tcl_FinalizeNotifier. This is an attempt to fix the Tcl Bug #1082283. 2005-05-30 Zoran Vasiljevic <[email protected]> * win/tclWinThrd.c: Fixed Tcl Bug #1204064. 2005-05-30 Donal K. Fellows <[email protected]> TIP #229 IMPLEMENTATION * generic/tclNamesp.c (Tcl_FindCommand, TclResetShadowedCmdRefs) (NamespacePathCmd, SetNsPath, UnlinkNsPath, TclInvalidateNsPath): Implementation of the [namespace path] command and the command name resolution engine. * doc/info.n, doc/namespace.n: Doc updates. * tests/namespace.test (namespace-51.*): Test updates. * generic/tclResolve.c (BumpCmdRefEpochs, Tcl_SetNamespaceResolvers): * generic/tclBasic.c (Tcl_CreateCommand, Tcl_CreateObjCommand): Ensure that people don't see stale paths. * generic/tclInt.h (Namespace, NamespacePathEntry): Structure defs. * generic/tclCmdIL.c (InfoCommandsCmd): Updates to [info commands]. 2005-05-26 Daniel Steffen <[email protected]> * macosx/Makefile: moved & corrected EMBEDDED_BUILD check. * unix/configure.in: corrected framework finalization to softlink stub library to Versions/8.x subdir instead of Versions/Current. * unix/configure: autoconf-2.59 2005-05-25 Jeff Hobbs <[email protected]> * generic/tclCmdMZ.c (Tcl_TimeObjCmd): add necessary cast 2005-05-25 Don Porter <[email protected]> TIP#182 IMPLEMENTATION [Patch 1165062] * doc/mathfunc.n: New built-in math function bool(). * generic/tclBasic.c: * tests/expr.test: * tests/info.test: 2005-05-24 Don Porter <[email protected]> * library/init.tcl: Updated [unknown] to be sure the [return] * tests/init.test: options from an auto-loaded command are seen correctly by the caller. 2005-05-24 Daniel Steffen <[email protected]> * tests/env.test: added DYLD_FRAMEWORK_PATH to the list of env vars that need to be handled specially. * macosx/Makefile: * macosx/README: * macosx/Tcl-Info.plist.in (new file): * unix/Makefile.in: * unix/configure.in: * unix/tcl.m4: * unix/tclUnixInit.c: moved all Darwin framework build support from macosx/Makefile into the standard unix configure/make buildsystem, the macosx/Makefile is no longer required to build Tcl.framework (but its functionality is still available for backwards compatibility). * unix/configure: autoconf-2.59 * generic/tclIOUtil.c (TclLoadFile): * generic/tclInt.h: * unix/tcl.m4: * unix/tclLoadDyld.c: added support for [load]ing .bundle binaries in addition to .dylib's: .bundle's can be [unload]ed (unlike .dylib's), and can be [load]ed from memory, e.g. directly from VFS without needing to be written out to a temporary location first. [Bug 1202209] * unix/configure: autoconf-2.59 * unix/tclConfig.h.in: autoheader-2.59 * generic/tclCmdMZ.c (Tcl_TimeObjCmd): change [time] called with a count > 1 to return a string with a float value instead of a rounded off integer. [Bug 1202178] * doc/expr.n: * doc/string.n: fixed roff syntax complaints from 'make html'. 2005-05-20 Don Porter <[email protected]> * generic/tclParseExpr.c: Corrected parser to recognize all boolean literals accepted by Tcl_GetBoolean, including prefixes like "y" and "f", and to allow "eq" and "ne" as function names in the proper context. [Bug 1201589]. 2005-05-19 Donal K. Fellows <[email protected]> * generic/tclBasic.c (TclEvalObjvInternal): Rewrite for greater clarity; although 'goto' is Bad, the contortions you have to go through to avoid it can be worse... 2005-05-19 Daniel Steffen <[email protected]> * macosx/tclMacOSXNotify.c (Tcl_InitNotifier): fixed crashing CFRelease of runLoopSource in Tcl_InitNotifier (reported by Zoran): CFRunLoopAddSource doesn't CFRetain, so can only CFRelease the runLoopSource in Tcl_FinalizeNotifier. 2005-05-18 Don Porter <[email protected]> * generic/tclBasic.c (Tcl_ExprBoolean): Rewrite as wrapper around Tcl_ExprBooleanObj. * generic/tclCmdMZ.c ([string is boolean/true/false]): Rewrite dropping string-based Tcl_GetBoolean call, so that internal reps are kept for subsequent quick boolean operations. * generic/tclExecute.c: Dropped most special handling of the "boolean" Tcl_ObjType, since that type should now be rarely encountered. * doc/BoolObj.3: Rewrite of documentation dropping many details about the internals of Tcl_Objs. Shorter documentation focuses on the function and use of the routines. * generic/tclInt.h: Revision to the "boolean" Tcl_ObjType, so * generic/tclObj.c: that only string values like "yes" and "false" * tests/obj.test: are kept as the "boolean" Tcl_ObjType. The string values "0" and "1" are kept as "int" Tcl_ObjType, which also produce quick calls to Tcl_GetBooleanFromObj(). Since this internal change means a Tcl_ConvertToType to a "boolean" Tcl_ObjType might not produce a Tcl_Obj of type "boolean", the registration of the "boolean" type is also removed. ***POTENTIAL INCOMPATIBILITY*** For callers of Tcl_GetObjType on the type name "boolean". 2005-05-17 Don Porter <[email protected]> * generic/tclObj.c (TclInitObjSubsystem): Removed the * tests/listObj.test: registration of the Tcl_ObjType's "list", * tests/obj.test: "procbody", "index", "ensembleCommand", "localVarName", and "levelReference". The only reason to register a Tcl_ObjType is to have it returned by Tcl_GetObjType, and the only reason for that is to retrieve a (Tcl_ObjType *) to pass to Tcl_ConvertToType(). None of the types above can support a Tcl_ConvertToType() call; they panic. Better not to offer something than to lead users into a panic. ***POTENTIAL INCOMPATIBILITY*** For callers of Tcl_GetObjType on the type names listed above. 2005-05-15 Kevin Kenny <[email protected]> * win/tclWin32Dll.c: conditioned definition of EXCEPTION_REGISTRATION structures on HAVE_NO_SEH, to fix a bug in buildability on MSVC. 2005-05-14 Daniel Steffen <[email protected]> * generic/tclInt.decls: * generic/tclTest.c: * generic/tclUtil.c: * win/tclWin32Dll.c: fixed link error due to direct access by tclTest.c to the MODULE_SCOPE tclPlatform global: renamed existing TclWinGetPlatform() accessor to TclGetPlatform() and moved it to generic code so that it can be used by on all platforms where MODULE_SCOPE is enforced. * macosx/tclMacOSXBundle.c: * unix/tclUnixInit.c: * unix/tcl.m4 (Darwin): made use of CoreFoundation API configurable and added test of CoreFoundation availablility to allow building on ppc64, replaced HAVE_CFBUNDLE by HAVE_COREFOUNDATION; test for availability of Tiger or later OSSpinLockLock API. * unix/tclUnixNotfy.c: * unix/Makefile.in: * macosx/tclMacOSXNotify.c (new file): when CoreFoundation is available, use new CFRunLoop based notifier: allows easy integration with other event loops on Mac OS X, in particular the TkAqua Carbon event loop is now integrated via a standard tcl event source (instead of TkAqua upon loading having to finalize the exsting notifier and replace it with its custom version). [Patch 1202052] * tests/unixNotfy.test: don't run unthreaded tests on Darwin since notifier may be using threads even in unthreaded core. * unix/tclUnixPort.h: * unix/tcl.m4 (Darwin): test for thread-unsafe realpath durning configure, as Darwin 7 and later realpath is threadsafe. * macosx/Makefile: enable configure caching. * unix/configure.in: wrap tclConfig.h header in #ifndef _TCLCONFIG so that it can be included more than once without warnings from gcc4.0 (as happens e.g. when including both tclInt.h and tclPort.h) * macosx/tclMacOSXBundle.c: * unix/tclUnixChan.c: * unix/tclLoadDyld.c: * unix/tclUnixInit.c: fixed gcc 4.0 warnings. * unix/configure: autoconf-2.59 * unix/tclConfig.h.in: autoheader-2.59 * generic/tclIntDecls.h: * generic/tclIntPlatDecls.h: * generic/tclStubInit.c: make genstubs 2005-05-13 Kevin Kenny <[email protected]> * win/tclWin32Dll.c: Further rework of the SEH logic. All EXCEPTION_REGISTRATION records are now in the activation record rather than pushed on the stack. 2005-05-13 Don Porter <[email protected]> * generic/tclBasic.c: Dropped the TCL_NO_MATH configuration. * generic/tclBinary.c: It's believed this has not been working * generic/tclExecute.c: in a long time. Tcl needs math.h. * unix/Makefile.in: [RFE 1200680]. 2005-05-12 Kevin Kenny <[email protected]> * doc/mathfunc.n: Changed NAME line to match the name of the page. 2005-05-11 Kevin Kenny <[email protected]> [kennykb-numerics-branch] Resynchronized with the HEAD; at this checkpoint [-rkennykb-numerics-branch-20050511], the HEAD and kennykb-numerics-branch contain identical code. 2005-05-11 Kevin Kenny <[email protected]> * generic/tclStrToD.c (TclStrToD, RefineResult, ParseNaN): Changed the code to cast 'char' to UCHAR explicitly when using ctype macros, to silence complaints from the Solaris compiler. 2005-05-10 Jeff Hobbs <[email protected]> * unix/tclUnixFCmd.c: add lint attr to enum to satisfy strictly compliant compilers that don't like trailing ,s. * tests/string.test: string-10.[21-30] * generic/tclCmdMZ.c (Tcl_StringObjCmd): add extra checks to prevent possible UMR in unichar cmp function for string map. 2005-05-10 Kevin Kenny <[email protected]> * generic/tclBinary.c (FormatNumber): Fixed a bug where NaN's resulted in reads of uninitialized memory when using 'd', 'q', or 'Q' format. * generic/tclStrToD.c (ParseNaN, TclFormatNaN): Added code to handle the peculiarities of HP's PA_RISC, which uses a different 'quiet' bit in NaN from everyone else. * libtommath/tommath_superclass.h: Corrected C++-style comment. 2005-05-10 Kevin Kenny <[email protected]> Merged all changes on kennykb-numerics-branch back into the HEAD. TIP's 132 and 232 are now Final. 2005-05-10 Kevin Kenny <[email protected]> [kennykb-numerics-branch] Merged changes from HEAD. 2005-05-10 Miguel Sofer <[email protected]> * generic/tclExecute.c (ExponLong, ExponWide): * tests/expr.test (expr-23.34/35): fixed special case 'i**0' for i>0 [Bug 1198892] 2005-05-09 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] * win/tclWin32Dll.c (TclpCheckStackSpace, TclWinCPUID): Reworked structured event handling to function even with -fomit-frame-pointers. 2005-05-08 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] * generic/tclStrToD.c: Made code more portable by finding a workaround for MSVC's 'volatile' issue that does not require conditional compilation. * win/tclWin32Dll.c (TclWinCPUID): Removed structured event handling from the GCC code since (a) bad code is generated by the instruction scheduling with -O2, and (b) it's not needed on any reasonably modern CPU. 2005-05-07 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] * generic/tclEvent.c: Moved initialization of tclStrToD.c's * generic/tclInt.h: static constants into a procedure called * generic/tclStrToD.c: from TclInitSubsystems to avoid double checked locking protocol. Cleaned up an issue where MSVC ignored the 'volatile' specifier, causing incorrect comparison of an underflowed number against zero. 2005-05-06 Jeff Hobbs <[email protected]> * unix/tcl.m4, unix/configure: correct Solaris 10 (5.10) check and add support for x86_64 Solaris cc builds. 2005-05-05 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] Merged with HEAD. 2005-05-05 Kevin B. Kenny <[email protected]> * win/tclWinThrd.c: Corrected a compilation error on the --enable-threads configuration. 2005-05-05 Don Porter <[email protected]> * generic/tclInt.decls: Converted TclMatchIsTrivial to a macro. * generic/tclInt.h: * generic/tclUtil.c: * generic/tclIntDecls.h: `make genstubs` * generic/tclStubInit.c: * generic/tclBasic.c: Added callers of TclMatchIsTrivial where * generic/tclCmdIL.c: a search can be done more efficiently * generic/tclCompCmds.c:when it is recognized that a pattern match * generic/tclDictObj.c: is really an exact match. [Patch 1076088] * generic/tclIO.c: * generic/tclNamesp.c: * generic/tclVar.c: * generic/tclCompCmds.c: Factored common efficiency trick into a macro named CompileWord. * generic/tclCompCmds.c: Replaced all instance of * generic/tclCompile.c: TCL_OUT_LINE_COMPILE with TCL_ERROR. * generic/tclInt.h: Now that we've eradicated the mistaken * tests/appendComp.test: notion of a "compile-time error", we can use the TCL_ERROR return code to signal any failure to produce bytecode. 2005-05-03 Don Porter <[email protected]> * doc/DString.3: Eliminated use of identifier "string" in Tcl's * doc/Environment.3: public C API to avoid conflict/confusion with * doc/Eval.3: the std::string of C++. * doc/ExprLong.3, doc/ExprLongObj.3, doc/GetInt.3, doc/GetOpnFl.3: * doc/ParseCmd.3, doc/RegExp.3, doc/SetResult.3, doc/StrMatch.3: * doc/Utf.3, generic/tcl.decls, generic/tclBasic.c, generic/tclEnv.c: * generic/tclGet.c, generic/tclParse.c, generic/tclParseExpr.c: * generic/tclRegexp.c, generic/tclResult.c, generic/tclUtf.c: * generic/tclUtil.c, unix/tclUnixChan.c: * generic/tclDecls.h: `make genstubs` 2005-05-02 Don Porter <[email protected]> * generic/tcl.decls: * generic/tclBasic.c: Simplified implementation of Tcl_ExprString. * tests/expr-old.test: * generic/tclDecls.h: `make genstubs` 2005-04-30 Daniel Steffen <[email protected]> * unix/tclUnixNotfy.c: applied dkf's tkMacOSXNotify.c cleanup changes. 2005-04-29 Don Porter <[email protected]> TIP#176 IMPLEMENTATION [Patch 1165695] * generic/tclUtil.c: Extended TclGetIntForIndex to recognize index formats including end+integer and integer+/-integer. * generic/tclCmdMZ.c: Extended the -start switch of [regexp] and [regsub] to accept all index formats known by TclGetIntForIndex. * doc/lindex.n: Updated docs to note new index formats. * doc/linsert.n, doc/lrange.n, doc/lreplace.n, doc/lsearch.n: * doc/lset.n, doc/lsort.n, doc/regexp.n, doc/regsub.n, doc/string.n: * tests/cmdIL.test: Updated tests. * tests/compile.test, tests/lindex.test, tests/linsert.test: * tests/lrange.test, tests/lreplace.test, tests/lsearch.test: * tests/lset.test, tests/regexp.test, tests/regexpComp.test: * tests/string.test, tests/stringComp.test, tests/util.test: 2005-04-28 Don Porter <[email protected]> * tests/unixInit.test (7.1): Alternative fix for the 2004-11-11 commit. 2005-04-27 Don Porter <[email protected]> * library/init.tcl: Corrected flaw in interactive command * tests/main.test: auto-completion. [Bug 1191409]. TIP#183 IMPLEMENTATION [Patch 577093] * generic/tclIOUtil.c (TclGetOpenModeEx): New routine. * generic/tclInt.h: * generic/tclIO.c (Tcl_OpenObjCmd): Support for "b" and * doc/open.n: "BINARY" in "access" argument to [open]. * tests/ioCmd.test: 2005-04-26 Kevin B. Kenny <[email protected]> * generic/tclBinary.c (FormatNumber): Dredge the NaN out of the internal representation if Tcl_GetDoubleFromObj returns TCL_ERROR on a NaN. * generic/tclObj.c (Tcl_GetDoubleFromObj): Restored silent overflow/underflow behaviour that the merge of 2004-04-25 messed up. Thanks to Don Porter for calling attention to this bug. Also removed an uninitialised memory reference in this function that valgrind caught. Also changed to return TCL_ERROR on a pure NaN. * generic/tclStrToD.c (RefineResult): Added a test for the initial approximation being HUGE_VAL; this test avoids EDOM being returned from ldexp on some platforms on input values exceeding the floating point range. * tests/expr.test (expr-29.*, expr-30.*): Added further tests of overflow/underflow on input conversions. 2005-04-25 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] Merged with HEAD. * doc/CrtMathFunc.n: Revised documentation for TIP 232 2005-04-25 Daniel Steffen <[email protected]> * compat/string.h: fixed memchr() protoype for __APPLE__ so that we build on Mac OS X 10.1 again. * generic/tclNotify.c (TclFinalizeNotifier): fixed notifier not being finalized in unthreaded core (was testing for notifier initialization in current thread by checking thread id != 0 but thread id is always 0 in untreaded core). * win/tclWinNotify.c (Tcl_WaitForEvent): * unix/tclUnixNotfy.c (Tcl_WaitForEvent): don't call ScaleTimeProc for zero wait times (as specified in TIP 233). * unix/Makefile.in: added @PLAT_SRCS@ to SRCS and split out NOTIFY_SRCS from UNIX_SRCS for parity with UNIX_OBJS & NOTIFY_OBJS. * unix/tcl.m4 (Darwin): added configure checks for recently added linker flags -single_module and -search_paths_first to allow building with older tools (and on Mac OS X 10.1), use -single_module in SHLIB_LD and not just T{CL,K}_SHLIB_LD_EXTRAS, added unexporting from Tk of symbols from libtclstub to avoid duplicate symbol warnings, added PLAT_SRCS definition for Mac OS X, defined MODULE_SCOPE to __private_extern__. (SC_MISSING_POSIX_HEADERS): added caching of dirent.h check. * unix/configure: autoconf-2.59 2005-04-25 Kevin B. Kenny <[email protected]> * library/tzdata/America/Boise: * library/tzdata/America/Chicago: * library/tzdata/America/Denver * library/tzdata/America/Indianapolis: * library/tzdata/America/Los_Angeles: * library/tzdata/America/Louisville: * library/tzdata/America/Managua: * library/tzdata/America/New_York: * library/tzdata/America/Phoenix: * library/tzdata/America/Port-au-Prince: * library/tzdata/America/Indiana/Knox: * library/tzdata/America/Indiana/Marengo: * library/tzdata/America/Indiana/Vevay: * library/tzdata/America/Kentucky/Monticello: * library/tzdata/America/North_Dakota/Center: * library/tzdata/Asia/Tehran: Olson's tzdata2005i. Corrects exact time at which Standard Time was adopted in the US (generally, noon, Standard Time, rather than noon, Local Mean Time). Adopts new civil rules for Nicaragua and Iran. 2005-04-25 Don Porter <[email protected]> * library/init.tcl: Use "ni" and "in" operators. 2005-04-25 Miguel Sofer <[email protected]> * generic/tclExecute.c: fix for [Bug 1189274]. 2005-04-24 Don Porter <[email protected]> * generic/tclLiteral.c: Silence compiler warnings. * generic/tclObj.c: [Bug 1188863]. 2005-04-22 Don Porter <[email protected]> The 2005-04-21 changes to Tcl_GetBooleanFromObj were done to bring it into agreement with its docs. Further investigation reveals it was the docs that were incorrect. * doc/BoolObj.3: Corrections to the documentation of Tcl_GetBooleanFromObj to bring it into agreement with what this public interface has always done, including noting the difference in function between Tcl_GetBooleanFromObj and Tcl_GetBoolean. * generic/tclGet.c: Revised Tcl_GetBoolean to no longer be a wrapper around Tcl_GetBooleanFromObj (different function!). * generic/tclObj.c: Removed TclGetTruthValueFromObj routine that was added yesterday. Revisions so that only Tcl_GetBoolean-approved values get the "boolean" Tcl_ObjType. This retains the fix for [Bug 1187123]. * tests/string.test: Test string-23.0 for Bug 1187123. * generic/tclInt.h: Revert most recent change. * generic/tclBasic.c: * generic/tclCompCmds.c: * generic/tclDictObj.c: * generic/tclExecute.c: * tests/obj.test: 2005-04-21 Don Porter <[email protected]> * doc/GetInt.3: Convert argument "string" to "str" to agree with code. Also clarified a few details on int and double formats. * generic/tclGet.c: Radical code simplification. Converted Tcl_GetFoo() routines into wrappers around Tcl_GetFooFromObj(). Reduces code duplication, and the resulting potential for inconsistency. * generic/tclObj.c: Several changes: - Re-ordered error detection code so all values with trailing garbage receive a "not an integer" message instead of an "integer too large" message. - Removed inactive code meant to deal with strtoul* routines that fail to parse leading signs. All of them do, and if any are detected that do not, the correct fix is replacement with compat/strtoul*.c, not a lot of special care by the callers. - Tcl_GetDoubleFromObj now avoids shimmering away a "wideInt" intrep. - Fixed Tcl_GetBooleanFromObj to agree with its documentation and with Tcl_GetBoolean, accepting only "0" and "1" and not other numeric strings. [Bug 1187123] - Added new private routine TclGetTruthValueFromObj to perform the more permissive conversion of numeric values to boolean that is needed by the [expr] machinery. * generic/tclInt.h (TclGetTruthValueFromObj): New routine. * generic/tclExecute.c: Updated callers to call new routine. * generic/tclBasic.c: Updated callers to call new routine. * generic/tclCompCmds.c: Updated callers to call new routine. * generic/tclDictObj.c: Updated callers to call new routine. * tests/obj.test: Corrected bad tests that actually expected values like "47" and "0xac" to be accepted as booleans. * generic/tclLiteral.c: Disabled the code that forces some literals into the "int" Tcl_ObjType during registration. We can re-enable it if this change causes trouble, but it seems more sensible to let Tcl's "on-demand" shimmering rule, and not try to pre-guess things. 2005-04-20 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] * doc/expr.n: * doc/mathfunc.n (new file): Revised documentation for TIP 232 2005-04-20 Don Porter <[email protected]> * generic/tclGet.c (Tcl_GetInt): Corrected error that did not * generic/tclObj.c (Tcl_GetIntFromObj): permit 0x80000000 to be recognized as an integer on TCL_WIDE_INT_IS_LONG systems [Bug 1090869]. 2005-04-20 Kevin B. Kenny <[email protected]> * generic/tclFileName.c: Silenced a compiler warning about '/*' within a comment. 2005-04-19 Don Porter <[email protected]> * generic/tclBasic.c: Added unsupported command * generic/tclCmdAH.c: [::tcl::unsupported::EncodingDirs] to permit * generic/tclInt.h: query/set of the encoding search path at * generic/tclInterp.c: the script level. Updated init.tcl to make * library/init.tcl: use of the new command. Also updated several coding practices in init.tcl ("eq" for [string equal], etc.) 2005-04-19 Kevin B. Kenny <[email protected]> * library/clock.tcl (Initialize): Put initialization code into a proc to avoid inadvertently clobbering global variables. [Bug 1185933] * tests/clock.test (clock-48.1): Added regression test for the above bug. Thanks to Ulrich Ring for reporting this bug. 2005-04-16 Miguel Sofer <[email protected]> * generic/Var.c (Tcl_ArrayObjCmd - ARRAY_NAMES): fix Tcl_Obj leak [Bug 1084111] 2005-04-16 Zoran Vasiljevic <[email protected]> * generic/tclIOUtil.c: force clenaup of the interp result in TclLoadFile(). Some implementations of TclpFindSymbol() will seed the interp result with error message when unable to find the requested symbol (this is not considered to be an error). Set of changes correcting huge memory waste (not a leak) when a thread exits. This has been introduced in 8.4.7 within an attempt to correctly cleanup after ourselves when Tcl library is being unloaded with the Tcl_Finalize() call. This fixes the Tcl Bug #1178445. * generic/tclInt.h: added prototypes for TclpFreeAllocCache() and TclFreeAllocCache() * generic/tclThreadAlloc.c: modified TclFinalizeThreadAlloc() to explicitly call TclpFreeAllocCache with the NULL-ptr as argument signalling cleanup of private tsd key used only by the threading allocator. * unix/tclUnixThrd.c: fixed TclpFreeAllocCache() to recognize when being called with NULL argument. This is a signal for it to clean up the tsd key associated with the threading allocator. * win/tclWinThrd.c: renamed TclWinFreeAllocCache to TclpFreeAllocCache and fixed to recognize when being called with NULL argument. This is a signal for it to clean up the tsd key associated with the threading allocator. 2005-04-13 Don Porter <[email protected]> * tests/unixInit.test: Disabled obsolete tests and removed code * tests/encoding.test: that supported them. * generic/tclInterp.c: * library/init.tcl: Use auto-loading to bring in Tcl Module * library/tclIndex: support as needed. This reduces startup * library/tm.tcl: time by delaying this initialization to a later time. 2005-04-15 Miguel Sofer <[email protected]> * generic/tclExecute.c: missing semicolons caused failure to compile with TCL_COMPILE_DEBUG. 2005-04-13 David Gravereaux <[email protected]> * generic/tclIO.c (Tcl_SetChannelBufferSize): Lowest size limit * tests/io.test: changed from ten bytes to one byte. Need * tests/iogt.test: for this change was proven by Ross Cartlidge <[email protected]> where [read stdin 1] was grabbing 10 bytes followed by starting a child process that was intended to continue reading from stdin. Even with -buffersize set to one, nine chars were getting lost by the buffersize over reading for the native read() caused by [read]. 2005-04-13 Don Porter <[email protected]> * unix/tclUnixInit.c (TclpGetEncodingNameFromEnvironment): Reversed order of verifying candidate [encoding system] value, checking against a table in memory first before calling Tcl_GetEncoding and potentially scanning through the filesystem. Also ordered the table so that a binary search could be used within it. Improves startup time a bit more on some systems. 2004-04-13 Kevin B. Kenny <[email protected]> * library/clock.n: Added a missing '--' on several [switch] commands to improve performance of [clock format] and related operations. [Feature Request 1182459] 2005-04-13 Donal K. Fellows <[email protected]> * doc/fcopy.n: Improved documentation on copying binary files, added an example and mentioned the use of [file copy]. * doc/fconfigure.n: Improved documentation of -encoding binary option. This is all following comments from Steve Manning <[email protected]> on comp.lang.tcl that the current documentation was not clear. 2005-04-13 Miguel Sofer <[email protected]> * generic/tclCompile.c:Commented out the functions TclPrintInstruction(), TclPrintObject() and TclPrintSource() when not debugging the compiler, as they are never called in that case. 2005-04-12 Don Porter <[email protected]> * generic/tclInterp.c: Corrected bad syntax of Tcl_Panic() call. * generic/tclUtil.c (TclGetProcessGlobalValue): More robust handling of bad TclInitProcessGlobalValueProc behavior; an immediate panic rather than a mysterious crash later. * generic/tclEncoding.c: Several changes to the way the encodingFileMap cache is maintained. Previously, it was attempted to keep the file map filled and up to date with changes in the encoding search path. This contributed to slow startup times since it required an expensive "glob" operation to fill the cache. Now the validity of items in the cache are checked at the time they are used, so the cache is permitted to fall out of sync with the encoding search path. Only [encoding names] and Tcl_GetEncodingNames() now pay the full expense. [Bug 1177363] 2005-04-12 Kevin B. Kenny <[email protected]> * compat/strstr.c: Added default definition of NULL to accommodate building on systems with badly broken headers. [Bug #1175161] 2005-04-11 Donal K. Fellows <[email protected]> * tools/tclZIC.tcl: Rewrote to take advantage of more features of Tcl 8.5 (on which it was dependent anyway). Also added a [package require] line to formalize the relationship. 2005-04-11 Kevin Kenny <[email protected]> [kennykb-numerics-branch] Merged with HEAD. Updated to libtommath 0.35. * generic/tclBasic.c: Attempted to repeat changes that applied to tclExecute.c in Miguel Sofer's commit of 2005-04-01, together with (possibly) a few more uses of his new object creation macros. Also plugged a memory leak in TclObjInvoke. [Bug 1180368] 2005-04-10 Kevin Kenny <[email protected]> * library/tzdata/America/Montevideo: * library/tzdata/Asia/Almaty: * library/tzdata/Asia/Aqtau: * library/tzdata/Asia/Aqtobe: * library/tzdata/Asia/Baku: * library/tzdata/Asia/Jerusalem: * library/tzdata/Asia/Oral: * library/tzdata/Asia/Qyzylorda: * library/tzdata/Indian/Chagos: * library/tzdata/Indian/Cocos: Olson's tzdata2005h 2005-04-10 Don Porter <[email protected]> * generic/tclBasic.c (TclObjInvoke): Plug memory leak. [Bug 1180368] 2005-04-09 Miguel Sofer <[email protected]> * generic/tclExecute.c: fix possible leak of expansion Tcl_Objs 2005-04-09 Daniel Steffen <[email protected]> * macosx/README: updated requirements for OS & developer tool versions + other small fixes/cleanup. * generic/tclListObj.c (Tcl_ListObjIndex): added missing NULL return when getting index from an empty list. * unix/tcl.m4 (Darwin): added -single_module linker flag to TCL_SHLIB_LD_EXTRAS and TK_SHLIB_LD_EXTRAS. * unix/configure: autoconf-2.59 2005-04-08 Don Porter <[email protected]> * generic/tclInt.h (TclGetEncodingFromObj): New function to * generic/tclEncoding.c (TclGetEncodingFromObj): retrieve a Tcl_Encoding value, as well as cache it in the internal rep of a new "encoding" Tcl_ObjType. * generic/tclCmdAH.c (Tcl_EncodingObjCmd): Updated to call new function so that Tcl_Encoding's used by [encoding convert*] routines are not freed too quickly. [Bug 1077262] 2005-04-08 Donal K. Fellows <[email protected]> * generic/tclCompCmds.c (TclCompileSwitchCmd): Rewritten to be able to handle the other form of [switch] and generate slightly simpler (but longer) code. 2005-04-06 Donal K. Fellows <[email protected]> * doc/upvar.n, doc/unset.n, doc/tell.n, doc/tclvars.n, doc/subst.n: * doc/seek.n, doc/scan.n, doc/regsub.n, doc/registry.n, doc/regexp.n: * doc/read.n, doc/puts.n, doc/pkgMkIndex.n, doc/open.n, doc/lreplace.n: * doc/lrange.n, doc/load.n, doc/llength.n, doc/linsert.n, doc/lindex.n: * doc/lappend.n, doc/info.n, doc/gets.n, doc/format.n, doc/flush.n: * doc/fileevent.n, doc/file.n, doc/fblocked.n, doc/close.n: * doc/array.n, doc/Utf.3, doc/TraceVar.3, doc/StrMatch.3, doc/RegExp.3: * doc/PrintDbl.3, doc/OpenTcp.3, doc/OpenFileChnl.3, doc/Object.3: * doc/Notifier.3, doc/LinkVar.3, doc/IntObj.3, doc/Interp.3: * doc/GetOpnFl.3, doc/GetIndex.3, doc/Eval.3, doc/CrtMathFnc.3: * doc/CrtFileHdlr.3, doc/CrtCommand.3, doc/CrtChannel.3: * doc/Backslash.3: Purge old .VS/.VE macro instances. * tools/man2html2.tcl (IPmacro): Rewrote to understand what .IP really is (.IP and .TP are really just two ways of doing the same thing). Change below made this relevant. * doc/re_syntax.n: Change some uses of .TP to .IP to work around bugs in various *roff implementations. Also reworded the atom descriptions slightly. 2005-04-05 Don Porter <[email protected]> * generic/tclExecute.c (ExprSrandFunc): Replaced incursions into the * generic/tclUtil.c (TclGetIntForIndex): intreps of numeric types with simpler calls of Tcl_GetIntFromObj and Tcl_GetLongFromObj, now that those routines are better behaved wrt shimmering. [Patch 1177219] 2005-04-05 Miguel Sofer <[email protected]> * generic/tclInt.h: * generic/tclObj.c: Change in TclDecrRefCount and TclFreeObj, to speed up the freeing of simple Tcl_Obj [Patch 1174551] 2005-04-04 Miguel Sofer <[email protected]> * generic/tclExecute.c: small opts in obj handling 2005-04-02 Miguel Sofer <[email protected]> * generic/tclVar.c: converted a few function calls to macros. 2005-04-01 Miguel Sofer <[email protected]> * doc/ListObj.3: * generic/tclBasic.c: * generic/tclCmdIL.c: * generic/tclConfig.c: * generic/tclExecute.c: * generic/tclInt.decls: * generic/tclInt.h: * generic/tclIntDecls.h: * generic/tclListObj.c: * generic/tclStubInit.c: * generic/tclVar.c: Changed the internal representation of lists to (a) reduce the malloc/free calls at list creation (from 2 to 1), (b) reduce the cost of handling empty lists (we now never create a list internal rep for them), (c) allow refcounting of the list internal rep. The latter permits insuring that the pointers returned by Tcl_ListObjGetElements remain valid even if the object shimmers away from its original list type. This is [Patch 1158008] * generic/tclExecute.c: * generic/tclInt.h: * generic/tclObj.c: * generic/tclStringObj.c: (1) defined new internal macros for creating and setting frequently used obj types (int,long, wideInt, double, string). Changed TEBC to use eg 'TclNewIntObj(objPtr, i)' to avoid the function call in 'objPtr = Tcl_NewIntObj(i)' (2) ExecEnv now stores two Tcl_Obj* pointing to the constants "0" and "1", for use by TEBC. (3) slight reduction in cost of INST_START_CMD 2005-03-31 Miguel Sofer <[email protected]> * generic/tclExecute.c (INST_JUMP_TRUE/FALSE): replaced "test and branch" with "compute index into table" 2005-03-30 Donal K. Fellows <[email protected]> * doc/FileSystem.3: Defined loadHandle argument. [Bug 1172401] 2005-03-29 Jeff Hobbs <[email protected]> * win/tcl.m4, win/configure: do not require cygpath in macros to allow msys alone as an alternative. 2005-03-24 Don Porter <[email protected]> * generic/tclCompile.h: Move the TclInterpReady() declaration from * generic/tclInt.h: tclCompile.h to tclInt.h. Should have been done as part of the 1115904 bug fix on 2005-03-18. * generic/tclThreadTest.c: Stop providing the phony package "Thread 1.0" when the [::testthread] command is defined. It's never used by anything, and conflicts with loading the real "Thread" package. 2005-03-18 Don Porter <[email protected]> * generic/tclCompCmds.c (TclCompileIncrCmd): Corrected checks for immediate operand usage to permit leading space and sign characters. Restores more efficient bytecode for [incr x -1] that got lost in the CONST string reforms of Tcl 8.4. [Bug 1165671] * generic/tclBasic.c (Tcl_EvalEx): Restored recursion limit * generic/tclParse.c (TclSubstTokens): testing in nested command * tests/basic.test (basic-46.4): substitutions within direct * tests/parse.test (parse-19.*): script evaluation (Tcl_EvalEx) that got lost in the parser reforms of Tcl 8.1. Added tests for correct behavior. [Bug 1115904] 2005-03-15 Vince Darley <[email protected]> * generic/tclFileName.c: * win/tclWinFile.c: * tests/winFCMd.test: fix to 'file pathtype' and 'file norm' failures on reserved filenames like 'COM1:', etc. 2005-03-15 Pat Thoyts <[email protected]> * unix/tcl.m4: Updated the OpenBSD configuration and regenerated * unix/configure: the configure script. 2005-03-15 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] Merged with HEAD. * generic/tclBasic.c (many): * generic/tclCompExpr.c (CompileMathFuncCall): * generic/tclCompile.h: * generic/tclExecute.c (many): * generic/tclParseExpr.c (ParsePrimaryExpr): * tests/compExpr-old.test: * tests/compExpr.test: * tests/compile.test: * tests/expr-old.test: * tests/expr.test: * tests/for.test: * tests/parseExpr.test: Initial implementation of TIP #232. * generic/tclObj.c (Tcl_DbNewBignumObj): Fixed typo that broke --enable-symbols=mem build * tests/binary.test (binary-40.3, binary-40.6): Corrected tests to allow NaN(7ffffffffffff). 2005-03-14 Miguel Sofer <[email protected]> * generic/tclExecute.c: fixed INST_PUSH1's debugging code (wrong obj ref passed to TRACE_WITH_OBJ). 2005-03-14 Miguel Sofer <[email protected]> * generic/tclCompile.c: fixed INST_RETURN's stack effect in tclInstructionTable (-1 instead of -2) 2005-03-10 Miguel Sofer <[email protected]> * generic/tclCompCmds.c: removed debugging line 2005-03-10 Don Porter <[email protected]> * generic/tclTrace.c (TclCheckInterpTraces): Corrected mistaken cast of ClientData to (TraceCommandInfo *) when not warranted. Thanks to Yuri Victorovich for the report. [Bug 1153871] * generic/tcl.h: Moved flag values TCL_TRACE_ENTER_EXEC and * generic/tclInt.h: TCL_TRACE_LEAVE_EXEC from public interface into private. Should be used only by internal workings of execution traces. 2005-03-09 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] Merged from HEAD. * doc/PrintDbl.3: * doc/tclVars.n: Documented new semantics for tcl_precision. * generic/tclExecute.c (Tcl_ExecuteByteCode): Removed the check for division-by-zero on IEEE-754 machines. * generic/tclUtil.c (Tcl_PrintDouble): Corrected bug where numbers in the range [1e-4 .. 1.) were printed incorrectly. * tests/compExpr-old.test (compExpr-old-11.13): Revised test case for division by zero * tests/expr-old.test (expr-34.11, expr-34.12): Revised test cases for overflow in pow() to deal with infinities. * tests/expr.test (expr-11.13, expr-29.1, expr-29.2): Revised test case for division by zero and for underflow on input conversions. * tests/parseExpr.test (parseExpr-16.11): Revised test case for overflow on input conversion. * tests/string.test (string-6.38 deleted): Removed test case for underflow on input conversion, which is no longer an error. * tests/util.test (util-10.*): Added test case for the bug in tclUtil.c. 2005-03-08 Jeff Hobbs <[email protected]> * win/makefile.vc: clarify necessary defined vars that can come from MSVC or the Platform SDK. 2005-03-07 Donal K. Fellows <[email protected]> * doc/string.n: Minor typo. [Bug 1158247] 2005-03-07 Miguel Sofer <[email protected]> * generic/tclExecute.c: new peephole optimisation for INST_PUSH1; fixed the peephole opt in INST_POP so that it is not used when TCL_COMPILE_DEBUG is defined. 2005-03-04 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] * generic/tclCmdMZ.c: Changed [scan] to treat out-of-range floating point values as infinities and zeroes. * generic/tclExecute.c: Changed [expr] to be permissive about infinities, allowing them to propagate. * generic/tclGet.c: Changed Tcl_GetDouble to be permissive about over/underflow. * generic/tclObj.c: Changed SetDoubleFromAny to be permissive about over/underflow. * generic/tclParseExpr.c: Made [expr] permissive about input numbers out of range. 2005-03-03 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] * generic/tclInt.h: * generic/tclStrToD.c (Tcl_DoubleDigits, TclFormatNaN): * generic/tclUtil.c (Tcl_PrintDouble): Changed the signature of TclDoubleDigits so that it accepts a pointer to the signum of the argument, and returns the signum via that pointer. Added very hacky code to handle IEEE signed zeroes in Tcl_DoubleDigits. (It can't be done other than as a hack until C9x; C89 simply doesn't deal with the concept of -0.0). Added output conversion of tagged NaN values. * generic/tclBinary.c (FormatNumber): Changed to allow [binary format] to handle NaN. * tests/binary.test (binary-60.1): Added a quick-n-dirty test to make sure that NaN's can be scanned and formatted. * generic/tclParseExpr.c (GetLexeme, ParseMaxDoubleLength): Modified so that tagged NaN (e.g., NaN(DEADBEEF)) can be recognized. 2005-03-02 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] Merged with HEAD as of 2005-02-23. * generic/tclExecute.c: Broadened test for NaN to work on Windows. * generic/tclInt.h: * generic/tclStrToD.c (Tcl_DoubleDigits): * generic/tclUtil.c (Tcl_PrintDouble, TclPrecTraceProc): Added Tcl_DoubleDigits to format 'double' numbers with the minimum number of significant digits to yield correct rounding. Modified tcl_precision to accept 0 as a precision (meaning "minimum digits"), and made 0 the default. [TIP #132] * generic/tclObj.c: Made NaN's throw an error in Tcl_GetDoubleFromObj. * unix/Makefile.in: * win/Makefile.in: * win/makefile.vc: Added libtommath/bn_mp_init_set.c to the build. * libtommath/tommath.h (mp_iseven): Fixed a bug that caused zero to test 'odd'. * generic/tommath.h: Regenerated. * tests/binary.test: * tests/expr-old.test: * tests/expr.test: * tests/scan.test: Corrected a number of tests that depended on tcl_precision, and removed the {eformat} condition from tests that no longer require it. * tests/util.test: Corrected a number of tests that depended on tcl_precision, and removed the {eformat} condition from tests that no longer require it. Added a series of tests for correct rounding in Tcl_PrintDouble. [TIP #132]. 2005-03-01 David N. Welton <[email protected]> * doc/CrtSlave.3: Changed to Tcl_Object to Tcl_Obj in the man page. 2005-02-24 Don Porter <[email protected]> * library/tcltest/tcltest.tcl: Better use of [glob -types] to avoid * tests/tcltest.test: failed attempts to [source] a directory, and similar matters. Thanks to "mpettigr". [Bug 1119798] * library/tcltest/pkgIndex.tcl: Bump to tcltest 2.2.8 * unix/Makefile.in: * win/Makefile.in: 2005-02-23 Donal K. Fellows <[email protected]> * doc/CrtChannel.3 (THREADACTIONPROC): Formatting fix. [Bug 1149605] 2005-02-17 Jeff Hobbs <[email protected]> * win/tclWinFCmd.c (TraverseWinTree): use wcslen on wchar, not Tcl_UniCharLen. 2005-02-16 Miguel Sofer <[email protected]> * doc/variable.n: fix for [Bug 1124160], variables are detected by [info vars] but not by [info locals]. 2005-02-11 Jeff Hobbs <[email protected]> * unix/Makefile.in: remove SHLIB_LD_FLAGS (only for AIX, inlined * unix/tcl.m4: into SHLIB_LD). Combine AIX-* and AIX-5 * unix/configure: branches in SC_CONFIG_CFLAGS. Correct gcc builds for AIX-4+ and HP-UX-11. autoconf-2.59 gen'd. 2005-02-11 Miguel Sofer <[email protected]> * tests/basic.test (basic-26.3): new test 2005-02-10 Miguel Sofer <[email protected]> * generic/tclBasic.c (Tcl_EvalObjEx): * tests/basic.test (basic-26.2): preserve the arguments passed to TEOV in the pure-list branch, in case the list shimmers away. Fix for [Bug 1119369], reported by Peter MacDonald. 2005-02-10 Vince Darley <[email protected]> * generic/tclFileName.c: fix for test failures introduced on 2005-01-17 [Bug 1119092] 2005-02-10 Donal K. Fellows <[email protected]> * doc/binary.n: Made the documentation of sign bit masking and [binary scan] consistent. [Bug 1117017] 2005-02-08 David N. Welton <[email protected]> * doc/CrtChannel.3: Typo: return->returns. 2005-02-06 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] * generic/tclStrToD.c (TclStrToD, SafeLdExp): Added code to manage the FPU precision on gcc+x86. Enabled fast conversion of floats with small exponents now that precision is correct. * tests/expr.test: Corrected test for the smallest representible value to the right IEEE values. 2005-02-06 David N. Welton <[email protected]> * doc/Thread.3: One-word grammar fix. 2005-02-05 David N. Welton <[email protected]> * doc/Thread.3: Fixed sentence describing flags for Tcl_CreateThread. * doc/FileSystem.3: Cleaned up typo in Tcl_FSNewNativePath documentation. * generic/tclPathObj.c: Cleaned up typo in comment. 2005-02-03 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] * generic/tclStrToD.c (TclStrToD, RefineResult, SafeLdExp): Added code to ensure that 'ldexp' is never called with a value that will underflow. * tests/expr.test: Added tests for the smallest representible value, and rounding between it and zero. (The tests reflect current behaviour; plan is to change the specification of Tcl so that input conversion of doubles underflows silently.) 2005-02-02 Mo DeJong <[email protected]> * generic/tclProc.c (TclInitCompiledLocals): Add check for type of the framePtr->procPtr->bodyPtr passed to TclInitCompiledLocals and panic if it is not the correct type. If the body of the proc is not of the compiled byte code type then the code will crash. This was discovered while tracking down a crash in Itcl, that crash is fixed by Itcl patch 1115085. 2005-02-01 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] Merged with HEAD as of today. * generic/tclInt.decls: Changed numbers of new stubs to resolve a conflict. * generic/tclInt.h: Added new TclStrToD routine that replaces the native 'strtod' thro ughout Tcl. * generic/tclCmdMZ (Tcl_StringObjCmd): * generic/tclGet.c (Tcl_GetDouble): * generic/tclObj.c (SetBooleanFromAny, SetDoubleFromAny): * generic/tclParseExpr.c (GetLexeme): * generic/tclScan.c (Tcl_ScanObjCmd): Replaced all uses of the native 'strtod' with a TclStrToD routine that performs correct rounding and handles denormals. * generic/tclStrToD.c: (new file) New scanning function for extracting 'double' from a string that rounds correctly, and handles denormals and infinities. * unix/Makefile.in: * win/Makefile.in: * win/makefile.vc: Added tclStrToD.c and the tommath routines that support it. These changes represent a partial implementation of TIP #132. Output conversion of floating point numbers, and proper handling of infinities within expressions, still need to be addressed. 2005-02-01 Don Porter <[email protected]> * generic/tclExecute.c (TclCompEvalObj): Removed stray statement left behind in prior code reorganization. 2005-01-31 Don Porter <[email protected]> * unix/configure: autoconf-2.57 2005-01-30 Joe English <[email protected]> * unix/configure.in: Restored two double-evals that were removed in the DBGX purge; these are still needed on some platforms to account for TCL_TRIM_DOTS. [Bug 1112654] * unix/configure: NOT REGENERATED: only have autoconf 2.59 here, need to find someone with autoconf 2.57. 2005-01-28 Jeff Hobbs <[email protected]> * unix/configure, unix/tcl.m4: add solaris 64-bit gcc build support. [Bug 1021871] 2005-01-28 Donal K. Fellows <[email protected]> * tests/expr-old.test (expr-old-37.2): Added test for [Bug 1109484] 2005-01-27 Jeff Hobbs <[email protected]> * generic/tclBasic.c (Tcl_ExprBoolean, Tcl_ExprDouble) (Tcl_ExprLong): Fix to recognize Tcl_WideInt type. [Bug 1109484] 2005-01-26 Andreas Kupries <[email protected]> TIP#218 IMPLEMENTATION * generic/tclDecls.h: Regenerated from tcl.decls. * generic/tclStubInit.c: * doc/CrtChannel.3: Documentation of extended API, * generic/tcl.decls: extended testsuite, and * generic/tcl.h: implementation. Removal of old * generic/tclIO.c: driver-specific TclpCut/Splice * generic/tclInt.h: functions. Replaced with generic * tests/io.test: thread-action calls through the * unix/tclUnixChan.c: new hooks. Update of all builtin * unix/tclUnixPipe.c: channel drivers to version 4. * unix/tclUnixSock.c: Windows drivers extended to * win/tclWinChan.c: manage thread state in a thread * win/tclWinConsole.c: action handler. * win/tclWinPipe.c: * win/tclWinSerial.c: * win/tclWinSock.c: 2005-01-25 Don Porter <[email protected]> * library/auto.tcl: Updated [auto_reset] to clear auto-loaded commands in namespaces other than :: and to clear auto-loaded commands that do not happen to be procs. [Bug 1101670] ***POTENTIAL INCOMPATIBILITY*** 2005-01-25 Daniel Steffen <[email protected]> * unix/tcl.m4 (Darwin): fixed bug with static build linking to dynamic library in /usr/lib etc instead of linking to static library earlier in search path. [Tcl Bug 956908] Removed obsolete references to Rhapsody. * unix/configure: autoconf-2.57 2005-01-21 Andreas Kupries <[email protected]> * generic/tclStubInit.c: Regenerated the stubs support code from * generic/tclDecls.h: the modified tcl.decls (TIP #233, see below). * doc/GetTime.3: Implemented TIP #233, i.e. the * generic/tcl.decls: 'Virtualization of Tcl's Sense of Time'. * generic/tcl.h: Declared, implemented, and documented the * generic/tclInt.h: specified new API functions. Moved the * unix/tclUnixEvent.c: native (OS) access to time information * unix/tclUnixNotfy.c: into standard handler functions. Inserted * unix/tclUnixTime.c: hooks calling on the handlers where native * win/tclWinNotify.c: access was done before, and where scaling * win/tclWinTime.c: between domains (real/virtual) is required. 2005-01-21 Andreas Kupries <[email protected]> * generic/tclThread.c: Typo police. Fixed some nits * generic/tclCmdAH.c: in header comments of functions. * generic/tclBasic.c: (Missing --). * generic/tclFileName.c: 2005-01-21 Donal K. Fellows <[email protected]> * doc/FileSystem.3: Add missing ARGUMENTS section definitions for arguments to Tcl_FSLink. [Bug 1106272] 2005-01-21 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] * unix/Makefile.in: Updated Makefile to build libtommath on Unix as well as Windows. [Bug 1106865] * generic/tclTestObj.c (TestbignumobjCmd): Silenced a compiler warning about a mismatched 'const'. 2005-01-20 Kevin B. Kenny <[email protected]> [kennykb-numerics-branch] Development checkpoint. * compat/strtoll.c: Reverted to HEAD. * compat/strtoull.c: * doc/Ensemble.3: * generic/tclBasic.c: * generic/tclCmdIL.c: * generic/tclNamesp.c: * generic/tclPathObj.c: * generic/tclPort.h: * unix/configure: * unix/configure.in: * unix/tcl.m4: * win/configure: * win/configure.in: * win/rules.vc: * win/tcl.m4: * generic/tcl.h: Added declarations for bignum types, and for a 'bignumValue' in the Tcl_Obj structure. * generic/tclInt.h: Added declarations of interface procedures for memory allocation in libtommath. * generic/tcl.decls: Added new interface to bignum objects. * generic/tclInt.decls: Added internal stubs for bignum routines used by the test code in tclTestObj.c. * generic/tclDecls/h: Regen. * generic/tclIntDecls.h: * generic/tclStubInit.h: * tools/fix_tommath_h.tcl: (New file) Script to edit libtommath/tommath.h and produce generic/tommath.h so that storage classes, allocation routines, and data types conform to Tcl's conventions. * generic/tommath.h: (New file) Generated by the above. * generic/tclTomMath.h: (New file) Additional declarations to be included in tommath.h when building Tcl. * generic/tclTomMathInterface.c: (New file) Small 'glue' routines adapting tommath's API to Tcl. * libtommath/bn_fast_s_mp_mul_digs.c: * libtommath/bn_mp_mul_d.c: * libtommath/bn_mp_read_radix.c: * libtommath/tommath.h: Applied suggested changes from Tom St Denis that correct an off-by-one error in single-digit multiplication (leading to a pointer smash if uncorrected) and change the string argument to 'mp_read_radix' from 'char*' to 'const char*'. * libtommath/bn_mp_radix_size.c: Local patch to ensure that sufficient memory is requested even if the number has a single digit. * libtommath/bn_mp_read_radix.c: Local patch to return MP_VAL if the input string contains an invalid character. * generic/tclObj.c: Added accessor functions for bignums. * generic/tclTestObj.c: Added a 'testbignumobj' command to exercise the accessor functions for bignums. * win/Makefile.in: Added rules for making libtommath. 2005-01-19 Donal K. Fellows <[email protected]> TIP#235 IMPLEMENTATION * doc/Ensemble.3: Documentation for the new public API. * generic/tclNamesp.c (Tcl_CreateEnsemble,...): Rename of * generic/tcl.decls: existing API into TIPped form. 2005-01-19 Mo DeJong <[email protected]> * win/tclWinChan.c (FileCloseProc): Invoke TclpCutFileChannel() to remove a FileInfo from the thread local list before deallocating it. This should have been done via an earlier call to Tcl_CutChannel, but I was running into a crash in the next call to Tcl_CutChannel during the IO finalization stage. 2005-01-18 Kevin Kenny <[email protected]> * library/tzdata/GMT+0: * library/tzdata/GMT-0: * library/tzdata/GMT0: * library/tzdata/Greenwich: * library/tzdata/Navajo: * library/tzdata/Universal: * library/tzdata/Zulu: * library/tzdata/America/Asuncion: * library/tzdata/America/Rosario: * library/tzdata/Asia/Jerusalem: * library/tzdata/Brazil/Acre: Routine update per Olson's tzdata2005c. Removed links to links (Greenwich in several aliases; Navajo; Acre). Updated Paraguayan DST rules and "best guess" at this year's Israeli rules. 2005-01-17 Vince Darley <[email protected]> * generic/tclFileName.c: fix for glob failure on Windows shares [Bug 1100542]. * doc/pkgMkIndex.n: added documentation that 'pkg_mkIndex -lazy' is not a good idea. [Bug 1101678] 2005-01-14 Donal K. Fellows <[email protected]> * tests/compile.test (compile-17.1): Document known issue with binding time of compiled command interpretations in [expr]. * generic/tclIOUtil.c (TclFSFileAttrIndex): New helper function so that we don't need to hard-code attribute indexes. [Bug 1100671] 2005-01-13 Donal K. Fellows <[email protected]> * doc/string.n: Removed the term 'set' from the documentation of the [string trim] commands, as it caused confusion. 2005-01-12 Donal K. Fellows <[email protected]> * unix/tcl.m4 (SC_PATH_{TCL,TK}CONFIG): Added code to detect the case when the --with-tcl/--with-tk arguments point to the config scripts themselves and not their directory. If this is the case, they now complain but keep working. [FRQ 951247] * unix/configure: autoconf-2.57 2005-01-10 Joe English <[email protected]> * unix/Makefile.in, unix/configure.in, unix/tcl.m4, * unix/tclConfig.sh.in, unix/dltest/Makefile.in: Remove ${DBGX}, ${TCL_DBGX} from Tcl build system [Patch 1081595]. * unix/configure: regenerated 2005-01-10 Donal K. Fellows <[email protected]> * unix/tclUnixFCmd.c (TclUnixCopyFile): Convert u_int to unsigned to make clashes with types in standard C headers less of a problem. [Bug 1098829] 2005-01-09 Joe English <[email protected]> * unix/tclUnixThrd.c, unix/tclUnixPort.h: Remove readdir_r() and related #ifdeffery (see #1095909). * unix/tcl.m4, unix/tclConfig.h.in: Don't check for HAVE_READDIR_R. * unix/configure: Regenerated. 2005-01-06 Donal K. Fellows <[email protected]> * library/http/http.tcl (http::mapReply): Significant performance enhancement by using [string map] instead of [regsub]/[subst], and update version requirement to Tcl8.4. [Bug 1020491] 2005-01-05 Donal K. Fellows <[email protected]> * doc/lsearch.n, doc/re_syntax.n: Convert to other form of emacs mode control comment to prevent problems with old versions of man. [Bug 1085127] 2005-01-05 Pat Thoyts <[email protected]> * tests/winDde.test: Fixed broken test result. 2005-01-05 Donal K. Fellows <[email protected]> * generic/tclInt.h, generic/tclPort.h: Move the #include of tclConfig.h *first* before any reference to tcl.h so that the build configuration is loaded before the first reference to any system headers. Issue reported by Art Haas on tcl-core. 2005-01-04 Don Porter <[email protected]> * tests/fCmd.test (fCmd-18.10): Added notNetworkFilesystem constraint. [Bug 456665] 2004-12-29 Jeff Hobbs <[email protected]> * win/tcl.m4, win/configure: update MSVC CFLAGS_OPT to -O2, remove -Gs (included in -O2) and -GD (outdated). Use "link -lib" instead of "lib" binary and remove -YX for MSVC7 portability. Add -fomit-frame-pointer for gcc OPT compiles. [Bug 1092952, 1091967] Align LIBS_GUI with Tk head needs. 2004-12-29 Kevin B. Kenny <[email protected]> * generic/tclDate.c: Regen * generic/tclGetDate.y (TclDatelex): Fixed a problem where a four-digit group with >=2 leading zeroes appeared to be a two-digit group, leading to misinterpreting the time 0012 as 1200. [Bug # 1090413] * library/clock.tcl: Added code to interpret correctly months outside the range 01-12 as reduced modulo 12 with a corresponding adjustment to the year. [Bug 1092789] * tests/clock.test: Added regression test cases for the above two bugs. * unix/Makefile.in: Added --no-lines to the 'bison' command line * win/Makefile.in: to help constrain the number of diffs in a cvs checkin. 2004-12-24 Miguel Sofer <[email protected]> * generic/tclCompile.c: * generic/tclCompile.h: * generic/tclExecute.c: * generic/tclInt.h: * generic/tclLiteral.c: * generic/tclProc.c: Avoid sharing cmdName literals accross namespaces, and generalise usage of the TclRegisterNewLiteral macro [Patch 1090905] 2004-12-20 Miguel Sofer <[email protected]> * generic/tclCompile.c: moved TclInitCompiledLocals to tclProc.c * generic/tclProc.c: new static InitCompiledLocals to allow for a single pass over the proc's arguments at proc load time (instead of two as previously). TclObjInterpProc() now allocates the compiledLocals on the tcl execution stack, using the new TclStackAlloc/Free functions. 2004-12-16 Donal K. Fellows <[email protected]> * generic/tclInterp.c (Tcl_LimitSetTime, TimeLimitCallback): (TclLimitRemoveAllHandlers, TclInitLimitSupport): Set a timer event to trigger when the time limit runs out. All the time limit actually does is check to see if the time limit has been exceeded, but this is enough to fix [Bug 1085023]. * generic/tclInt.h (struct Interp): Added a field to hold the token for the timer event handler associated with the current time limit. * generic/tclEvent.c (Tcl_UpdateObjCmd, Tcl_VwaitObjCmd): Add error message when limit exceeded. * tests/interp.test (interp-34.[89]): Check that time limits handle the two cases reported in [Bug 1085023] * generic/tclTimer.c (TclCreateAbsoluteTimerHandler): New internal function that allows setting a timer handler that will be triggered at (or after) a specific time instead of at some number of milliseconds in the future. This is a candidate for future exposure via a TIP. 2004-12-15 Miguel Sofer <[email protected]> * generic/tclBasic.c: * generic/tclExecute.c: * generic/tclInt.decls: * generic/tclIntDecls.h: * generic/tclNamesp.c: * generic/tclProc.c: * generic/tclStubInit.c: * generic/tclTest.c: Added two new functions to allocate memory from the execution stack (TclStackAlloc, TclStackFree). Added functions TclPushStackFrame and TclPopStackFrame that do the work of Tcl_PushCallFrame and Tcl_PopCallFrame, but using frames allocated in the execution stack - i.e., heap instead of C-stack. The core uses these two new functions exclusively; the old ones remain for backwards compat, as at least two popular extensions (itcl, xotcl) are known to use them. 2004-12-14 Miguel Sofer <[email protected]> * generic/tclCmdIL.c: * generic/tclInt.h: * generic/tclProc.c: * generic/tclVar.c: changing the isProcCallFrame field of the CallFrame struct from a 0/1 field to flags. Should be perfectly backwards compatible. 2004-12-14 Don Porter <[email protected]> * unix/configure.in: Added special processing to remove "$U" from libraries in the LIBOBJS value. This is an auto-make-ism we need to avoid. [Bug 1081541] * unix/configure: autoconf-2.57 2004-12-13 Don Porter <[email protected]> * generic/tcl.h: Restored extern "C" guards so that C++ code sees function pointer typedef linkage consistent with earlier Tcl releases. [Bug 1082349]. * generic/tclEncoding.c: Plugged some memory leaks. Thanks to * generic/tclUtil.c: Rolf Ade for reports and testing [Bug 1083082] 2004-12-13 Kevin B. Kenny <[email protected]> * doc/clock.n: Clarify that the [clock scan] command does not accept the full range of ISO8601 point-in-time formats [Bug 1075433]. 2004-12-12 Miguel Sofer <[email protected]> * generic/tclVar.c (TclArrayObjCmd - ARRAY_NAMES): leaking an object [Bug 1084111] - thanks to Rolf Ade. 2004-12-12 Miguel Sofer <[email protected]> * generic/tclObj.c (TclSetCmdNameObj): special handling for fully qualified command names (as in fix [Patch 456668]). 2004-12-11 Miguel Sofer <[email protected]> * generic/tclInt.h: * generic/tclNamesp.c: converting the static function GetNamespaceFromObj() to MODULE_SCOPE TclGetNamespaceFromObj(). 2004-12-10 Donal K. Fellows <[email protected]> * tools/tcl.wse.in, unix/tcl.spec, win/README.binary, README: * win/configure.in, unix/configure.in, generic/tcl.h: Bumped version number to 8.5a3 to distinguish HEAD of CVS development from the recent 8.5a2 release. 2004-12-10 Miguel Sofer <[email protected]> * generic/tclCompile.c (TclInitCompiledLocals): * generic/tclCompile.h: * generic/tclInt.h: * generic/tclProc.c (TclObjInterpProc, TclCreateProc): optimised loops that initialise a proc's arguments and compiled local variables, removing tests from inner loops. 2004-12-10 Donal K. Fellows <[email protected]> * generic/tclInt.h: Move ensemble API decls here from tclNamesp.c 2004-12-09 Donal K. Fellows <[email protected]> * generic/tclNamesp.c (TclMakeEnsembleCmd, TclSetEnsemble*) (TclSetEnsemble*, TclFindEnsemble): Build an internal API for creating and manipulating ensembles; they can be deleted using the normal command-deletion API. * doc/Async.3: Reword for better grammar, better nroff and get the flag name right. (Reported by David Welton.) 2004-12-07 Don Porter <[email protected]> * tests/unixInit.test (2.1-4): Added constraints so that when a value of TCL_LIBRARY is required for process initialization, we skip the tests that mess with that value. 2004-12-07 Donal K. Fellows <[email protected]> *** 8.5a2 TAGGED FOR RELEASE *** * unix/Makefile.in: add library/{tzdata,msgs} to dist target (kbk) * doc/foreach.n: Adjust tabs to be friendlier to some HTML converters. [Bug 1078760] 2004-12-06 Jeff Hobbs <[email protected]> * unix/tclUnixNotfy.c (NotifierThreadProc): init numFdBits [Bug 1079286] * doc/error.n, doc/SaveResult.3, doc/Thread.3: minor nroff typos 2004-12-06 Don Porter <[email protected]> * tests/safe.test: Trim auto_path to improve performance [1080039] * tests/msgcat.test: makeFile/removeFile cleanup [1079117] 2004-12-04 Don Porter <[email protected]> * generic/tclEncoding.c: Different fix for [Bug 1077005]. * generic/tclEvent.c: Broke apart TclpSetInitialEncodings() on * generic/tclInt.h: Windows into TclpSetInterfaces(), that is * unix/tclUnixInit.c: fundamentally essential, and the initialization * win/tclWinInit.c: of the system encoding, which is not. Made the TclpSetInterfaces call part of TclInitSubsystems so it cannot be overlooked. 2004-12-03 Jeff Hobbs <[email protected]> * changes: updated for 8.5a2 release 2004-12-02 Don Porter <[email protected]> * generic/tclUtil.c (TclSetProcessGlobalValue): Handle the case where a ProcessGlobalValue might be assigned to itself. * generic/tclEncoding.c (MakeFileMap): Correct refcounting errors managing values returned by TclPathPart (with refCount of 1!) that led to a memory leak. [Bug 1077474]. 2004-12-02 Vince Darley <[email protected]> * generic/tclPathObj.c: fix and new tests for [Bug 1074671] to * tests/fileSystem.test: ensure tilde paths are not returned specially by 'glob'. 2004-12-02 Kevin B. Kenny <[email protected]> * win/Makefile.in: Added a 'sed' in the setting of ROOT_DIR_NATIVE to compensate for a bug in cygpath (at least version 1.36) that leaves a trailing backslash on the end of the converted path. 2004-12-02 Donal K. Fellows <[email protected]> * generic/tclInterp.c (Alias,Target,Master): Rewrote these so that the aliases that refer to an interpreter are stored in a list and not a hashtable (which was only ever a convenience, and forced the use of a global mutex to generate keys!) [FRQ 1077210] * generic/tclNamesp.c (numNsCreated): Moved into thread-local storage to remove a global mutex. [FRQ 1077210] 2004-12-01 Don Porter <[email protected]> * generic/tclUtil.c (TclGetProcessGlobalValue): Narrowed the scope of mutex locks. * generic/tclUtil.c: Updated Tcl_GetNameOfExecutable() to * generic/tclEncoding.c: make use of a ProcessGlobalValue for * generic/tclEvent.c: storing the executable name. |
︙ | ︙ | |||
44 45 46 47 48 49 50 | 2004-12-01 Donal K. Fellows <[email protected]> * tests/winDde.test: Rewritten to use tcltest2 features more thoroughly (reducing the [catch] count!) and fix the problem with winDde-6.1 being out of synch with the implementation. | | | | | | | | | | | | | | 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 | 2004-12-01 Donal K. Fellows <[email protected]> * tests/winDde.test: Rewritten to use tcltest2 features more thoroughly (reducing the [catch] count!) and fix the problem with winDde-6.1 being out of synch with the implementation. 2004-11-30 Don Porter <[email protected]> * library/init.tcl ([unknown]): Restored the save/restore of the variables ::errorCode and ::errorInfo. This is needed when the [::bgerror] command is auto-loaded (as it is by Tk). Patch 976520 reworks several of the details involved with startup/initialization of the Tcl library, focused on the activities of Tcl_FindExecutable(). * generic/tclIO.c: Removed bogus claim in comment that encoding "iso8859-1" is "built-in" to Tcl. * generic/tclInt.h: Created a new struct ProcessGlobalValue, * generic/tclUtil.c: routines Tcl(Get|Set)ProcessGlobalValue, and function type TclInitProcessGlobalValueProc. Together, these take care of the housekeeping for "values" (things that can be held in a Tcl_Obj) that are global across a whole process. That is, they are shared among multiple threads, and epoch and mutex protection must govern the validity of cached copies maintained in each thread. * generic/tclNotify.c: Modified TclInitNotifier() to tolerate being called multiple times in the same thread. * generic/tclEvent.c: Dropped the unused argv0 argument to TclInitSubsystems(). Removed machinery to unsure only one TclInitNotifier() call per thread, now that that is safe. Converted Tcl(Get|Set)LibraryPath to use a ProcessGlobalValue, and moved them to tclEncoding.c. * generic/tclBasic.c: Updated caller. * generic/tclInt.h: TclpFindExecutable now returns void. * unix/tclUnixFile.c: * win/tclWinFile.c: * win/tclWinPipe.c: * generic/tclEncoding.c: Built new encoding search initialization on a foundation of ProcessGlobalValues, exposing new routines Tcl(Get|Set)EncodingSearchPath. A cache of a map from encoding name to directory pathname keeps track of where encodings are available for loading. Tcl_FindExecutable greatly simplified into just three function calls. The "library path" is now misnamed, as its only remaining purpose is as a foundation for the default encoding search path. * generic/tclInterp.c: Inlined the initScript that is evaluated by Tcl_Init(). Added verification after initScript evaluation that Tcl can find its installed *.enc files, and that it has initialized [encoding system] in agreement with what the environment expects. [tclInit] no longer driven by the value of $::tcl_libPath; it largely constructs its own search path now, rather than attempt to share one with the encoding system. * unix/tclUnixInit.c: TclpSetInitialEncodings factored so that a new * win/tclWinInit.c: routine TclpGetEncodingNameFromEnvironment can reveal that Tcl thinks the [encoding system] should be, even when an incomplete encoding search path, or a missing *.enc file won't allow that initialization to succeed. TclpInitLibraryPath reworked as an initializer of a ProcessGlobalValue. * unix/tclUnixTest.c: Update implementations of [testfindexecutable], [testgetdefenc], and [testsetdefenc]. * tests/unixInit.test: Corrected tests to operate properly even when a value of TCL_LIBRARY is required to find encodings. * generic/tclInt.decls: New internal stubs: TclGetEncodingSearchPath, TclSetEncodingSearchPath, TclpGetEncodingNameFromEnvironment. These are candidates for public exposure by future TIPs. * generic/tclIntDecls.h: make genstubs * generic/tclStubInit.c: * generic/tclTest.c: Updated [testencoding] to use * tests/encoding.test: Tcl(Get|Set)EncodingSearchPath. Updated tests. 2004-11-30 Kevin B. Kenny <[email protected]> * library/clock.tcl: Corrected the regular expressions that match a time zone to allow for time zones specified as +HH or -HH. * tests/clock.test: Added regression test case for the above issue. Thanks to Rolf Ade for reporting this issue [http://wiki.tcl.tk/13094] * win/tclWinDde.c (Tcl_DdeObjCmd): Corrected a typo that caused a compilation failure on VC++. 2004-11-29 Andreas Kupries <[email protected]> * win/Makefile.in (install-libraries): Brought entry '2004-10-26 Don Porter (Tcl Modules)' into the windows world, actually the win/configure buildsystem. The other windows buildsystems (.vc, .bc) still have to be updated as well. 2004-11-26 Andreas Kupries <[email protected]> * win/tclWinDde.c (ExecuteRemoteObject): Removed bogus semicolon found at the end of the header for the function definition, terminating it early and preventing a compile. This is likely a fix for '2004-11-25 Donal'. I have to conclude that it is also unknown if the other changes to this file actually pass the testsuite. Running testsuite ... They don't. winDde-6.1 fails. This is only a message discrepance, i.e. not too bad. Leaving resolution of that to Pat and Donal. 2004-11-26 Don Porter <[email protected]> * library/auto.tcl (tcl_findLibrary): Made sure the uniquifying operations on the search path does not also normalize. [Bug 1072136] 2004-11-26 Donal K. Fellows <[email protected]> * unix/configure.in: Simplify the code to check for correctness of strstr, strtoul and strtod. * unix/tcl.m4 (SC_TCL_CHECK_BROKEN_FUNC): Split a complex stanza out of configure.in into its own function. Also force it to do the |
︙ | ︙ | |||
178 179 180 181 182 183 184 | be fixed as well. Done with a load of #ifdef-ery because this hack is so ugly nobody should keep it around once Itcl's fixed. 2004-11-25 Reinhard Max <[email protected]> * tests/tcltest.test: The order in which [glob] returns the file names is undefined, so tests should not depend on it. | | | 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 | be fixed as well. Done with a load of #ifdef-ery because this hack is so ugly nobody should keep it around once Itcl's fixed. 2004-11-25 Reinhard Max <[email protected]> * tests/tcltest.test: The order in which [glob] returns the file names is undefined, so tests should not depend on it. 2004-11-25 Zoran Vasiljevic <[email protected]> * doc/Thread.3: * doc/Notifier.3: Added changes from the core-8-4-branch 2004-11-25 Donal K. Fellows <[email protected]> |
︙ | ︙ | |||
211 212 213 214 215 216 217 | * unix/tclUnixNotfy.c: Corrected all uses of 'select' to manage their masks using the FD_CLR, FD_ISSET, FD_SET, and FD_ZERO macros rather than bit-whacking that failed under Solaris-Sparc-64. [Bug 1071807] * win/tclWinInit.c (TclpInitLibraryPath): Removed unused vars 'pathc' and 'pathv' that caused compilation problems on VC++ with --enable-symbols. | | | | | 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 | * unix/tclUnixNotfy.c: Corrected all uses of 'select' to manage their masks using the FD_CLR, FD_ISSET, FD_SET, and FD_ZERO macros rather than bit-whacking that failed under Solaris-Sparc-64. [Bug 1071807] * win/tclWinInit.c (TclpInitLibraryPath): Removed unused vars 'pathc' and 'pathv' that caused compilation problems on VC++ with --enable-symbols. 2004-11-24 Don Porter <[email protected]> * unix/tcl.m4 (SC_ENABLE_THREADS): Corrected failure to determine the number of arguments for readdir_r on SunOS systems. [Bug 1071701] * unix/configure: autoconf-2.57 * generic/tclCmdIL.c (InfoVarsCmd): Corrected segfault in new * tests/info.test (info-19.6): trivial matching branch [Bug 1072654] 2004-11-24 Donal K. Fellows <[email protected]> |
︙ | ︙ | |||
256 257 258 259 260 261 262 | * unix/tcl.m4 (SC_ENABLE_THREADS): Check for a 2 argument version of readdir_r that is known to exists under IRIX 5.3. * unix/tclUnixThrd.c (TclpReaddir): Use either 2 arg or 3 arg version of readdir_r. [Bug 1001325] | | | | | | 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 | * unix/tcl.m4 (SC_ENABLE_THREADS): Check for a 2 argument version of readdir_r that is known to exists under IRIX 5.3. * unix/tclUnixThrd.c (TclpReaddir): Use either 2 arg or 3 arg version of readdir_r. [Bug 1001325] 2004-11-22 Don Porter <[email protected]> * unix/tclUnixInit.c (TclpInitLibraryPath): Purged dead code that * win/tclWinInit.c (TclpInitLibraryPath): used to extend the "library path". Search path construction for init.tcl is now done within the [tclInit] proc. * generic/tclInterp.c: Restored several directories to the search * tests/unixInit.test: path used to locate init.tcl within [tclInit]. This change does not restore any directories to the encoding search path, so should still avoid the price of an unreasonably large number of filesystem accesses during encoding initialization at startup [Bug 976438] 2004-11-22 Vince Darley <[email protected]> * generic/tclPathObj.c: fix and new test for [Bug 1043129] in * tests/fileSystem.test: the treatment of backslashes in file join on Windows. 2004-11-21 Don Porter <[email protected]> * doc/AddErrInfo.3: Typo corrections (Thanks Daniel South). * doc/interp.n: 2004-11-19 Don Porter <[email protected]> * doc/AddErrInfo.3: Docs for Tcl_(Get|Set)ReturnOptions. [TIP 227] * doc/AddErrInfo.3: * doc/Async.3: Documentation updates to replace references * doc/BackgdErr.3: to global variable ::errorInfo and ::errorCode * doc/SaveResult.3: and to the ::bgerror command with references |
︙ | ︙ | |||
305 306 307 308 309 310 311 | * doc/update.n: * tests/unixInit.test: Removed "knownBug" constraints to prompt bug fixing before 8.5a2 release. 2004-11-19 Daniel Steffen <[email protected]> | | | | | | | | | | | | | | | | | | | | | | 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 | * doc/update.n: * tests/unixInit.test: Removed "knownBug" constraints to prompt bug fixing before 8.5a2 release. 2004-11-19 Daniel Steffen <[email protected]> * macosx/Makefile: * unix/configure.in: * unix/tclUnixInit.c (MacOSXGetLibraryPath): changed detection of tcl framework build when determining tclLibPath from overloaded TCL_LIBRARY to configuration define TCL_FRAMEWORK. [Bug 1068088] * unix/configure: autoconf-2.57 * unix/tclConfig.h.in: autoheader-2.57 2004-11-18 Don Porter <[email protected]> * doc/SaveResult.3: Documentation for Tcl_*InterpState (TIP 226). * generic/tclEvent.c (HandleBgErrors): Simplified program flow. * tests/basic.test: Updated functional (not testing) uses of * tests/io.test: [bgerror] to make use of [interp bgerror]. * tests/socket.test: * tests/timer.test: * tests/interp.test (interp-36.*): [interp bgerror] tests. * generic/tclInterp.c: Corrected [interp bgerror] error messages. 2004-11-18 Reinhard Max <[email protected]> * unix/tcl.m4 (SC_CONFIG_MANPAGES): Applied an improved version of * unix/configure.in: patch #996085, that introduces * unix/Makefile.in: --enable-man-suffix. * unix/installManPage: added * unix/mkLinks.tcl: removed * unix/mkLinks: removed * unix/configure: generated * unix/Makefile.in: Don't install tclConfig.h . 2004-11-17 Don Porter <[email protected]> * unix/configure.in: The change below reveals that the public data type Tcl_StatBuf relies on config information. For now, disabled the use of the tclConfig.h file until its full impact on Tcl's interface can be assessed. * unix/configure: autoconf-2.57 * generic/tcl.h: Moved the #include "tclConfig.h" out of * generic/tclInt.h: tcl.h. The config settings are not part of * generic/tclPort.: the public interface, and having it there breaks compiled against uninstalled Tcl and extensions using autoconf-2.5*. 2004-11-16 Jeff Hobbs <[email protected]> * unix/tclUnixChan.c (TtySetOptionProc): fixed crash configuring -ttycontrol on a channel. [Bug 1067708] 2004-11-16 Don Porter <[email protected]> * generic/tclIOUtil.c (TclFSEpochOk): There were two code paths via which the thread copy of filesystemEpoch could be synched with the master copy, but only one kept the filesystem list cache up to date. Fix routes everything through a single code path. [Bug 1035775]. 2004-11-16 Donal K. Fellows <[email protected]> * unix/tcl.m4 (SC_CONFIG_CFLAGS): Stop architecture flags to 'ld' from getting lost when [load] is disabled. [Bug 1016796] 2004-11-16 Daniel Steffen <[email protected]> * generic/tcl.h: * unix/configure.in: changed HAVE_CONFIG_H to HAVE_TCL_CONFIG_H. * unix/configure: autoconf-2.57 2004-11-15 Don Porter <[email protected]> * generic/tclInt.h: Added comment warning that the old ERR_IN_PROGRESS and ERROR_CODE_SET flag values should not be re-used for the sake of those extensions that have accessed them. * generic/tclCmdMZ.c (Tcl_TraceObjCmd): Fixed Bug 1065378 which failed * tests/trace.test (trace-33.1): to permit a variable trace created with [trace variable] to be destroyed with [trace remove]. Thanks to Keith Vetter for the report. 2004-11-15 Donal K. Fellows <[email protected]> * doc/tclvars.n: Added section to documentation on global variables that are specific to tclsh and wish. [Patch 1065732] 2004-11-12 Jeff Hobbs <[email protected]> * generic/tclEncoding.c (TableFromUtfProc): correct crash condition when TCL_UTF_MAX == 6. [Bug 1004065] 2004-11-12 Donal K. Fellows <[email protected]> * doc/interp.n: Basic documentation of the TIP#221 API. 2004-11-12 Don Porter <[email protected]> TIP #221 IMPLEMENTATION * generic/tclBasic.c: Define [::tcl::Bgerror] in new interps. * generic/tclEvent.c: Update Tcl_BackgroundError to make use of the registered [interp bgerror] command. * generic/tclInterp.c: New [interp bgerror] subcommand. * tests/interp.test: syntax tests updated. TIP #226 IMPLEMENTATION * generic/tcl.decls: Stubs for Tcl_(Save|Restore|Discard)InterpState * generic/tcl.h: New public opaque type, Tcl_InterpState. * generic/tclInt.h: Drop old private declarations. Add Tcl(Get|Set)BgErrorHandler * generic/tclResult.c: Tcl_*InterpState implementations. * generic/tclDictObj.c: Update callers. * generic/tclIOGT.c: * generic/tclTrace.c: TIP #227 IMPLEMENTATION |
︙ | ︙ | |||
448 449 450 451 452 453 454 | * generic/tclVar.c: it is verifiably after tclConfig.h inclusion. 2004-11-12 Daniel Steffen <[email protected]> * generic/tcl.h: * generic/tclInt.h: * unix/Makefile.in: include tclConfig.h from tcl.h and install it | | | | 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 | * generic/tclVar.c: it is verifiably after tclConfig.h inclusion. 2004-11-12 Daniel Steffen <[email protected]> * generic/tcl.h: * generic/tclInt.h: * unix/Makefile.in: include tclConfig.h from tcl.h and install it as a public header. Normalized compiler include path order to -I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR}. * unix/dltest/Makefile.in: add ${BUILD_DIR}/.. to include path to pick up tclConfig.h. * unix/tclUnixInit.c: moved check for HAVE_CFBUNDLE define after #include "tclInt.h" to ensure tclConfig.h has been included. 2004-11-12 Reinhard Max <[email protected]> * unix/config.h.in: * unix/tclConfig.h.in: renamed * unix/Makefile.in: Completed support for config header, * unix/configure.in: fixed building outside of the unix dir, * unix/tclAppinit.c: and reflected the name change of config.h. * generic/tclInt.h: * unix/configure: generated 2004-11-12 Donal K. Fellows <[email protected]> * unix/config.h.in: Allow configure to put all the C #defs into * unix/configure.in: a file (called config.h) so that Unix builds * unix/tcl.m4: now take far fewer lines of scrollback to * unix/Makefile.in: proceed (making it less likely that any errors |
︙ | ︙ | |||
569 570 571 572 573 574 575 | are still very cryptic, but they appear to have to be that way. The number of skipped tests has increased, but now the skipped tests have much more meaningful content. * tests/tm.test (genpaths): Add a [file normalize] so we pick up Windows drive letters, etc. [Bug 1053568] | | | 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 | are still very cryptic, but they appear to have to be that way. The number of skipped tests has increased, but now the skipped tests have much more meaningful content. * tests/tm.test (genpaths): Add a [file normalize] so we pick up Windows drive letters, etc. [Bug 1053568] 2004-11-04 Don Porter <[email protected]> * changes: Updates toward an 8.5a2 release. 2004-11-03 Kevin B. Kenny <[email protected]> * library/clock.tcl (FreeScan): Fixed a bug where scanning "Monday" with a base time other than midnight incorrectly carried |
︙ | ︙ | |||
602 603 604 605 606 607 608 | * win/tclWinPort.h: to prior the inclusion of the Stubs headers as they are now resetting TCL_STORAGE_CLASS. Removed extrainious reset from tclWinPort.h. [Patch 1055668] * generic/tclCompile.h: Removed extrainious reset of TCL_STORAGE_CLASS missed in my last edit. | | | 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 | * win/tclWinPort.h: to prior the inclusion of the Stubs headers as they are now resetting TCL_STORAGE_CLASS. Removed extrainious reset from tclWinPort.h. [Patch 1055668] * generic/tclCompile.h: Removed extrainious reset of TCL_STORAGE_CLASS missed in my last edit. 2004-11-03 Don Porter <[email protected]> * library/init.tcl ([unknown]): Corrections to the 2004-10-25 mods to Aunt ??? in [unknown]. Flaws revealed by Itcl test suite, which still apparently relies on this brokenness. Also added comment suggesting the error message that any code using this hack *ought* to receive in reply. |
︙ | ︙ | |||
624 625 626 627 628 629 630 | * generic/tclInt.h: added a check for #ifdef __cplusplus around the #define of MODULE_SCOPE. About the only time it would be problem is when someone is statically linking to Tcl and accessing internals from a C++ file and has name mangling issues from the lack of "C" after 'extern' [Patch 1055668]. * generic/tclCompile.h: Exchanged use of the EXTERN macro to the | | | | | | | 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 | * generic/tclInt.h: added a check for #ifdef __cplusplus around the #define of MODULE_SCOPE. About the only time it would be problem is when someone is statically linking to Tcl and accessing internals from a C++ file and has name mangling issues from the lack of "C" after 'extern' [Patch 1055668]. * generic/tclCompile.h: Exchanged use of the EXTERN macro to the new MODULE_SCOPE macro. Lowered exported internals count by 35. [Patch 1055668] * win/tclWinInt.h: * win/tclWinPort.h: exported internals dropped by a count of 14. * generic/tclFileSystem.h: Added use of MODULE_SCOPE on protos. * generic/tclRegexp.h: manipulating TCL_STORAGE_CLASS unnecessary. 2004-11-02 Don Porter <[email protected]> * library/tcltest/tcltest.tcl: Corrected some misleading * tests/tcltest.test (tcltest-26.1,2): displays of ::errorInfo and ::errorCode information when the -setup, -body, and/or -cleanup scripts return an unexpected return code. Thanks to Robert Seeger for the fix. [RFE 1017151]. 2004-11-02 Donal K. Fellows <[email protected]> * generic/tclExecute.c (TclExecuteByteCode): Improved version of the NaN fix from Miguel Sofer. [Bug 761471] 2004-11-02 Kevin Kenny <[email protected]> * library/tzdata/America/Cuiaba: Change to DST rules for * library/tzdata/America/Havana: autumn of 2004. [ftp://elsie.nci.nih.gov/pub/tzdata2004g.tar.gz] * tools/tclZIC.tcl: Updated to be compatible with recent changes in library/clock.tcl. 2004-11-02 Vince Darley <[email protected]> * win/tclWinFile.c: Simplify TclpUtime to use Tcl_FSGetNativePath, and add comments. 2004-11-02 Donal K. Fellows <[email protected]> * generic/tclInt.h: Change uses of EXTERN to MODULE_SCOPE (defined in this file too to be 'extern' if not overridden) as nothing declared in tclInt.h is supposed to be visible outside the Tcl |
︙ | ︙ | |||
698 699 700 701 702 703 704 | * tests/io.test (io-40.3): Convert umask2 test constraint into a form that most people will be able to satisfy. * tests/cmdAH.test (cmdAH-8.45): Removed broken test constraint. It didn't do what it was intended to do, and it implied the other correct constraint. [Bug 1053908] | | | | | | 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 | * tests/io.test (io-40.3): Convert umask2 test constraint into a form that most people will be able to satisfy. * tests/cmdAH.test (cmdAH-8.45): Removed broken test constraint. It didn't do what it was intended to do, and it implied the other correct constraint. [Bug 1053908] * generic/tclCmdIL.c (InfoGlobalsCmd): * tests/info.test (info-8.4): Strip leading global-namespace specifiers from the pattern argument. [Bug 1057461] 2004-10-30 Kevin Kenny <[email protected]> * generic/clock.c: Replaced WIN32 macro with __WIN32__. [Bug 1054357]. Thanks to David Gravereaux for the patch. * win/tclWinFile.c: Removed a long-standing bug that causes incorrect conversion between file time and UTC time if the file time is recorded in a different Daylight Saving Time status than the current one. [Bug 926106] 2004-10-29 Don Porter <[email protected]> * library/tcltest/tcltest.tcl: Correct reaction to errors in the obsolete processCmdLineArgsHook. [Bug 1055673] * library/tcltest/pkgIndex.tcl: Bump to tcltest 2.2.7 * unix/Makefile.in: * tests/all.tcl: Update to use [tcltest::configure]. |
︙ | ︙ | |||
734 735 736 737 738 739 740 | in doing this. * tests/namespace.test (namespace-50.*): Tests of ensemble subcommand error message rewriting. * generic/tclProc.c (TclObjInterpProc): Make procedures implement their wrong-num-args message using Tcl_WrongNumArgs instead of something baked-at-home. | | | | | | 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 | in doing this. * tests/namespace.test (namespace-50.*): Tests of ensemble subcommand error message rewriting. * generic/tclProc.c (TclObjInterpProc): Make procedures implement their wrong-num-args message using Tcl_WrongNumArgs instead of something baked-at-home. * generic/tclNamesp.c (TclIsEnsemble, NsEnsembleImplementationCmd): Added test of ensemble-hood (available to rest of core) and made ensembles set up the rewriting for Tcl_WrongNumArgs to take advantage of. * generic/tclInt.h (Interp.ensembleRewrite): Extra fields. * generic/tclIndexObj.c (Tcl_WrongNumArgs): Add knowledge of what is going on in ensembles' command rewriting so this command can generate the right error message itself. * generic/tclBasic.c (Tcl_CreateInterp, TclEvalObjvInternal): Added code to initialize (as empty) the rewriting fields and reset them when we leak outside an ensemble implementation. 2004-10-28 Miguel Sofer <[email protected]> * generic/tclExecute.c (INST_START_CMD): * tests/execute.test (execute-8.3): fix for execution stack corruption [Bug 1055676]. Credit dgp for detective work and fix. 2004-10-27 Don Porter <[email protected]> * tests/socket.test (socket-13.1): Balanced [makeFile] and [removeFile] commands. * tests/clock.test: Correct duplicate test names. * tests/namespace.test: * tests/string.test: * tests/io.test (io-50.4): Use namespace variables. |
︙ | ︙ | |||
804 805 806 807 808 809 810 | * tests/tm.test: Expanded on the testsuite entered by Donal. * library/tm.tcl: Even found bugs, these have been corrected. 2004-10-26 Kevin Kenny <[email protected]> * tests/format.test (format-19.1): Additional regression test for | | | | | 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 | * tests/tm.test: Expanded on the testsuite entered by Donal. * library/tm.tcl: Even found bugs, these have been corrected. 2004-10-26 Kevin Kenny <[email protected]> * tests/format.test (format-19.1): Additional regression test for Bug 868489. 2004-10-27 Donal K. Fellows <[email protected]> * doc/*.n: Many small general documentation fixes. 2004-10-26 David Gravereaux <[email protected]> * generic/tclPipe.c (TclCleanupChildren): bad cast of resolvedPid caused PIDs on win95 to go negative. winpipe-4.2 brought this to the surface. Fixed with sprintf in place of TclFormatInt. Thanks to hgiese [Patch 767676] 2004-10-26 Andreas Kupries <[email protected]> * library/tm.tcl (::tcl::tm::Defaults): Added a second [file dirname] around the location of the executable. This fixes [Tcl SF Bug 1038705]. Instable of a bogus "foo/bin/lib" we now have the correct "foo/lib" as a base path for modules. 2004-10-26 Don Porter <[email protected]> * generic/tclParse.c (Tcl_SubstObj): Fix for failed subst-12.3 test. * tests/subst.test (subst-12.3-5): More tests for Bug 1036649. * unix/Makefile.in (install-libraries): Updated the installation of the http, msgcat, and tcltest packages to install as Tcl Modules on Unix systems. Other platform Makefiles still need updating. [Patch 1054370] * tests/basic.test: Added missing constraints. |
︙ | ︙ | |||
872 873 874 875 876 877 878 | single characters. [Bug 1048005] * doc/info.n (procs): Clarified that the pattern argument may have namespace separators in it. [Bug 1047928] * tests/cmdAH.test (cmdAH-8.45): Simplify in the hope that the reasons for [Bug 1053908] will become clearer. | | | 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 | single characters. [Bug 1048005] * doc/info.n (procs): Clarified that the pattern argument may have namespace separators in it. [Bug 1047928] * tests/cmdAH.test (cmdAH-8.45): Simplify in the hope that the reasons for [Bug 1053908] will become clearer. 2004-10-25 Don Porter <[email protected]> * generic/tclExecute.c (IllegalExprOperandType,TclExecuteByteCode): Removed several DECACHE_INFO/CACHE_INFO pairs that are no longer needed for protection because routines like Tcl_SetErrorCode() and Tcl_AddErrorInfo() can no longer re-enter bytecode execution. * generic/tclResult.c (TclProcessReturn): Bug fix. Be sure that |
︙ | ︙ | |||
894 895 896 897 898 899 900 | * library/clock.tcl remaining references to global vars * library/init.tcl ::errorInfo and ::errorCode. * generic/tclMain.c (Tcl_Main): Updated to make use of TclGetReturnOptions instead of ::errorInfo variable. * generic/tclInterp.c (tclInit): Bug fix. Access dict variables | | | | | 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 | * library/clock.tcl remaining references to global vars * library/init.tcl ::errorInfo and ::errorCode. * generic/tclMain.c (Tcl_Main): Updated to make use of TclGetReturnOptions instead of ::errorInfo variable. * generic/tclInterp.c (tclInit): Bug fix. Access dict variables with [dict get], not array syntax. 2004-10-25 Donal K. Fellows <[email protected]> * tests/tm.test: Rewrote the tests to actually perform syntax checks on the public API. Added a new test (currently failing) to indicate that the test suite is not complete yet. * library/tm.tcl (path): Rewrote to turn this command into an ensemble to make it faster and simpler. 2004-10-24 Miguel Sofer <[email protected]> * generic/tclCmdIL.c: * generic/tclExecute.c: * generic/tclInt.h: * generic/tclTrace.c: defined new macros to get/set the flags of variables. The only files that still access the flag values directly are tclCompCmds.c, tclCompile.c, tclProc.c and tclVar.c 2004-10-24 Don Porter <[email protected]> * generic/tclBasic.c (Tcl_LogCommandInfo,Tcl_AddObjErrorInfo): Shift the initialization of errorCode to NONE to more central location. * generic/tclEvent.c (BgError,Tcl_BackgroundError,HandleBgErrors): Rewrite to build on the new TclGet/SetReturnOptions routines. |
︙ | ︙ | |||
950 951 952 953 954 955 956 | * tests/clock.test: Added regression test cases that covers both bugs. Thanks to Todd M. Helfter <[email protected]> for finding these bugs. 2004-10-22 Donal K. Fellows <[email protected]> | | | | 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 | * tests/clock.test: Added regression test cases that covers both bugs. Thanks to Todd M. Helfter <[email protected]> for finding these bugs. 2004-10-22 Donal K. Fellows <[email protected]> * generic/tclExecute.c (TclCompEvalObj, Tcl_ExprObj): * generic/tclProc.c (TclProcCompileProc): Always call object freeIntRepProc's in the same way. 2004-10-22 Miguel Sofer <[email protected]> * generic/tclVar.c: fixed bug in commit of 2004-07-23, which was causing a leak of Proc structures and failure of compile-12.1. Two lines were 'zombies' from the previous way localVarNames worked. Credit dgp for finding this. 2004-10-21 Don Porter <[email protected]> * generic/tclInt.h (Interp): * generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp): * generic/tclResult.c (GetKeys,ReleaseKeys,etc.): Moved the key values of the return options dictionary out of private fields of the Interp struct and into thread-static values managed in tclResult.c. |
︙ | ︙ | |||
988 989 990 991 992 993 994 | * generic/tclResult.c (TclProcessReturn,TclMergeReturnOptions): Move internal utility routines from tclCmdMZ.c to tclResult.c. * generic/tclBasic.c (Tcl_CreateInterp, Tcl_DeleteInterp): * generic/tclResult.c (TclTransferResult): Rework so that iPtr->returnOpts can be NULL when there are no special options. | | | | | 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 | * generic/tclResult.c (TclProcessReturn,TclMergeReturnOptions): Move internal utility routines from tclCmdMZ.c to tclResult.c. * generic/tclBasic.c (Tcl_CreateInterp, Tcl_DeleteInterp): * generic/tclResult.c (TclTransferResult): Rework so that iPtr->returnOpts can be NULL when there are no special options. * generic/tclResult.c (TclRestoreInterpState): Plug potential memory leak. 2004-10-21 Kevin B. Kenny <[email protected]> * generic/tclBasic.c: Various changes to [clock format] that, * generic/tclClock.c: together, make it roughly twice as fast * generic/tclInt.h: while all tests in the test suite * library/clock.tcl: continue to pass. 2004-10-20 Andreas Kupries <[email protected]> * win/Makefile.in (install-msgs): Fixed a problem with the * win/Makefile.in (install-tzdata): installation of timezone data and message catalogs. They used the installed tcl library directory, not the source library. Before it was installed. Switched to source lib dir. Thanks to Kevin for the help in figuring this out. 2004-10-20 Don Porter <[email protected]> * generic/tclThreadTest.c (ThreadEventProc): Corrected subtle bug where the returned (char *) from Tcl_GetStringResult(interp) continued to be used without copying or refcounting, while activity on the interp continued. That's not safe, and recent changes demonstrated the lack of safety with failing tests thread-4.3 and thread-4.5. 2004-10-19 Donal K. Fellows <[email protected]> * generic/tclDictObj.c (DictWithCmd): Make sure all paths (that are not themselves error paths) do not lose the result code. 2004-10-19 Don Porter <[email protected]> * generic/tclInt.h (Tcl*InterpState): New internal routines * generic/tclResult.c (Tcl*InterpState): TclSaveInterpState, TclRestoreInterpState, and TclDiscardInterpState are superior replacements for Tcl_(Save|Restore|Discard)Result. Intent is that these routines will be converted to public routines after TIP approval. Interfaces for these routines were shamelessly stolen from Itcl. |
︙ | ︙ | |||
1044 1045 1046 1047 1048 1049 1050 | * generic/tclEvent.c (HandleBgErrors): * generic/tclFCmd.c (CopyRenameOneFile): Calls to Tcl_*Result that were eliminated because they appeared to serve no useful purpose, typically saving/restoring an error message, only to throw it away. | | | | | | 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 | * generic/tclEvent.c (HandleBgErrors): * generic/tclFCmd.c (CopyRenameOneFile): Calls to Tcl_*Result that were eliminated because they appeared to serve no useful purpose, typically saving/restoring an error message, only to throw it away. 2004-10-18 Don Porter <[email protected]> * generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp): * generic/tclCmdAH.c (Tcl_CatchObjCmd): * generic/tclCmdMZ.c (TclMergeReturnOptions,TclProcessReturn): * generic/tclCompCmds.c (TclCompileReturnCmd): * generic/tclExecute.c (TclCompEvalObj): * generic/tclInt.h (Interp): * generic/tclProc.c (TclUpdateReturnInfo): Place primary storage of the -level and -code information in private fields of the Interp struct, rather than in a DictObj. This should significantly improve performance of TclUpdateReturnInfo. 2004-10-17 Miguel Sofer <[email protected]> * generic/tclResult.c: removed unused variable [Bug 1048588]. Thanks to Daniel South. 2004-10-15 Don Porter <[email protected]> * generic/tclCmdMZ.c (TclProcessReturn): Now that primary * generic/tclProc.c (TclUpdateReturnInfo): storage for the errorInfo and errorCode values are internal fields, we can set them at the time of the [return] command, and not have to wait until the specified number of "-level"s have popped. |
︙ | ︙ | |||
1091 1092 1093 1094 1095 1096 1097 | (Tcl_ResetResult,TclTransferResult): * generic/tclTrace.c (CallVarTraces): Reworked management of the "errorInfo" data of an interp. That information is now primarily stored in a new private (Tcl_Obj *) field of the Interp struct, rather than using a global variable ::errorInfo as the primary storage. The ERR_IN_PROGRESS flag bit value is no longer required to manage | | | 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 | (Tcl_ResetResult,TclTransferResult): * generic/tclTrace.c (CallVarTraces): Reworked management of the "errorInfo" data of an interp. That information is now primarily stored in a new private (Tcl_Obj *) field of the Interp struct, rather than using a global variable ::errorInfo as the primary storage. The ERR_IN_PROGRESS flag bit value is no longer required to manage the value in its new location, and is removed. Variable traces are established to support compatibility for any code expecting the ::errorInfo variable to hold the information. ***POTENTIAL INCOMPATIBILITY*** Code that sets traces on the ::errorInfo variable may notice a difference in timing of the firing of those traces. Code that uses the value ERR_IN_PROGRESS. |
︙ | ︙ | |||
1136 1137 1138 1139 1140 1141 1142 | * generic/tclExecute.c (TclExecuteByteCode): Implementation of the INST_LIST_IN and INST_LIST_NOT_IN bytecodes. * generic/tclParseExpr.c (GetLexeme): Parse the 'in' and 'ni' operators for TIP#201. * generic/tclDictObj.c (DictUpdateCmd,DictWithCmd): Core of implementation of TIP#212; docs and tests still to do... | | | | 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 | * generic/tclExecute.c (TclExecuteByteCode): Implementation of the INST_LIST_IN and INST_LIST_NOT_IN bytecodes. * generic/tclParseExpr.c (GetLexeme): Parse the 'in' and 'ni' operators for TIP#201. * generic/tclDictObj.c (DictUpdateCmd,DictWithCmd): Core of implementation of TIP#212; docs and tests still to do... 2004-10-07 Don Porter <[email protected]> * generic/tclTest.c (TestsetobjerrorcodeCmd): Simplified. 2004-10-07 Vince Darley <[email protected]> * generic/tclFileName.c: * generic/tclFileSystem.h: * generic/tclIOUtil.c: * generic/tclPathObj.c: * unix/tclUnixFile.c: * win/tclWinFile.c: * tests/fileName.test: * tests/winFCmd.test: code reorganization for better generic/ platform code splitting [Bug 925620] removing the need for several #ifdef's, and tests and fix for an unreported Windows glob problem ('glob -dir C: -tails *'). 2004-10-07 Donal K. Fellows <[email protected]> * *.3: Convert CONST to const and VOID to void so we document how people should actually use the Tcl API and not the compatability hacks that it has to have. |
︙ | ︙ | |||
1191 1192 1193 1194 1195 1196 1197 | the Engineering Manual more closely, and also take advantage of the internal object manipulation macros more. * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Reorganized to have fewer magic flag variables and to separate the code that scans for a match from the code that processes a match body. | | | 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 | the Engineering Manual more closely, and also take advantage of the internal object manipulation macros more. * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Reorganized to have fewer magic flag variables and to separate the code that scans for a match from the code that processes a match body. 2004-10-06 Don Porter <[email protected]> * generic/tclBasic.c: * generic/tclBinary.c: * generic/tclCmdAH.c: * generic/tclCmdIL.c: * generic/tclCmdMZ.c: * generic/tclCompExpr.c: |
︙ | ︙ | |||
1226 1227 1228 1229 1230 1231 1232 | * win/tclWinDde.c: * win/tclWinFCmd.c: * win/tclWinPipe.c: * win/tclWinReg.c: It is a poor practice to directly set or append to the value of the objResult of an interp, because that value might be shared, and in that circumstance a Tcl_Panic() will be the | | | | | 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 | * win/tclWinDde.c: * win/tclWinFCmd.c: * win/tclWinPipe.c: * win/tclWinReg.c: It is a poor practice to directly set or append to the value of the objResult of an interp, because that value might be shared, and in that circumstance a Tcl_Panic() will be the result. Searched for example of this practice and replaced with safer alternatives, often using the Tcl_AppendResult() routine that dkf just rehabilitated. * library/dde/pkgIndex.tcl: Bump to dde 1.3.1 * library/reg/pkgIndex.tcl: Bump to registry 1.1.5 2004-10-06 Donal K. Fellows <[email protected]> * doc/SetResult.3: Made Tcl_AppendResult non-deprecated; better that people use it than most of the common alternatives! * generic/tclResult.c (Tcl_AppendResultVA): Make this work better with Tcl_Objs. [Patch 1041072] (Tcl_SetResult, Tcl_AppendElement): Change string to stringPtr to avoid C++ keywords. 2004-10-05 Don Porter <[email protected]> * generic/tclBasic.c (TclObjInvoke): More simplification of the TclObjInvoke routine toward unification with the rest of the evaluation stack. * generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp, TclEvalObjvInternal,Tcl_LogCommandInfo): * generic/tclCmdAH.c (Tcl_CatchObjCmd): * generic/tclEvent.c (BgError,Tcl_BackgroundError,HandleBgErrors): * generic/tclInt.h (Interp, ERROR_CODE_SET): * generic/tclNamesp.c (Tcl_CreateNamespace,Tcl_DeleteNamespace,TclTeardownNamespace): * generic/tclResult.c (Tcl_ResetResult,Tcl_SetObjErrorCode,TclTransferResult): * generic/tclTrace.c (CallVarTraces): Reworked management of the "errorCode" data of an interp. That information is now primarily stored in a new private (Tcl_Obj *) field of the Interp struct, rather than using a global variable ::errorCode as the primary storage. The ERROR_CODE_SET flag bit value is no longer required to manage the value in its new location, and is removed. Variable traces are established to support compatibility for any code expecting the ::errorCode variable to hold the information. ***POTENTIAL INCOMPATIBILITY*** Code that sets traces on the ::errorCode variable may notice a difference in timing of the firing of those traces. |
︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 | 2004-10-04 Donal K. Fellows <[email protected]> * generic/tclParseExpr.c (GetLexeme): Ensure that the 'eq' and 'ne' operators are followed by non-alphabetic characters so lexemes can't run together. [Bug 884830] * doc/DictObj.3, doc/dict.n: Clarified that a dictionary is not | | | | | | | 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 | 2004-10-04 Donal K. Fellows <[email protected]> * generic/tclParseExpr.c (GetLexeme): Ensure that the 'eq' and 'ne' operators are followed by non-alphabetic characters so lexemes can't run together. [Bug 884830] * doc/DictObj.3, doc/dict.n: Clarified that a dictionary is not order-preserving. [Bug 1032243] Also added another example to show off more ways of using a dictionary and a few other formatting improvements. 2004-10-02 Donal K. Fellows <[email protected]> * generic/tclDictObj.c (TraceDictPath, Tcl_DictObjPutKeyList): Add support for automatic creation of dictionary paths since that is what everyone seems to actually expect of the API! [Bug 1037235] (Tcl_DictObjNext): Make calling this after Tcl_DictObjDone non-fatal as that simplifies a number of internal APIs. This doesn't break any existing working code as it is a case which previously caused a panic. 2004-10-02 Don Porter <[email protected]> * tests/namespace.test (namespace-8.7): Another test for save/restore of ::errorInfo and ::errorCode during global namespace teardown. 2004-10-01 Donal K. Fellows <[email protected]> * generic/tclProc.c (TclObjGetFrame, Tcl_UplevelObjCmd): * generic/tclVar.c (Tcl_UpvarObjCmd): Cache stackframe level references in the level object for speed. 2004-09-30 Don Porter <[email protected]> * generic/tclBasic.c (Tcl_CreateInterp): Removed the flag bit value * generic/tclInt.h (Interp): EXPR_INITIALIZED. It was set during interp creation and never tested. Whatever purpose it had is in the past. * generic/tclBasic.c (Tcl_EvalObjEx): Removed the flag bit value * generic/tclInt.h (Interp): USE_EVAL_DIRECT. It was used only * generic/tcLTest.c (TestevalexObjCmd): in the testing command * tests/parser.test (parse-9.2): [testevalex] and nothing in the test suite made use of the capability it enabled. * generic/tclBasic.c (Tcl_AddObjErrorInfo): More re-organization * generic/tclCmdAH.c (Tcl_ErrorObjCmd): of the management of * generic/tclCmdMZ.c (TclProcessReturn): the errorCode value. * tests/error.test (error-6.4-9): * generic/tclNamespace.c (TclTeardownNamespace): Tcl_Obj-ified * tests/namespace.test (namespace-8.5,6): the save/restore of ::errorInfo and ::errorCode during global namespace teardown. Revised the comment to clarify why this is done, and added tests |
︙ | ︙ | |||
1347 1348 1349 1350 1351 1352 1353 | * tests/var.test (var-16.1): values that define part of the interpreter state during variable traces. [Bug 1038021]. 2004-09-30 Miguel Sofer <[email protected]> * tests/subst.test (12.1-2): added tests for [Bug 1036649] | | | | | | | | | | | | | | | | | | | | | | | 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 | * tests/var.test (var-16.1): values that define part of the interpreter state during variable traces. [Bug 1038021]. 2004-09-30 Miguel Sofer <[email protected]> * tests/subst.test (12.1-2): added tests for [Bug 1036649] 2004-09-29 Don Porter <[email protected]> * tests/basic.test (49.*): New tests for TCL_EVAL_GLOBAL. 2004-09-29 Donal K. Fellows <[email protected]> * generic/tclVar.c (TclObjLookupVar, TclObjLookupVar): (TclObjUnsetVar2, SetArraySearchObj): * generic/tclUtil.c (SetEndOffsetFromAny): * generic/tclStringObj.c (Tcl_SetStringObj): (Tcl_SetUnicodeObj, SetStringFromAny): * generic/tclResult.c (ResetObjResult): * generic/tclRegexp.c (Tcl_GetRegExpFromObj): * generic/tclPathObj.c (TclFSMakePathRelative, SetFsPathFromAny): (TclFSMakePathFromNormalized, Tcl_FSNewNativePath): * generic/tclObj.c (TclFreeObj, Tcl_SetBooleanObj, SetBooleanFromAny): (Tcl_SetDoubleObj, SetDoubleFromAny, Tcl_SetIntObj): (SetIntOrWideFromAny, Tcl_SetLongObj, SetWideIntFromAny): (Tcl_SetWideIntObj, TclSetCmdNameObj, SetCmdNameFromAny): * generic/tclNamesp.c (SetNsNameFromAny, MakeCachedEnsembleCommand): * generic/tclListObj.c (Tcl_SetListObj, SetListFromAny): * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): * generic/tclDictObj.c (SetDictFromAny): * generic/tclCompile.c (TclInitByteCodeObj): * generic/tclBinary.c (Tcl_SetByteArrayObj, SetByteArrayFromAny): * generic/tclInt.h (TclFreeIntRep): Factorize out deletion of object internal representation to a shared macro, so simplifying much code. 2004-09-27 Miguel Sofer <[email protected]> * generic/tclBasic.c (TclObjInvoke): fix for bogus gcc warning about uninitialised variable. 2004-09-27 Don Porter <[email protected]> * generic/tclBasic.c: Removed internal routines TclInvoke, * generic/tclInt.decls: TclGlobalInvoke, TclObjInvokeGlobal and * tests/basic.test: the portion of TclObjInvoke that handles calls without TCL_INVOKE_HIDDEN enabled. None of this code is called any longer within the core, and the superior public interface, Tcl_EvalObjv, is available for any external callers. |
︙ | ︙ | |||
1411 1412 1413 1414 1415 1416 1417 | * tests/winFCmd.test: fix to bad error message with 'cd' on windows, when permissions are inadequate [Bug 1035462] and to treatment of a volume-relative pwd on Windows [Bug 1018980]. * doc/FileSystem.3: added missing Tcl_GlobTypeData documentation [Bug 935853] | | | | 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 | * tests/winFCmd.test: fix to bad error message with 'cd' on windows, when permissions are inadequate [Bug 1035462] and to treatment of a volume-relative pwd on Windows [Bug 1018980]. * doc/FileSystem.3: added missing Tcl_GlobTypeData documentation [Bug 935853] 2004-09-27 Kevin Kenny <[email protected]> * compat/strftime.c (Removed): * generic/tclClock.c (removed TclClockOldscanObjCmd): * generic/tclDate.c (Regenerated): * generic/tclGetDate.y: * generic/tclInt.decls (removed TclGetDate and TclpStrftime): * generic/tclInt.h (removed TclGetDateInfo): * generic/tclIntDecls.h (Regenerated): * generic/tclStubInit.c (Regenerated): * library/clock.tcl: * unix/tclUnixTime.c (removed TclpStrftime): * win/Makefile.in: * win/makefile.bc: * win/makefile.bc: * win/tcl.dsp: Continued refactoring of [clock] for TIP 173 changes. Broke the free-form parser apart so that the Bison parser |
︙ | ︙ | |||
1444 1445 1446 1447 1448 1449 1450 | have been removed. The refactoring also has the benefit that all storage in the Bison parser is now on the C stack, eliminating any need for mutex protection around [clock scan]. Also, changed the Makefiles so that 'make gendate' is available on Windows as well as Unix. * generic/tclCmdAH.c (Tcl_FormatObjCmd): Removed some grubby | | | | | 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 | have been removed. The refactoring also has the benefit that all storage in the Bison parser is now on the C stack, eliminating any need for mutex protection around [clock scan]. Also, changed the Makefiles so that 'make gendate' is available on Windows as well as Unix. * generic/tclCmdAH.c (Tcl_FormatObjCmd): Removed some grubby * generic/tclObj.c (SetBooleanFromAny): work-around code that was needed only because of Bug 868489. * generic/tclBasic.c (TclObjInvoke): Removed three unused variables to silence a compiler warning in VC++. 2004-09-27 Vince Darley <[email protected]> * doc/FileSystem.3: fix to small typo. |
︙ | ︙ | |||
1469 1470 1471 1472 1473 1474 1475 | * generic/tclProc.c: * tests/compExpr-old.test: * tests/compExpr.test: * tests/expr.test: * tests/for.test: * tests/if.test: * tests/incr.test: | | | | | | 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 | * generic/tclProc.c: * tests/compExpr-old.test: * tests/compExpr.test: * tests/expr.test: * tests/for.test: * tests/if.test: * tests/incr.test: * tests/while.test: Report compilation errors at runtime, [Patch 1033689] by dgp. 2004-09-23 Mo DeJong <[email protected]> * unix/dltest/Makefile.in (clean): Fixup make clean rule so that it does not delete all files when SHLIB_SUFFIX is set to the empty string in a static build. [Bug 1016726] 2004-09-23 Don Porter <[email protected]> * generic/tclBasic.c: Corrections to the 2004-09-21 commit * generic/tclExecute.c: regarding ERR_ALREADY_LOGGED. That commit * generic/tclNamesp.c: caused Tk test send-10.7 to fail. Added * tests/namespace.test (25.7,8): tests in the Tcl test suite * tests/pkg.test (2.25,26): to catch this error without the aid of Tk in the future. * generic/tclCmdAH.c (Tcl_ExprObjCmd): Simplified the TclObjCmdProc of [expr] with a call to Tcl_ConcatObj. 2004-09-22 Don Porter <[email protected]> * generic/tclCmdMZ.c (TclProcessReturn): Support the -errorline * generic/tclCompile.c (TclCompileScript): option to [return]. * tests/compile.test (16.23.*): Use that capability to defer reporting * tests/misc.test (1.2): of parse errors until runtime. Updated tests to reflect change. [Bug 1032805] |
︙ | ︙ | |||
1513 1514 1515 1516 1517 1518 1519 | * library/tzdata/America/Montevideo: Updated to reflect ftp://elsie.nci.nih.gov/pub/tzdata2004d.tar.gz. (Changes to Asia/Jerusalem were in the comments only.) [Routine maintenance - no bug] Spanish-language description of the change at http://www.presidencia.gub.uy/decretos/2004091502.htm | | | | | 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 | * library/tzdata/America/Montevideo: Updated to reflect ftp://elsie.nci.nih.gov/pub/tzdata2004d.tar.gz. (Changes to Asia/Jerusalem were in the comments only.) [Routine maintenance - no bug] Spanish-language description of the change at http://www.presidencia.gub.uy/decretos/2004091502.htm 2004-09-21 Don Porter <[email protected]> * generic/tclCompCmds.c: Tolerate [append] syntax errors * tests/appendComp.test (8.1): at compile time, and allow runtime to raise the error (or succeed if a redefined [append] allows). * generic/tclBasic.c: Reworked management of the interp * generic/tclCompile.c: flag ERR_ALREADY_LOGGED, to reduce * generic/tclExecute.c: its exposure. Still left several * generic/tclNamesp.c: references that are just too nice on performace to do away with. These changes also resolve an inconsistency in the ::errorInfo values produced by [namespace eval x error foo bar] and [namespace eval x {error foo bar}]. * generic/tclExecute.c (TclCompEvalObj): Simplified the TclCompEvalObj routine. Much housekeeping now reliably happens elsewhere. [Patch 1031949] 2004-09-21 Donal K. Fellows <[email protected]> * doc/interp.n: Tighten up wording on how [interp eval] and [interp invokehidden] operate w.r.t. stack frames. [Bug 926590] 2004-09-20 Don Porter <[email protected]> * tests/error.test (error-6.2,3): Added more tests to verify ::errorCode setting by/after a [catch]. 2004-09-19 Miguel Sofer <[email protected]> * generic/tclCmdAH.c: removed outdated comment [Bug 1029518]. |
︙ | ︙ | |||
1561 1562 1563 1564 1565 1566 1567 | * generic/tclExecute.c (TEBC-INST_LSHIFT,INST_RSHIFT): Ensure that large shifts end up shifting correctly. [Bug 868467] * doc/FileSystem.3, doc/OpenFileChnl.3: More documentation fixes from Mikhail Kolesnitchenko. [Patch 1022527] * doc/*: Standardize highlighting of symbols defined in tcl.h | | | | | | | | 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 | * generic/tclExecute.c (TEBC-INST_LSHIFT,INST_RSHIFT): Ensure that large shifts end up shifting correctly. [Bug 868467] * doc/FileSystem.3, doc/OpenFileChnl.3: More documentation fixes from Mikhail Kolesnitchenko. [Patch 1022527] * doc/*: Standardize highlighting of symbols defined in tcl.h 2004-09-17 Don Porter <[email protected]> * generic/tclBasic.c (Tcl_AddObjErrorInfo, Tcl_LogCommandInfo): * generic/tclCmdAH.c ([catch], [error]): * generic/tclCmdMZ.c ([return]): * generic/tclProc.c (TclUpdateReturnInfo): * generic/tclResult.c (Tcl_SetErrorCodeVA, Tcl_SetObjErrorCode) (TclTransferResult): Refactored so that all errorCode setting flows through Tcl_SetObjErrorCode(). This greatly reduces the number of different places in the code that need to know details about an internal bitflag field of the Interp struct. Also places errorCode setting in one place for easier future mods. 2004-09-17 Kevin B.Kenny <[email protected]> * generic/tclDate.c: Revised tclGetDate.y to use bison instead * generic/tclGetDate.y: of yacc to build the parser, eliminating * generic/tclInt.h: all the complicated hackery involving * unix/Makefile.in: 'sed' postprocessing. Rebuilt the parser. 2004-09-14 Kevin B. Kenny <[email protected]> * generic/tclClock.c (ClockOldscanObjCmd): Silenced a compiler warning (long passed as a param where unsigend long was expected). 'Unsigned long' is wrong, but the fix is really to change the signature of TclGetDate to return a structure of its 'yy' variables and then do the remaining work inside clock.tcl. But, as I said on 2004-09-08, that's a job for another day. [Bug 1027993] 2004-09-10 Miguel Sofer <[email protected]> * doc/interp.n: * generic/tclInterp.c (TclPreventAliasLoop, AliasCreate): * tests/interp.test (17.4-6, 19.3-4): fixing problems with renaming of aliases [Bugs 707104 1026493]. Fix designed by dgp. 2004-09-13 Donal K. Fellows <[email protected]> * generic/tclNamesp.c (NsEnsembleImplementationCmd): Add token field to internal rep of EnsembleCmdRep structure so that we can check it to see if the subcommand object is really being used with the same ensemble. [Bug 1026903] |
︙ | ︙ | |||
1640 1641 1642 1643 1644 1645 1646 | 2004-09-10 Andreas Kupries <[email protected]> * generic/tcl.h: Micro formatting fixes. * generic/tclIOGT.c: Channel version fixed, must be 3, to have wideseekProc. Thanks to David Graveraux <[email protected]>. | | | | | | 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 | 2004-09-10 Andreas Kupries <[email protected]> * generic/tcl.h: Micro formatting fixes. * generic/tclIOGT.c: Channel version fixed, must be 3, to have wideseekProc. Thanks to David Graveraux <[email protected]>. 2004-09-11 Don Porter <[email protected]> * generic/tclNamespace.c (TclGetNamespaceForQualName): Resolved longstanding inconsistency in the treatment of the TCL_NAMESPACE_ONLY flag revealed by testing the 2004-09-09 commits against Itcl. TCL_NAMESPACE_ONLY now acts as specified in the pre-function comment, forcing resolution in the passed in context namespace. It has been incorrectly forcing resolution in the interp's current namespace. 2004-09-10 Kevin Kenny <[email protected]> * library/clock.tcl: Fixed a bug where %z always put a plus sign on the time zone in :localtime. * tests/clock.test: Added test case for the above bug. 2004-09-10 Miguel Sofer <[email protected]> * generic/tclExecute.c (INST_CONCAT1): added a peephole optimisation for concatting an empty string. This enables replacing the idiom 'K $x [set x {}]' by '$x[set x {}]' for fastest execution. 2004-09-09 David Gravereaux <[email protected]> * win/tclWinConsole.c: Calls to WriteFile and WriteConsoleA changed to WriteConsole for simplicity. 2004-09-09 Don Porter <[email protected]> * generic/tclNamesp.c (Tcl_ForgetImport): Corrected faulty * tests/namespace.test: logic that relied exclusively on string matching and failed in the presence of [rename]s. [Bug 560297] Also corrected faulty prevention of [namespace import] cycles. [Bug 1017299] 2004-09-08 Don Porter <[email protected]> * generic/tclBasic.c (Tcl_CreateInterp): Removed obsolete field for storing the string-based command procedure of built-in commands. We no longer have any string-based built-in commands! 2004-09-08 Kevin B. Kenny <[email protected]> |
︙ | ︙ | |||
1698 1699 1700 1701 1702 1703 1704 | clock-34.* test cases so that the consistency check is performed in :localtime rather than the current time zone. This change allows dealing with issues where the C library has a different idea of DST conversion than Tcl. (Real fix would be to break TclGetDate into separate parser and time converter, and do the time conversion in clock.tcl. That's for another day.) Added regression test case for the bug where month was scanned | | | 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 | clock-34.* test cases so that the consistency check is performed in :localtime rather than the current time zone. This change allows dealing with issues where the C library has a different idea of DST conversion than Tcl. (Real fix would be to break TclGetDate into separate parser and time converter, and do the time conversion in clock.tcl. That's for another day.) Added regression test case for the bug where month was scanned incorrectly in -timezone :localtime. [Bug 1023779] Added regression test case for %k at the zero hour. 2004-09-07 David Gravereaux <[email protected]> * win/makefile.vc: some quoting needed to be removed as it was breaking with VC7. [Bug 1023150] |
︙ | ︙ | |||
1721 1722 1723 1724 1725 1726 1727 | its imports. [Bug 1016167] * library/clock.tcl (InitTZData, ClearCaches): Changed so that the in-memory time zone :UTC (and its aliases) always gets reinitialised, in case tzdata is absent. [Bug 1019537, 1023779] * library/tzdata/*: Regenerated. * tests/clock.test (clock-31.*, clock-39.1): Corrected a problem where the 'system' locale tests fail on a non-English Windows | | | 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 | its imports. [Bug 1016167] * library/clock.tcl (InitTZData, ClearCaches): Changed so that the in-memory time zone :UTC (and its aliases) always gets reinitialised, in case tzdata is absent. [Bug 1019537, 1023779] * library/tzdata/*: Regenerated. * tests/clock.test (clock-31.*, clock-39.1): Corrected a problem where the 'system' locale tests fail on a non-English Windows machine. [Bug 1023761]. Added a test to make sure that alias time zones load correctly. [Bug 1023779]. * tests/timer.test (timer-1.1, timer-2.1): Changed to (one hopes!) be more resilient on an overloaded system, if [after 200] sleeps for 300 ms or longer. * tools/tclZIC.tcl (writeLinks): Corrected a problem where alias time zone names were written incorrectly, causing them to fail to load at run time. [Bug 1023779]. |
︙ | ︙ | |||
1761 1762 1763 1764 1765 1766 1767 | * doc/lsearch.n: Clarified meaning of -dictionary. [Bug 759545] 2004-09-02 Vince Darley <[email protected]> * win/makefile.vc: clock.tcl needs to be installed. | | | | | | | | | 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 | * doc/lsearch.n: Clarified meaning of -dictionary. [Bug 759545] 2004-09-02 Vince Darley <[email protected]> * win/makefile.vc: clock.tcl needs to be installed. 2004-09-01 Jeff Hobbs <[email protected]> * win/tclWinReg.c (BroadcastValue): WIN64 cast corrections * win/tclWinDde.c (DdeClientWindowProc): (DdeServicesOnAck, DdeEnumWindowsCallback): WIN64 corrections * win/tclWin32Dll.c (TclWinCPUID): need _asm for WIN64 (Itanium), until we have it, just return unknown. [Bug 1020445] 2004-09-01 Donal K. Fellows <[email protected]> * doc/regsub.n, doc/RegConfig.3, doc/Environment.3: * doc/CrtChannel.3, doc/safe.n: Use correct abbreviations. 2004-08-31 Donal K. Fellows <[email protected]> * doc/trace.n, doc/socket.n, doc/registry.n, doc/pid.n: * doc/namespace.n, doc/msgcat.n, doc/lsort.n, doc/lsearch.n: * doc/linsert.n, doc/info.n, doc/http.n, doc/history.n: * doc/format.n, doc/file.n, doc/exec.n, doc/dde.n, doc/clock.n: * doc/catch.n, doc/binary.n: More spelling and grammar fixes from Mikhail Kolesnitchenko. [Patch 1018486] 2004-08-31 Vince Darley <[email protected]> * doc/FileSystem.3: * generic/tclIOUtil.c: Clarified documentation regarding ability |
︙ | ︙ | |||
1821 1822 1823 1824 1825 1826 1827 | * unix/Makefile.in: added customization of default module path roots via TCL_MODULE_PATH makefile variable. * macosx/Makefile: add platform standard locations to default module path roots. [Patch 942881] * tests/env.test: macosx fixes. | | | | | | 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 | * unix/Makefile.in: added customization of default module path roots via TCL_MODULE_PATH makefile variable. * macosx/Makefile: add platform standard locations to default module path roots. [Patch 942881] * tests/env.test: macosx fixes. 2004-08-25 Don Porter <[email protected]> * tests/timer.test (timer-10.1): Test for Bug 1016167. * generic/tclTimer.c: Workaround for situation when a [namespace import] causes the objv[0] value to be something other than what Tcl_AfterObjCmd expects. [Bug 1016167]. 2004-08-25 Donal K. Fellows <[email protected]> * generic/tclNamesp.c (NsEnsembleImplementationCmd): Use the ensemble command token to get the name of the ensemble for passing to the -unknown handler instead of relying on objv[0], which may contain useless info in the presence of [namespace import]. Problem found by Don Porter when investigating [Bug 1016167]. 2004-08-24 Don Porter <[email protected]> * generic/tclProc.c: The routine TclProcInterpProc was a * generic/tclTestProcBodyObj.c: specific instance of the general service already provided by TclObjInvokeProc. Removed TclProcInterpProc and TclGetInterpProc from the code... * generic/tclInt.decls ...and from the internal stubs table. * generic/tclIntDecls.h * generic/tclStubInit.c 2004-08-24 Donal K. Fellows <[email protected]> * doc/string.n: Added clarifying note. 2004-08-23 Don Porter <[email protected]> * library/auto.tcl: Updated [tcl_findLibrary] search path to include any [<pkg>::pkgconfig get scriptdir,runtime] directory, as well as the $::auto_path. [RFE 695441] 2004-08-21 Kevin B. Kenny <[email protected]> * tests/clock.test (clock-38.1): Changed TZ setting to specify CET in excruciating detail to deal with systems that lack the Posix defaults for DST changes (and to be formally correct with the change dates for CET). 2004-08-19 Donal K. Fellows <[email protected]> * generic/tclScan.c (Tcl_ScanObjCmd, ValidateFormat): Ensure that the %ld conversion works correctly on 64-bit platforms. [Bug 1011860] 2004-08-19 Kevin Kenny <[email protected]> * library/clock.tcl (format): Changed default timezone format from alphabetic to numeric to produce scannable times in more locales. * tests/clock.test (clock-37.1): Removed now-unused 'needPST' constraint and the comments that refer to it. |
︙ | ︙ | |||
1896 1897 1898 1899 1900 1901 1902 | * doc/tm.n: New file, documentation for Tcl Modules, based on the TIP. * unix/mkLinks: Regenerated. * win/makefile.vc: Added tm.tcl to list of files to install. | | | 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 | * doc/tm.n: New file, documentation for Tcl Modules, based on the TIP. * unix/mkLinks: Regenerated. * win/makefile.vc: Added tm.tcl to list of files to install. 2004-08-18 Kevin Kenny <[email protected]> * tests/httpd (httpdRespond): Corrected an abuse of the [clock] command that caused test failures for some values of [clock clicks]. * doc/clock.n * generic/tclBasic.c (Tcl_CreateInterp, Tcl_HideUnsafeCommands): * generic/tclClock.c (all): |
︙ | ︙ | |||
1960 1961 1962 1963 1964 1965 1966 | * doc/SetVar.3: * generic/tclTest.c (TestseterrorcodeCmd): * generic/tclVar.c (TclPtrSetVar): * tests/result.test (result-4.*, result-5.*): [Bug 1008314] detected and fixed by dgp. | | | | | | | | | | | | | | | | | | | | | | | 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 | * doc/SetVar.3: * generic/tclTest.c (TestseterrorcodeCmd): * generic/tclVar.c (TclPtrSetVar): * tests/result.test (result-4.*, result-5.*): [Bug 1008314] detected and fixed by dgp. 2004-08-13 Don Porter <[email protected]> * library/msgcat/msgcat.tcl: Added checks to prevent [mclocale] * tests/msgcat.test: from registering filesystem paths to possibly malicious code to be evaluated by a later [mcload]. 2004-08-10 Zoran Vasiljevic <[email protected]> * unix/tclUnixThrd.c (TclpThreadCreate): changed handling of the returned thread ID since broken on 64-bit systems (Cray). Thanks to Rob Ratcliff for reporting the bug. 2004-08-03 Donal K. Fellows <[email protected]> * generic/tclNamesp.c (MakeCachedEnsembleCommand): Initialize the epoch field cached in the subcommand. [Bug 989298] (NsEnsembleImplementationCmd): Plug a leak (thanks to Miguel Sofer for spotting it with valgrind) and reduce the number of goto labels to make the code clearer. 2004-08-02 Don Porter <[email protected]> * library/package.tcl (pkg_mkIndex): Updated [pkg_mkIndex] to make use of [glob -directory $dir -tails] and return options. TIP#207 IMPLEMENTATION * doc/interp.n: Added support for a -namespace option to the * generic/tclBasic.c: [interp invokehidden] command. Also added an * generic/tclInt.h: internal routine TclObjInvokeNamespace() and * generic/tclInterp.c: corrected the flag names TCL_FIND_ONLY_NS and * generic/tclNamesp.c: TCL_CREATE_NS_IF_UNKNOWN that are passed to the * generic/tclTrace.c: internal routine TclGetNamespaceForQualName(). * tests/interp.test: [Patch 981841] * generic/tclLiteral.c (TclCleanupLiteralTable): Corrected * tests/compile.test (compile-12.4): flawed deletion of literal internal reps that could lead to accessing of freed memory. Thanks to Kevin Kenny for test case and fix [Bug 1001997]. 2004-07-30 Don Porter <[email protected]> * tests/safe.test (safe-2.1): Disabled senseless test. [Bug 999612] * library/auto.tcl (auto_reset): Removed "protected" list of commands from [auto_reset]. All entries in the auto_index can be re-loaded. * library/package.tcl: Updated comment to reflect 2004-07-28 commit. * generic/tclEvent.c (Tcl_Finalize): Re-organized Tcl_Finalize so that Tcl_ExitProc's that call Tcl_Finalize recursively do not cause deadlock. [Patch 999084 fixes Tk Bug 714956] 2004-07-30 Daniel Steffen <[email protected]> * unix/configure: * unix/tcl.m4 (SC_CONFIG_CFLAGS): Darwin: instead of setting PLAT_OBJS to explict object files in tcl.m4, refer to MAC_OSX_OBJS makefile var. * unix/Makefile.in: added MAC_OSX_OBJS variable. 2004-07-29 Don Porter <[email protected]> * library/package.tcl: [::pkg::create] is now an alias. Test safe-2.1 will now fail until Bug 999612 is corrected. 2004-07-28 Don Porter <[email protected]> * library/package.tcl: Moved private command * library/tclIndex: [pkg_compareExtension] into ::tcl::Pkg. * tests/pkg_mkIndex.test: Also moved implementation of [::pkg::create] to [::tcl::Pkg::Create]. 2004-07-25 Pat Thoyts <[email protected]> * tests/io.test: Make io-61.1 create file as binary to pass on Win32 2004-07-23 Miguel Sofer <[email protected]> * generic/tclVar.c: simplify tclLocalVarNameType, removing the reference to the corresponding proc. The reference is now seen as unnecessary, and it may cause leaking circular references under some circumstances (see for example [Bug 994838]). 2004-07-22 Don Porter <[email protected]> * tests/eofchar.data (removed): Test io-61.1 now generates its own * tests/io.test: file of test data as needed. 2004-07-20 Jeff Hobbs <[email protected]> * generic/tclEvent.c: Correct threaded obj allocator to * generic/tclInt.h: fully cleanup on exit and allow for * generic/tclThreadAlloc.c: reinitialization. [Bug #736426] * unix/tclUnixThrd.c: (mistachkin, kenny) * win/tclWinThrd.c: 2004-07-21 Kevin Kenny <[email protected]> * generic/tclBasic.c (DeleteInterpProc): * generic/tclLiteral.c (TclCleanupLiteralTable): * generic/tclInt.h: added a TclCleanupLiteralTable function, called from DeleteInterpProc, that frees internal representations of shared literals early when an interpreter is being deleted. This change corrects a number of memory mismanagement issues in the cases where the internal representation of one literal contains a reference to another, and avoids conditions such as resolved variable names referring to procedure and namespace contexts that no longer exist. [Bug 994838] 2004-07-20 Daniel Steffen <[email protected]> * unix/Makefile.in: * win/Makefile.in: added 'install-private-headers' makefile target to allow optionally installing private tcl headers. [FR 922727] * macosx/Makefile: use new 'install-private-headers' target to install private headers into framework. [FR 922727] * unix/tclUnixFile.c (NativeMatchType): added support for readonly matching of user immutable files (where available). * macosx/tclMacOSXBundle.c: dynamically acquire address for CFBundleOpenBundleResourceMap symbol, since it is only present in full CoreFoundation on Mac OS X and not in CFLite on pure Darwin. 2004-07-19 Zoran Vasiljevic <[email protected]> * win/tclwinThrd.c: redefined MASTER_LOCK to call TclpMasterLock. Fixes Bug #987967 2004-07-17 Vince Darley <[email protected]> * generic/tclIOUtil.c: fix to rare 'cd' infinite loop in normalization with vfs [Bug 991420]. * tests/fileSystem.test: added test for above bug. * doc/FileSystem.3: clarified documentation of posix error codes in 'remove directory' FS proc - 'EEXIST' is used to signify a non-empty directory error (bug reported against tclvfs). 2004-07-16 Jeff Hobbs <[email protected]> * unix/Makefile.in, unix/tcl.m4: move (C|LD)FLAGS after their * unix/configure.in, unix/configure: _DEFAULT to allow for env setting to override m4 switches. Move SC_MISSING_POSIX_HEADERS up and consolidate calls to limit redundancy in configure. (CFLAGS_WARNING): Remove -Wconversion (SC_ENABLE_THREADS): Set m4 to force threaded build when built |
︙ | ︙ | |||
2146 2147 2148 2149 2150 2151 2152 | * unix/tclUnixThrd.c (TclpFinalizeMutex): Accepted Joe Mistachkin's patch for [Tcl SF Bug 990453], closing leakage of mutexes. They were not destroyed properly upon finalization. 2004-07-15 Andreas Kupries <[email protected]> | | | | 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 | * unix/tclUnixThrd.c (TclpFinalizeMutex): Accepted Joe Mistachkin's patch for [Tcl SF Bug 990453], closing leakage of mutexes. They were not destroyed properly upon finalization. 2004-07-15 Andreas Kupries <[email protected]> * generic/tclIO.h (CHANNEL_INCLOSE): New flag. Set in * generic/tclIO.c (Tcl_UnregisterChannel): 'Tcl_Close' while the * generic/tclIO.c (Tcl_Close): close callbacks are run. Checked in 'Tcl_Close' and 'Tcl_Unregister' to prevent recursive call of 'close' in the close-callbacks. This is a possible error made by implementors of virtual filesystems based on 'tclvfs', thinking that they have to close the channel in the close handler for the filesystem. 2004-07-14 Andreas Kupries <[email protected]> |
︙ | ︙ | |||
2181 2182 2183 2184 2185 2186 2187 | <[email protected]>. 2004-07-15 Zoran Vasiljevic <[email protected]> * generic/tclEvent.c (Tcl_Finalize): stuffed memory leak incurred by re-initializing of TSD slots after the last call to TclFinalizeThreadData (done from within Tcl_FinalizeThread()). | | | | | | 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 | <[email protected]>. 2004-07-15 Zoran Vasiljevic <[email protected]> * generic/tclEvent.c (Tcl_Finalize): stuffed memory leak incurred by re-initializing of TSD slots after the last call to TclFinalizeThreadData (done from within Tcl_FinalizeThread()). We basically just repeat the TclFinalizeThreadData() once more before tearing down TSD keys in TclFinalizeSynchronization(). There should be more elaborate mechanism in place for handling such issues, based on thread cleanup handlers registered on the OS level. Such change requires much more work and would also require TIP because some visible parts of Tcl API would have to be modified. In the meantime, this will do. * generic/tclNotify.c (TclFinalizeNotifier): Added conditional notifier finalization based on the fact that an TclInitNotifier has been called for the current thread. This fixes the Tcl Bug #770053 again. Hopefully this time w/o unwanted side-effects. 2004-07-15 Kevin Kenny <[email protected]> * generic/tclLiteral.c (TclReleaseLiteral): Removed unused variable 'codePtr' to silence a message from VC++. 2004-07-15 Miguel Sofer <[email protected]> * generic/tclCompile.c (TclCompileScript): * generic/tclLiteral.c (TclReleaseLiteral): fix for [Bug 467523], which resurfaced with the latest changes. The previous strategy was to have special code in TclReleaseLiteral to handle the self-references generated by empty scripts. The new approach avoids the self-reference altogether, by having empty scripts return an unshared literal. |
︙ | ︙ | |||
2233 2234 2235 2236 2237 2238 2239 | * generic/tclNamesp.c (BuildEnsembleConfig): Don't forget to clean out references when deleting the hash table. * generic/tclDictObj.c (Tcl_DictObjRemoveKeyList): Oops, forgot to delete value object when removing the hash entry. [Bug 989093 in part] 2004-07-11 Miguel Sofer <[email protected]> | | | | | | | | | | | | | | | | | | | | | 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 | * generic/tclNamesp.c (BuildEnsembleConfig): Don't forget to clean out references when deleting the hash table. * generic/tclDictObj.c (Tcl_DictObjRemoveKeyList): Oops, forgot to delete value object when removing the hash entry. [Bug 989093 in part] 2004-07-11 Miguel Sofer <[email protected]> * generic/tclExecute.c (TEBC): fixed leak of expandNestList objs when there is an error while an expansion is in progress (code added at checkForCatch). 2004-07-11 Vince Darley <[email protected]> * generic/tclIOUtil.c: fix to 'cd' bug when vfs is active [Bug 986944 in tclvfs project] - this bug recently introduced by some threading fixes. Need to work out how to add tests for this. 2004-07-10 Kevin Kenny <[email protected]> * tests/clock.test (clock-2.11): Changed the test so that it isn't an infinite loop when run under valgrind on a slow virtual machine. Thanks to Miguel Sofer for the bug report. Also put in code to restore env(LC_TIME) after tests complete, silencing a warning from 'make TESTFLAGS="-debug 1" test'. 2004-07-08 Miguel Sofer <[email protected]> * generic/tclBasic.c (DeleteInterpProc): reverted the modification of 3 days ago, as the leak of [Bug 983660] is now handled by the change in TclCleanupByteCode. * generic/tclCompile.c (TclCleanupByteCode): let each bytecode remove its references to literals at interp deletion, without updating the dying literal table. * generic/tclLiteral.c (TclDeleteLiteralTable): with the above change to TclCleanupByteCode, this function now removes a single reference to the literal object and cleans up its own structures. 2004-07-08 Kevin Kenny <[email protected]> * win/tclWinInit.c (AppendEnvironment): Silenced a compilation warning about a type mismatch. 2004-07-07 Miguel Sofer <[email protected]> * generic/tclCompile.c (TclCompileScript): fix for [Bug 458361]. Single-word scripts are compiled with an unshared cmdName to avoid shimmering between bytecode and cmdName reps. 2004-07-07 Don Porter <[email protected]> * generic/tclCmdMZ.c (TclMergeReturnOptions): Simplified logic and removed potential memory leak. [Bug 986257]. 2004-07-07 Donal K. Fellows <[email protected]> * tools/man2help2.tcl (setTabs, IPmacro): Added support for the more advanced *roff macros used in Tk's doc/bind.n * generic/tclObj.c (TclInitObjSubsystem): Declare all current object types. 2004-07-06 Don Porter <[email protected]> * tests/cmdMZ.test (cmdMZ-return-2.17): Added a test that a word containing backslash-quoted value is treated correctly. * generic/tclCompile.c (TclWordKnownAtCompileTime): [Bug 986196] Corrected flaw above and the flaw that caused TCL_TOKEN_SIMPLE_WORDs to have their original word value copied ( "{a b}" ) rather than the actual value ( "a b" ). Thanks to Kevin Kenny for report and tests. 2004-07-06 Kevin B. Kenny <[email protected]> * tests/cmdMZ.test (cmdMZ-return-2.15,cmdMZ-return-2.16): Added a test that a return code containing spaces is correctly returned. 2004-07-06 Donal K. Fellows <[email protected]> * tools/man2html2.tcl (IPmacro, setTabs): Added support for the more advanced *roff macros used in Tk's doc/bind.n 2004-07-05 Miguel Sofer <[email protected]> * generic/tclBasic.c (DeleteInterpProc): fix for [Bug 983660], found by pspjuth. Tear down the global namespace before freeing the interp handle, to allow the bytecodes to free their non-shared literals. * generic/tclLiteral.c (TclReleaseLiteral): moved special code for self-ref so that it is also used for non-shared literals. Possible bug found by inspection. 2004-07-03 Miguel Sofer <[email protected]> * generic/tclExecute.c (ExprRoundFunc): * tests/expr-old.test (39.1): added support for wide integers to round(); [Bug 908375], reported by Hemang Lavana. 2004-07-03 Miguel Sofer <[email protected]> * generic/tclCompile.h: * generic/tclInt.decls: * generic/tclIntDecls.h: * generic/tclStubInit.c: Moved declaration of TclCompEvalObj() from tclCompile.h to the internal stubs table, for compiler experimentation. 2004-07-02 Jeff Hobbs <[email protected]> * generic/regcomp.c (stid): correct minor pointer size error * generic/tclPipe.c (TclCreatePipeline): applied TIP #202 patch * doc/exec.n, tests/exec.test: that adds 2>@1 as a special case redirection of stderr to the result output. 2004-07-02 Kevin B. Kenny <[email protected]> * tests/io.test: Changed several tests to run the event loop rather than just calling [update] periodically, avoiding intermittent failures (usually in io-29.32) that stemmed from unreaped processes on Windows. * tests/winPipe.test (winpipe-1.11): Fixed a bug that caused test to fail if the path name of the working directory contained whitespace [Bug 678430] 2004-07-01 Vince Darley <[email protected]> * tests/fileSystem.test: Added test for [Bug 970529] 2004-07-01 Donal K. Fellows <[email protected]> * win/README.binary, win/README: Updated references to Tcl and Tk 8.4 to point to 8.5 instead. Thanks to Theo Verelst for spotting this. * generic/tcl.h: Added note to help prevent those changes from getting missed in the future. * doc/Namespace.3, doc/load.n, doc/Limit.3: Typo fixes and remove duplicate documentation. [Bug 983146] 2004-06-30 Don Porter <[email protected]> * tests/fileSystem.test: Minor correction to new fileSystem-9.X tests so that they clean up temporary directories correctly. 2004-06-30 Vince Darley <[email protected]> * doc/filename.n: clarified behaviour concerning trailing slashes in filenames [Bug 971976] * win/tclWinFile.c: * tests/fileSystem.test: fix and tests for [Bug 979879] 2004-06-30 Donal K. Fellows <[email protected]> TIP#188 IMPLEMENTATION * doc/string.n, tests/string.test: Add 'wideinteger' to things * generic/tclCmdMZ.c (Tcl_StringObjCmd): that can be tested for with the [string is] subcommand. [Patch 940915, by Kevin Kenny] 2004-06-29 Don Porter <[email protected]> * win/tclWinInit.c: Corrected reference counting flaw in recent changes. Thanks to Pat Thoyts. [Bug 981893]. 2004-06-29 Vince Darley <[email protected]> * win/tclWin32Dll.c: fix to compilation with VC++ 5.2 2004-06-29 Donal K. Fellows <[email protected]> * library/safe.tcl: Make sure that the temporary variable is local to the namespace and not inadvertently global. [Bug 981733] 2004-06-24 Donal K. Fellows <[email protected]> * tests/unixNotfy.test: Modified constraints so that testing with a threaded tclsh (not tcltest) will not hang. 2004-06-23 Don Porter <[email protected]> * generic/tclThreadStorage.c: Corrected type casting errors that led to calculation of a negative index value, thus accesses outside the threadStorageCache array, thus memory corruption. Crash observed on Mac OS X platform. 2004-06-23 Joe Mistachkin <[email protected]> |
︙ | ︙ | |||
2434 2435 2436 2437 2438 2439 2440 | * unix/tcl.m4: * win/makefile.vc: * win/rules.vc: * win/Makefile.in: Modified the unix, VC++, and Cygwin build systems * win/configure: to include the new "tclThreadStorage.c" and the new * win/tcl.m4: USE_THREAD_STORAGE define. | | | 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 | * unix/tcl.m4: * win/makefile.vc: * win/rules.vc: * win/Makefile.in: Modified the unix, VC++, and Cygwin build systems * win/configure: to include the new "tclThreadStorage.c" and the new * win/tcl.m4: USE_THREAD_STORAGE define. 2004-06-23 Pat Thoyts <[email protected]> * tests/io.test: Added -force to 18.1 and 18.2. This was failing on WinXP. * tests/winFCmd.test: Added a cleanup to winFCmd-16.11 to avoid a failure in 16.12. |
︙ | ︙ | |||
2460 2461 2462 2463 2464 2465 2466 | winDde-4.2, -6.5, and -6.6 appear to be much less frequent. [Bug #957449] 2004-06-23 Donal K. Fellows <[email protected]> * tests/*.test: Standardize use of platform constraints. | | | | 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 | winDde-4.2, -6.5, and -6.6 appear to be much less frequent. [Bug #957449] 2004-06-23 Donal K. Fellows <[email protected]> * tests/*.test: Standardize use of platform constraints. * unix/tclUnixInit.c (GetStackSize, TclpCheckStackSpace): * unix/tclUnixThrd.c (TclpThreadGetStackSize): Added code to check whether the C stack is about to be exceeded, from [Patch 746378] by Joe Mistachkin but with substantial revisions. 2004-06-22 Kevin Kenny <[email protected]> * generic/tclEvent.c (NewThreadProc): Fixed broken build on Windows caused by missing TCL_THREAD_CREATE_RETURN. * tests/stack.test (stack-3.1): Corrected nuisance error in threaded builds. |
︙ | ︙ | |||
2510 2511 2512 2513 2514 2515 2516 | 2004-06-21 Donal K. Fellows <[email protected]> * generic/tclThreadAlloc.c (Ptr2Block): Rewrote so as to maximize the chance of detecting and reporting a memory inconsistency without relying on things being consistent. [Bug 975895] | | | 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 | 2004-06-21 Donal K. Fellows <[email protected]> * generic/tclThreadAlloc.c (Ptr2Block): Rewrote so as to maximize the chance of detecting and reporting a memory inconsistency without relying on things being consistent. [Bug 975895] 2004-06-18 Don Porter <[email protected]> * tests/load.test: Relaxed strictness of error message matching for test load-2.3 so that it will pass on Mac OSX. * generic/tclEncoding.c: Static TclFindEncodings -> FindEncodings. * generic/tclInt.h: Updated TclpFindExecutable() so that failed * generic/tclUtil.c: attempts to find the executable are saved |
︙ | ︙ | |||
2537 2538 2539 2540 2541 2542 2543 | * unix/configure: autoconf-2.57 2004-06-18 Donal K. Fellows <[email protected]> * unix/tclUnixInit.c (localeTable): Added some more locale to encoding mapping info from Jim Huang <[email protected]> | | | | | | | | | | 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 | * unix/configure: autoconf-2.57 2004-06-18 Donal K. Fellows <[email protected]> * unix/tclUnixInit.c (localeTable): Added some more locale to encoding mapping info from Jim Huang <[email protected]> * generic/tclInt.h (PendingObjData,TclFreeObjMacro,etc): * generic/tclObj.c (TclFreeObj): Added scheme for making TclFreeObj() avoid blowing up the C stack when freeing up very large object trees. [Bug 886231] * win/tclWinInit.c (SetDefaultLibraryDir): Fix logic, simplify and add comments. 2004-06-17 Don Porter <[email protected]> * generic/tclObj.c: Added missing space in panic message. * win/tclWinInit.c: Inform [tclInit] about the default library directory via the ::tclDefaultLibrary variable. This should correct a problem with my 2004-06-11 commit. Better solutions still in the works. Thanks to Joe Mistachkin for pointing out the breakage. 2004-06-16 Don Porter <[email protected]> * doc/library.n: Moved variables ::auto_oldpath and * library/auto.tcl: ::unknown_pending into ::tcl namespace. * library/init.tcl: [Bugs 808319, 948794] 2004-06-15 Donal K. Fellows <[email protected]> * doc/binary.n: Added some notes to the documentation of the 'a' format to address the point raised in [RFE 768852]. 2004-06-15 Jeff Hobbs <[email protected]> * unix/tclConfig.sh.in (TCL_EXTRA_CFLAGS): set to @CFLAGS@, which is the configure-time CFLAGS. Addendum to m4 change on 2004-05-26. 2004-06-14 Kevin Kenny <[email protected]> * win/Makefile.in: Corrected compilation flags for tclPkgConfig.c so that it doesn't require Stubs. * generic/tclBasic.c (Tcl_CreateInterp): Removed comment stating that TclInitEmbeddedConfigurationInformation needs Stubs; with the change above, the comment is now erroneous. 2004-06-11 Don Porter <[email protected]> * doc/Encoding.3: Removed bogus claims about tcl_libPath. * generic/tclInterp.c (Tcl_Init): Stopped setting the tcl_libPath variable. [tclInit] can get all its directories without it. |
︙ | ︙ | |||
2618 2619 2620 2621 2622 2623 2624 | * win/configure.in: * generic/tclBasic.c (Tcl_CreateInterp): Moved call to TclInitEmbeddedConfigurationInformation() earlier in Tcl_CreateInterp() so that other parts of interp creation and initialization may access and use the config values. | | | | | | | | | | 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 | * win/configure.in: * generic/tclBasic.c (Tcl_CreateInterp): Moved call to TclInitEmbeddedConfigurationInformation() earlier in Tcl_CreateInterp() so that other parts of interp creation and initialization may access and use the config values. 2004-06-11 Kevin Kenny <[email protected]> * win/tclAppInit.c: Restored the 'setargv' procedure when compiling with mingw. Apparently, the command line parsing in mingw doesn't work as well as that in vc++, and the result was (1) that winPipe-8.19 failed, and (2) that 'make test' would work at all only with TESTFLAGS='-singleproc 1'. [Bug 967195] 2004-06-10 Zoran Vasiljevic <[email protected]> * generic/tclIOUtil.c: removed forceful setting of the private cached current working directory rep from within the Tcl_FSChdir(). We delegate this task to the Tcl_FSGetCwd() which does this task anyway. The relevant code is still present but disabled temporarily until the change proves correct. The Tcl test suite passes all test with the given change so I suppose it is good enough. 2004-06-10 Don Porter <[email protected]> * unix/tclUnixInit.c (TclpInitLibraryPath): Disabled addition of * win/tclWinInit.c (TclpInitLibraryPath): relative-to-executable directories to the library search path. A first step in reform of Tcl's startup process. ***POTENTIAL INCOMPATIBILITY*** Attempts to directly run ./tclsh or ./tcltest out of a build directory will either fail, or will make use of an installed script library in preference to the one in the source tree. Use `make shell` or `make runtest` instead. * tests/unixInit.test: Modified tests to suit above changes. * generic/tclPathObj.c: Corrected [file tail] results when operating on a path produced by TclNewFSPathObj(). [Bug 970529] 2004-06-09 Zoran Vasiljevic <[email protected]> * generic/tclIOUtil.c: partially corrected [Bug 932314]. Also, corrected return values of Tcl_FSChdir() to reflect those of the underlying platform-specific call. Originally, return codes were mixed with those of Tcl. 2004-06-08 Miguel Sofer <[email protected]> * generic/tclCompile.c: * generic/tclExecute.c: handle warning [Bug 969066] 2004-06-08 Donal K. Fellows <[email protected]> * generic/tclHash.c (RebuildTable): Move declaration of variable so it is only declared when it is used. [Bug 969068] |
︙ | ︙ | |||
2688 2689 2690 2691 2692 2693 2694 | * generic/tclInt.decls: clock frequency in * generic/tclIntDecls.h: Tcl_WinTime * generic/tclIntPlatDecls.h: so that any clock frequency * generic/tclPlatDecls.h: is accepted provided that * generic/tclStubInit.c: all CPU's in the system share * tests/platform.test (platform-1.3): a common chip, and hence, * win/tclWin32Dll.c (TclWinCPUID): presumably, a common clock. | | | | | | | | | 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 | * generic/tclInt.decls: clock frequency in * generic/tclIntDecls.h: Tcl_WinTime * generic/tclIntPlatDecls.h: so that any clock frequency * generic/tclPlatDecls.h: is accepted provided that * generic/tclStubInit.c: all CPU's in the system share * tests/platform.test (platform-1.3): a common chip, and hence, * win/tclWin32Dll.c (TclWinCPUID): presumably, a common clock. * win/tclWinTest.c (TestwincpuidCmd) This change necessitated a * win/tclWinTime.c (Tcl_GetTime): small burst of assembly code to read CPU ID information, which was added as TclWinCPUID in the internal Stubs. To test this code in the common case of a single-processor machine, a 'testwincpuid' command was added to tclWinTest.c, and a test case in platform.test. Thanks to Jeff Godfrey and Richard Suchenwirth for reporting this bug. [Bug #976722] 2004-06-04 Don Porter <[email protected]> * generic/tcl.h: Restored #include <stdio.h> to tcl.h, rejecting the "fix" for "Bug" 945570. Tcl_FSSeek() needs the values of SEEK_SET, etc. and too many extensions rely on tcl.h providing stdio.h for them. 2004-06-02 Jeff Hobbs <[email protected]> * win/tclWinFile.c (TclpFindExecutable): when using GetModuleFileNameA (Win9x), convert from CP_ACP to WCHAR then convert back to utf8. Adjunct to 2004-04-07 fix. 2004-06-02 David Gravereaux <[email protected]> * tests/winPipe.test (winpipe-6.1): blocking set to 1 before closing to ensure we get an exitcode. The windows pipe channel driver doesn't differentiate between a blocking and non-blocking close just yet, but will soon. Part of [Bug 947693] 2004-06-02 Vince Darley <[email protected]> * doc/file.n: fix to documentation of 'file volumes' (Bug 962435) 2004-06-01 David Gravereaux <[email protected]> |
︙ | ︙ | |||
2753 2754 2755 2756 2757 2758 2759 | each function in the limit implementation and rewrote the names of some non-public functions for greater clarity of purpose. * doc/interp.n: Added note about what happens when a limited interpreter creates a slave interpreter. * doc/Limit.3: Added manual page for the resource limit subsystem's C API. [Bug 953903] | | | 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 | each function in the limit implementation and rewrote the names of some non-public functions for greater clarity of purpose. * doc/interp.n: Added note about what happens when a limited interpreter creates a slave interpreter. * doc/Limit.3: Added manual page for the resource limit subsystem's C API. [Bug 953903] 2004-05-29 Joe English <[email protected]> * doc/global.n, doc/interp.n, doc/lrange.n: Fix minor markup errors. 2004-05-28 Donal K. Fellows <[email protected]> * doc/*.n: Added examples to many (too many to list) more man pages. |
︙ | ︙ | |||
2796 2797 2798 2799 2800 2801 2802 | * generic/tclCmdMZ.c (Tcl_StringObjCmd): uses are performed. The overall effect is to make building with gcc with the additional flags -Wstrict-prototypes -Wmissing-prototypes produce no increase in the total number of warnings (except for main(), which is undeclared for traditional reasons.) | | | | | | | | | | | | | | 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 | * generic/tclCmdMZ.c (Tcl_StringObjCmd): uses are performed. The overall effect is to make building with gcc with the additional flags -Wstrict-prototypes -Wmissing-prototypes produce no increase in the total number of warnings (except for main(), which is undeclared for traditional reasons.) 2004-05-26 Jeff Hobbs <[email protected]> * unix/Makefile.in: Rework configure ordering to TCL_LINK_LIBS, * unix/tcl.m4: ENABLE_SHARED, CONFIG_CFLAGS, & ENABLE_SYMBOLS * unix/configure: before TCL_EARLY_FLAGS and TCL_64BIT_FLAGS * unix/configure.in: (about 400 lines earlier) in configure.in. This forces CFLAGS configuration to be done before many tests, which is needed for 64-bit builds and may affect other builds. Also make CONFIG_CFLAGS append to CFLAGS directly instead of using EXTRA_CFLAGS, and have LDFLAGS append to any existing value. [Bug #874058] * unix/dltest/Makefile.in: change EXTRA_CFLAGS to DEFS 2004-05-26 Don Porter <[email protected]> * library/tcltest/tcltest.tcl: Correction to debug prints and testing * library/tcltest/pkgIndex.tcl: if TCLTEST_OPTIONS value. Corrected * tests/tcltest.test: double increment of numTestFiles in -singleproc 1 configurations. Updated tcltest-19.1 to tcltest 2.1 behavior. Corrected tcltest-25.3 to not falsely report a failure in tcltest.test. Bumped to tcltest 2.2.6. [Bugs 960560, 960926] 2004-05-25 Jeff Hobbs <[email protected]> * doc/http.n (http::config): add -urlencoding option (default utf-8) * library/http/http.tcl: that specifies encoding conversion of * library/http/pkgIndex.tcl: args for http::formatQuery. Previously * tests/http.test: undefined, RFC 2718 says it should be utf-8. 'http::config -urlencoding {}' returns previous behavior, which will throw errors processing non-latin-1 chars. Bumped http package to 2.5.0. 2004-05-25 Donal K. Fellows <[email protected]> * generic/tclInterp.c (DeleteScriptLimitCallback): Move all deletion of script callback hash table entries to happen here so the entries are correctly removed at the right time. [Bug 960410] 2004-05-25 Miguel Sofer <[email protected]> * docs/global.n: added details for qualified variable names [Bug 959831] 2004-05-25 Miguel Sofer <[email protected]> * generic/tclNamesp.c (Tcl_FindNamespaceVar): * tests/namespace.test (namespace-17.10-12): reverted commit of 2004-05-23 and removed the tests, as it interferes with the varname resolver and there are apps that break (AlphaTk). A fix will have to wait for Tcl9. * generic/tclVar.c: Caching of namespace variables disabled: no simple way was found to avoid interfering with the resolver's idea of variable existence. A cached varName may keep a variable's name in the namespace's hash table, which is the resolver's criterion for existence. * tests/namespace.c (namespace-17.10): testing for interference between varname caching and name resolver. 2004-05-25 Kevin Kenny <[email protected]> * tests/winFCmd.test: Correct test for the presence of a CD-ROM so that it doesn't misdetect some other sort of filesystem with a write-protected root as being a CD-ROM drive. [Bug 918267] 2004-05-25 Don Porter <[email protected]> * tests/winPipe.test: Protect against path being set * tests/unixInit.test: Unset path when done. * tests/unload.test (unload-3.1): Verify [pkgb_sub] does not exist. Delete interps when done. * tests/stringComp.test: stop re-use of string.test test names * tests/regexpComp.test: stop re-use of regexp.test test names * tests/namespace.test (namespace-46.3): Verify [p] does not exist. * tests/http.test: Clear away the custom [bgerror] when done. |
︙ | ︙ | |||
2893 2894 2895 2896 2897 2898 2899 | * generic/tcl.h: comments. [Bug 848440, second part] * tests/fCmd.test: Rewrote tests that failed consistently on NFS so they either succeed (through slightly more liberal matching of the results) or are constrained to not run. [Bug 931312] * doc/bgerror.n: Use idiomatic open flags for working with log | | | | | | | | | | | | 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 | * generic/tcl.h: comments. [Bug 848440, second part] * tests/fCmd.test: Rewrote tests that failed consistently on NFS so they either succeed (through slightly more liberal matching of the results) or are constrained to not run. [Bug 931312] * doc/bgerror.n: Use idiomatic open flags for working with log files. [Bug 959602] 2004-05-24 Jeff Hobbs <[email protected]> * generic/tclExecute.c (VerifyExprObjType): use GET_WIDE_OR_INT to properly have tclIntType used for smaller values. This corrects TclX bug 896727 and any other 3rd party extension that created math functions but was not yet WIDE_INT aware in them. 2004-05-24 Donal K. Fellows <[email protected]> * generic/tclInterp.c (TclInitLimitSupport): Made limits work on platforms where sizeof(void*)!=sizeof(int). [Bug 959193] 2004-05-24 Miguel Sofer <[email protected]> * doc/set.n: accurate description of name resolution process, referring to namespace.n for details [Bug 959180] 2004-05-23 Miguel Sofer <[email protected]> * generic/tclNamesp.c (Tcl_FindNamespaceVar): [Bug 959052] fixed, insuring that no "zombie" variables are found. * generic/tclVar.c (TclLookupSimpleVar): comments re [Bug 736729] (predecessor of [Bug 959052]) removed. * tests/namespace.test: added tests 17.10-12 The patch modifies non-documented behaviour, and passes every test in the testsuite. However, scripts relying on the old behaviour may break. Note that the only behaviour change concerns the creative writing of unset variables. More precisely, which variable will be created when neither a namespace variable nor a global variable by that name exists, as defined by [info vars]. The new behaviour is that the namespace resolution process deems a variable to exist exactly when [info vars] finds it - ie, either it has value, or else it was "fixed" by a call to [variable]. Note: this patch was removed on 2002-05-25. 2004-05-22 Miguel Sofer <[email protected]> * generic/tclVar.c (TclObjLookupVar, TclObjUnsetVar2): fix for new (in tcl8.4) exteriorisations of [Bug 736729] due to the use of tclNsVarNameType obj types. Reenabling the use of this objType ("VAR ref absolute" benchmark down to 66 ms, from 230). Added comments in TclLookupSimpleVar explaining my current understanding of [Bug 736729]. 2004-05-22 Miguel Sofer <[email protected]> * generic/tclVar.c: fix for [Bug 735335]. The use of tclNsVarNameType objs is still disabled, pending resolution of [Bug 736729]. 2004-05-21 Miguel Sofer <[email protected]> * tests/namespace.test (namespace-41.3): removed the {knownBug} constraint: [Bug 231259] is closed since nov 2001, and the fix of [Bug 729692] (INST_START_CMD) makes the test succeed. 2004-05-21 Donal K. Fellows <[email protected]> * generic/tclExecute.c (TclExecuteByteCode): Move a few declarations a short distance so pre-C99 compilers can cope. Also fix so TCL_COMPILE_DEBUG path compiles... 2004-05-21 Miguel Sofer <[email protected]> * generic/tclExecute.c (TclExecuteByteCode): reorganised TEBC automatic variables, defining them in tight blocks instead of at the function level. This has three purposes: - it simplifies the analysis of individual instructions - it is preliminary work to the non-recursive engine - it allows a better register allocation by the optimiser; under gcc3.3, this results in up to 10% runtime in some tests 2004-05-20 Donal K. Fellows <[email protected]> * generic/tclInterp.c (TclLimitRemoveAllHandlers): * generic/tclBasic.c (DeleteInterpProc): * tests/interp.test (interp-34.7): Ensure that all limit callbacks are deleted when their interpreters are deleted. [Bug 956083] 2004-05-19 Kevin B. Kenny <[email protected]> * win/tclWinFile.c (TclpMatchInDirectory): fix for an issue where there was a sneak path from Tcl_DStringFree to |
︙ | ︙ | |||
2999 3000 3001 3002 3003 3004 3005 | * generic/tclInterp.c (Tcl_LimitCheck): Fix the sense of checks to see whether a time limit has been extended. * tests/*.test: Many minor fixes, including ensuring that every test is run (so constraints control whether the test is doing anything) and making sure that constraints are always set using the API instead of poking around inside tcltest's internal | | | | | | | | | | | | | 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 | * generic/tclInterp.c (Tcl_LimitCheck): Fix the sense of checks to see whether a time limit has been extended. * tests/*.test: Many minor fixes, including ensuring that every test is run (so constraints control whether the test is doing anything) and making sure that constraints are always set using the API instead of poking around inside tcltest's internal datastructures. Also got rid of all trailing whitespace lines from the test suite! 2004-05-19 Andreas Kupries <[email protected]> * generic/tclIO.c: Fixed [SF Tcl Bug 943274]. This is the same problem * generic/tclIO.h: as [SF Tcl Bug 462317], see ChangeLog entry 2001-09-26. The fix done at that time is incomplete. It is possible to get around it if the actual read operation is defered and not executed in the event handler itself. Instead of tracking if we are in an read caused by a synthesized fileevent we now track if the OS has delivered a true event = actual data and bypass the driver if a read finds that there is no actual data waiting. The flag is cleared by a short or full read. ***POTENTIAL INCOMPATIBILITY*** for channel drivers. 2004-05-17 Vince Darley <[email protected]> * generic/tclPathObj.c: fix to (Bug 956063) in 'file dirname'. * tests/cmdAH.test: added test for this bug. * doc/FileSystem.3: better documentation of refCount requirements of some FS functions (Bug 956126) 2004-05-19 Donal K. Fellows <[email protected]> * generic/tclTest.c (TestgetintCmd): Made the tests in get.test check * tests/get.test: Tcl_GetInt() since the core now avoids that function. |
︙ | ︙ | |||
3122 3123 3124 3125 3126 3127 3128 | * generic/tclCompile.c: * generic/tclExecute.c: changed implementation of {expand}, last chance while in alpha as ... ***POTENTIAL INCOMPATIBILITY*** Scripts precompiled with ProComp under previous tcl8.5a versions may malfunction due to changed instruction numbers for | | | | | | | | | | 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 | * generic/tclCompile.c: * generic/tclExecute.c: changed implementation of {expand}, last chance while in alpha as ... ***POTENTIAL INCOMPATIBILITY*** Scripts precompiled with ProComp under previous tcl8.5a versions may malfunction due to changed instruction numbers for INST_LIST_INDEX_IMM, INST_LIST_RANGE_IMM and INST_START_CMD. 2004-05-14 Kevin B. Kenny <[email protected]> * generic/tclInt.decls: Promoted TclpLocaltime and TclpGmtime * generic/tclIntDecls.h: from Unix-specific stubs to the generic * generic/tclIntPlatDecls.h: internal Stubs table. Reran 'genstubs' * generic/tclStubInit.c: * unix/tclUnixPort.h: * generic/tclClock.c: Changed a buggy 'GMT' timezone specification to the correct 'GMT0'. [Bug #922848] * unix/tclUnixThrd.c: Moved TclpGmtime and TclpLocaltime to unix/tclUnixTime.c where they belong. * unix/tclUnixTime.c (TclpGmtime, TclpLocaltime, TclpGetTimeZone, ThreadSafeGMTime [removed], ThreadSafeLocalTime [removed], SetTZIfNecessary, CleanupMemory): Restructured to make sure that the same mutex protects all calls to localtime, gmtime, and tzset. Added a check in front of those calls to make sure that the TZ env var hasn't changed since the last call to tzset, and repeat tzset if necessary. [Bug #942078] Removed a buggy test of the Daylight Saving Time information in 'gettimeofday' in favor of applying 'localtime' to a known value. [Bug #922848] |
︙ | ︙ | |||
3169 3170 3171 3172 3173 3174 3175 | (eePtr). First step towards a change in the execution stack management - it is now only used within TEBC. 2004-05-13 Donal K. Fellows <[email protected]> TIP#143 IMPLEMENTATION | | | | 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 | (eePtr). First step towards a change in the execution stack management - it is now only used within TEBC. 2004-05-13 Donal K. Fellows <[email protected]> TIP#143 IMPLEMENTATION * generic/tclExecute.c (TclCompEvalObj, TclExecuteByteCode): * generic/tclBasic.c (TclEvalObjvInternal): Enable limit checking. * generic/tclInterp.c (Tcl_Limit*): Public limit API. * generic/tcl.decls: * tests/interp.test: Basic tests of command limits. * doc/binary.n: TIP#129 IMPLEMENTATION [Patch 858211] * generic/tclBinary.c: Note that the test suite probably has many more * tests/binary.test: failures now due to alterations in constraints. 2004-05-12 Miguel Sofer <[email protected]> |
︙ | ︙ | |||
3195 3196 3197 3198 3199 3200 3201 | 2004-05-11 Donal K. Fellows <[email protected]> * doc/split.n, doc/join.n: Updated examples and added more. 2004-05-11 Vince Darley <[email protected]> | | | 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 | 2004-05-11 Donal K. Fellows <[email protected]> * doc/split.n, doc/join.n: Updated examples and added more. 2004-05-11 Vince Darley <[email protected]> * doc/glob.n: documented behaviour of symbolic links with 'glob -types d' (Bug 951489) 2004-05-11 Donal K. Fellows <[email protected]> * doc/scan.n: Updated the examples to be clearer about their relevance to the scan command. |
︙ | ︙ | |||
3220 3221 3222 3223 3224 3225 3226 | (TclpCreateProcess): When under NT, with no console, and executing a DOS application, the path priming does not need an ending space as BuildCommandLine() will do this for us. 2004-05-08 Vince Darley <[email protected]> | | | | | | | | | | | 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 | (TclpCreateProcess): When under NT, with no console, and executing a DOS application, the path priming does not need an ending space as BuildCommandLine() will do this for us. 2004-05-08 Vince Darley <[email protected]> * generic/tclFileName.c: * generic/tclIOUtil.c: remove some compiler warnings on MacOS X. 2004-05-07 Chengye Mao <[email protected]> * win/tclWinPipe.c: refixed bug 789040 re-entered in rev 1.41. Let's be careful and don't re-enter previously fixed bugs. 2004-05-08 Donal K. Fellows <[email protected]> * doc/format.n: Added examples. 2004-05-07 Miguel Sofer <[email protected]> * doc/unset.n: added upvar.n to the "see also" list 2004-05-07 Reinhard Max <[email protected]> * generic/tclEncoding.c: * tests/encoding.test: added support and tests for translating embedded null characters between real nullbytes and the internal representation on input/output (Bug #949905). 2004-05-07 Vince Darley <[email protected]> * generic/tclFileName.c: * generic/tclIOUtil.c: * generic/tclFileSystem.h: * tests/fileSystem.test: fix for [Bug 943995], in which vfs- registered root volumes were not handled correctly as glob patterns in all circumstances. 2004-05-06 Miguel Sofer <[email protected]> * generic/tclInt.h: * generic/tclObj.c (TclFreeObj): made TclFreeObj use the new macro TclFreeObjMacro(), so that the allocation and freeing of Tcl_Obj is defined in a single spot (the macros in tclInt.h), with the exception of the TCL_MEM_DEBUG case. The #ifdef logic for the corresponding macros has been reformulated to make it clearer. 2004-05-05 Donal K. Fellows <[email protected]> * doc/break.n, doc/continue.n, doc/for.n, doc/while.n: More examples. 2004-05-05 Don Porter <[email protected]> * tests/unixInit.test (unixInit-2.10): Test correction for Mac OSX. Be sure to consistently compare normalized path names. Thanks to Steven Abner (tauvan). [Bug 948177] 2004-05-05 Donal K. Fellows <[email protected]> * doc/CrtObjCmd.3: Remove reference to Tcl_RenameCommand; there is no such API. [Bug 848440] 2004-05-05 David Gravereaux <[email protected]> * win/tclWinSock.c (SocketEventProc) : connect errors should fire both the readable and writable handlers because this is how it works on UNIX [Bug 794839] * generic/tclEncoding.c (TclFinalizeEncodingSubsystem): FreeEncoding(systemEncoding); moved to before the hash table itereation as it was causing a double free attempt under some conditions. * win/coffbase.txt: Added the tls extension to the list of preferred load addresses. 2004-05-04 Jeff Hobbs <[email protected]> * tests/fileSystem.test (filesystem-1.39): replace 'file volumes' * tests/fileName.test (filename-12.9,10): lindex with direct C:/ hard-coded because A:/ was being used and that is empty for most. * tests/winFCmd.test (winFCmd-16.12): test volumerelative $HOME 2004-05-04 Don Porter <[email protected]> * generic/tclAlloc.c: Make sure Tclp*Alloc* routines get * generic/tclInt.h: declared in the TCL_MEM_DEBUG and * generic/tclThreadAlloc.c: TCL_THREADS configuration. [Bug 947564] * tests/tcltest.test: Test corrections for Mac OSX. Thanks to Steven Abner (tauvan). [Bug 947440] |
︙ | ︙ | |||
3334 3335 3336 3337 3338 3339 3340 | 2004-05-03 Miguel Sofer <[email protected]> * generic/tclCompile.c: * generic/tclInt.h: reverted fix for [Bug 926445] of 2004-04-02, restoring TCL_ALIGN to the header file. Todd Helfter reported that the macro is required by tbcload. | | | | | | | | | 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 | 2004-05-03 Miguel Sofer <[email protected]> * generic/tclCompile.c: * generic/tclInt.h: reverted fix for [Bug 926445] of 2004-04-02, restoring TCL_ALIGN to the header file. Todd Helfter reported that the macro is required by tbcload. 2004-05-03 Kevin Kenny <[email protected]> * win/tclWin32Dll.c (TclpCheckStackSpace): * tests/stack.test (stack-3.1): Fix for undetected stack overflow in TclReExec on Windows. [Bug 947070] 2004-05-03 Don Porter <[email protected]> * library/init.tcl: Corrected unique prefix matching of interactive command completion in [unknown]. [Bug 946952] 2004-05-02 Miguel Sofer <[email protected]> * generic/tclProc.c (TclObjInvokeProc): * tests/proc.test (proc-3.6): fix for bad quoting of multi-word proc names in error messages [Bug 942757] 2004-04-30 Donal K. Fellows <[email protected]> * doc/glob.n, doc/incr.n, doc/set.n: More examples. * doc/if.n, doc/rename.n, doc/time.n: 2004-04-30 Don Porter <[email protected]> * generic/tclInt.h: Replaced Kevin Kenny's temporary * generic/tclThreadAlloc.c: fix for Bug 945447 with a cleaner, more permanent replacement. 2004-04-30 Kevin B. Kenny <[email protected]> * generic/tclThreadAlloc.c: Added a temporary (or so I hope!) inclusion of "tclWinInt.h" to avoid problems when compiling on Win32-VC++ with --enable-threads. [Bug 945447] 2004-04-30 Donal K. Fellows <[email protected]> * doc/puts.n: Added a few examples. 2004-04-29 Don Porter <[email protected]> * tests/execute.test (execute-8.2): Avoid crashes when there is limited system stack space (threads-enabled). 2004-04-28 Miguel Sofer <[email protected]> * doc/global.n: * doc/upvar.n: * generic/tclVar.c (ObjMakeUpvar): * tests/upvar.test (upvar-8.11): * tests/var.test (var-3.11): Avoid creation of unusable variables: [Bug 600812] [TIP 184]. 2004-04-28 Donal K. Fellows <[email protected]> * doc/lsearch.n: Fixed fault in documentation of -index option [943448] 2004-04-26 Don Porter <[email protected]> * unix/tclUnixFCmd.c (TclpObjNormalizePath): Corrected improper positioning of returned checkpoint. [Bug 941108] 2004-04-26 Donal K. Fellows <[email protected]> * doc/open.n, doc/close.n: Updated (thanks to David Welton) to be clearer about pipeline errors and added example to open(n) that shows simple pipeline use. [Patches 941377,941380] * doc/DictObj.3: Added warning about the use of Tcl_DictObjDone and an example of use of iteration. [Bug 940843] * doc/Thread.3: Reworked to remove references to testing interfaces and instead promote the use of the Thread package. [Patch 932527] Also reworked and reordered the page for better readability. 2004-04-25 Don Porter <[email protected]> * generic/tcl.h: Removed obsolete declarations and #include's. * generic/tclInt.h: [Bugs 926459, 926486] 2004-04-24 David Gravereaux <[email protected]> * win/tclWin32Dll.c (DllMain): Added DisableThreadLibraryCalls() |
︙ | ︙ | |||
3536 3537 3538 3539 3540 3541 3542 | * doc/gets.n: Added example based on [Patch 935911]. 2004-04-15 Donal K. Fellows <[email protected]> * generic/tclClock.c (Tcl_ClockObjCmd): Minor fault in a [clock clicks] error message. | | | | | | | | 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 | * doc/gets.n: Added example based on [Patch 935911]. 2004-04-15 Donal K. Fellows <[email protected]> * generic/tclClock.c (Tcl_ClockObjCmd): Minor fault in a [clock clicks] error message. 2004-04-07 Jeff Hobbs <[email protected]> * win/tclWinInit.c (TclpSetInitialEncodings): note that WIN32_CE is also a unicode platform. * generic/tclEncoding.c (TclFindEncodings, Tcl_FindExecutable): * generic/tclInt.h: Correct handling of UTF * unix/tclUnixInit.c (TclpInitLibraryPath): data that is actually * win/tclWinFile.c (TclpFindExecutable): "clean", allowing the * win/tclWinInit.c (TclpInitLibraryPath): loading of Tcl from paths that contain multi-byte chars on Windows [Bug 920667] * win/configure: define TCL_LIB_FLAG, TCL_BUILD_LIB_SPEC, * win/configure.in: TCL_LIB_SPEC, TCL_PACKAGE_PATH in tclConfig.sh. 2004-04-06 Don Porter <[email protected]> Patch 922727 committed. Implements three changes: * generic/tclInt.h: Reworked the Tcl header files into a clean * unix/tclUnixPort.h: hierarchy where tcl.h < tclPort.h < tclInt.h * win/tclWinInt.h: and every C source file should #include * win/tclWinPort.h: at most one of those files to satisfy its declaration needs. tclWinInt.h and tclWinPort.h also better organized so that tclWinPort.h includes the Windows implementation of cross-platform declarations, while tclWinInt.h makes declarations that are available on Windows only. |
︙ | ︙ | |||
3584 3585 3586 3587 3588 3589 3590 | * tests/unixInit.test (unixInit-3.1): Default encoding on Darwin systems is utf-8. Thanks to Steven Abner (tauvan). [Bug 928808] 2004-04-06 Donal K. Fellows <[email protected]> * tests/cmdAH.test (cmdAH-18.2): Added constraint because access(...,X_OK) is defined to be permitted to be meaningless when | | | | | | | | | | | | | | | | | | 6827 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 | * tests/unixInit.test (unixInit-3.1): Default encoding on Darwin systems is utf-8. Thanks to Steven Abner (tauvan). [Bug 928808] 2004-04-06 Donal K. Fellows <[email protected]> * tests/cmdAH.test (cmdAH-18.2): Added constraint because access(...,X_OK) is defined to be permitted to be meaningless when running as root, and OSX exhibits this. [Bug 929892] 2004-04-02 Miguel Sofer <[email protected]> * generic/tclCompile.c: * generic/tclInt.h: removed the macro TCL_ALIGN() from tclInt.h, replaced by the static macro ALIGN() in tclCompile.c [Bug 926445] 2004-04-02 Miguel Sofer <[email protected]> * generic/tclCompile.h: removed redundant #ifdef _TCLINT [Bug 928415], reported by tauvan. 2004-04-02 Don Porter <[email protected]> * tests/tcltest.test: Corrected constraint typos: "nonRoot" -> "notRoot". Thanks to Steven Abner (tauvan). [Bug 928353] 2004-04-01 Don Porter <[email protected]> * generic/tclInt.h: Removed obsolete tclBlockTime* declarations. [Bug 926454] 2004-04-01 Vince Darley <[email protected]> * generic/tclIOUtil.c: Fix to privately reported vfs bug with 'glob -type d -dir . *' across a vfs boundary. No tests for this are currently possible without effectively moving tclvfs into Tcl's test suite. 2004-03-31 Don Porter <[email protected]> * doc/msgcat.n: Clarified message catalog file encodings. [Bug 811457] * library/msgcat/msgcat.tcl: Updated internals to make use of [dict]s to store message catalog data and to use [source -encoding utf-8] to access catalog files. Thanks to Michael Sclenker. [Patch 875055, RFE 811459] Corrected [mcset] to be able to successfully set a translation to the empty string. [mcset $loc $src {}] was incorrectly set the $loc translation of $src back to $src. Also changed [ConvertLocale] to minimally require a non-empty "language" part in the locale value. If not, an error raised prompts [Init] to keep looking for a valid locale value, or ultimately fall back on the "C" locale. [Bug 811461]. * library/msgcat/pkgIndex.tcl: Bump to msgcat 1.4.1. 2004-03-30 Donal K. Fellows <[email protected]> * generic/tclHash.c (HashStringKey): Cleaned up. This function is not faster, but it is a little bit clearer. * generic/tclLiteral.c (HashString): Applied logic from HashObjKey. * generic/tclObj.c (HashObjKey): Rewrote to fix fault which hashed every single-character object to the same hash bucket. The new code is shorter, simpler, clearer, and (happily) faster. 2004-03-30 Miguel Sofer <[email protected]> * generic/tclExecute.c (TEBC): reverting to the previous method for async tests in TEBC, as the new method turned out to be too costly. Async tests now run every 64 instructions. 2004-03-30 Miguel Sofer <[email protected]> * generic/tclCompile.c: New instruction code INST_START_CMD * generic/tclCompile.h: that allows checking the bytecode's * generic/tclExecute.c: validity [Bug 729692] and the interp's * tests/interp.test (18.9): readyness [Bug 495830] before running * tests/proc.test (7.1): the command. It also changes the * tests/rename.test (6.1): mechanics of the async tests in TEBC, doing it now at command start instead of every 16 instructions. 2004-03-30 Vince Darley <[email protected]> * generic/tclFileName.c: Fix to Windows glob where the pattern is * generic/tclIOUtil.c: a volume relative path or a network * tests/fileName.test: share [Bug 898238]. On windows 'glob' * tests/fileSystem.test: will now return the results of 'glob /foo/bar' and 'glob \\foo\\bar' as 'C:/foo/bar', i.e. a correct absolute path (rather than a volume relative path). Note that the test suite does not test commands like 'glob //Machine/Shared/*' (on a network share). 2004-03-30 Vince Darley <[email protected]> * generic/tclPathObj.c: Fix to filename bugs recently * tests/fileName.test: introduced [Bug 918320]. 2004-03-29 Don Porter <[email protected]> * generic/tclMain.c (Tcl_Main, StdinProc): Append newline only * tests/basic.test (basic-46.1): to incomplete scripts as part of multi-line script construction. Do not add an extra trailing newline to the complete script. [Bug 833150] 2004-03-28 Miguel Sofer <[email protected]> * generic/tclCompile.c (TclCompileScript): corrected possible segfault when a compilation returns TCL_OUTLINE_COMPILE after having grown the compile environment [Bug 925121]. 2004-03-27 Miguel Sofer <[email protected]> * doc/array.n: added documentation for trace-realted behaviour of 'array get' [Bug 449893] 2004-03-26 Don Porter <[email protected]> * README: Bumped version number to 8.5a2 to * tools/tcl.wse.in: distinguish HEAD of CVS development * unix/configure.in: from the recent 8.5a1 release. * unix/tcl.spec: * win/README.binary: * win/configure.in: |
︙ | ︙ | |||
3727 3728 3729 3730 3731 3732 3733 | * compat/strtoll.c: * compat/strtoull.c: * generic/tclIntDecls.h: * generic/tclMain.c: * generic/tclObj.c: * win/tclWinDde.c: * win/tclWinReg.c: | | | | | | | | | | | | 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 | * compat/strtoll.c: * compat/strtoull.c: * generic/tclIntDecls.h: * generic/tclMain.c: * generic/tclObj.c: * win/tclWinDde.c: * win/tclWinReg.c: * win/tclWinTime.c: Made HEAD build on Windows VC++ again. 2004-03-19 Donal K. Fellows <[email protected]> * generic/tclIntDecls.h: Made HEAD build on Solaris again by applying fix recommended by Don Porter. 2004-03-18 Reinhard Max <[email protected]> * generic/tclIntDecls.h: Removed TclpTime_t. It wasn't really needed, * generic/tclInt.h: but caused warnings related to * generic/tclInt.decls: strict aliasing with GCC 3.3. * generic/tclClock.c: * generic/tclDate.c: * generic/tclGetDate.y: * win/tclWinTime.c: * unix/tclUnixTime.c: * generic/tclNamesp.c: Added temporary pointer variables to work * generic/tclStubLib.c: around warnings related to * unix/tclUnixChan.c: strict aliasing with GCC 3.3. * unix/tcl.m4: Removed -Wno-strict-aliasing. 2004-03-18 Daniel Steffen <[email protected]> Removed support for Mac OS Classic platform [Patch 918142] * README: * compat/string.h: |
︙ | ︙ | |||
3899 3900 3901 3902 3903 3904 3905 | 2004-03-17 Donal K. Fellows <[email protected]> * doc/lsearch.n: Improved examples on the advanced capabilities of lsearch (with the right options, set element removal can be done) following discussion on tkchat. | | | | | 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 | 2004-03-17 Donal K. Fellows <[email protected]> * doc/lsearch.n: Improved examples on the advanced capabilities of lsearch (with the right options, set element removal can be done) following discussion on tkchat. 2004-03-16 Don Porter <[email protected]> * doc/catch.n: Compiled [catch] no longer fails to catch syntax errors. Removed the claims in the documentation that it does. * doc/return.n: Updated example to use [dict merge]. 2004-03-16 Jeff Hobbs <[email protected]> * unix/configure, unix/tcl.m4: add -Wno-strict-aliasing for GCC to suppress useless type puning warnings. 2004-03-16 Donal K. Fellows <[email protected]> * doc/file.n: *roff formatting fix. [Bug 917171] |
︙ | ︙ | |||
3932 3933 3934 3935 3936 3937 3938 | IMPLEMENTATION OF TIP#163 * generic/tclDictObj.c (DictMergeCmd): This is based on work by Joe * tests/dict.test (dict-20.*): English in Tcl [FRQ 745851] * doc/dict.n: but not exactly. 2004-03-10 Kevin B. Kenny <[email protected]> | | | | | 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 | IMPLEMENTATION OF TIP#163 * generic/tclDictObj.c (DictMergeCmd): This is based on work by Joe * tests/dict.test (dict-20.*): English in Tcl [FRQ 745851] * doc/dict.n: but not exactly. 2004-03-10 Kevin B. Kenny <[email protected]> * generic/tclGetDate.y (TclGetDate): Fix so that [clock scan <timeOfDay> -gmt true] uses the GMT base date instead of the local one. [Bug 913513] * tests/clock.test: Added test cases for wrong ISO8601 week number [Bug 500285] and wrong GMT base date [Bug 913513]. Several tests still fail on Windows, and these are actual faults in [clock scan]. Fix is still pending. * generic/tclDate.c: Regenerated. 2004-03-08 Vince Darley <[email protected]> * generic/tclFileName.c: Fix to 'glob -path' near the root * tests/fileName.test: of the filesystem. [Bug 910525] 2004-03-08 Don Porter <[email protected]> * generic/tclParse.c (TclParseInit): Modified TclParseInit so * generic/tclTest.c ([testexprparser]): that Tcl_Parse initialization conforms to documented promised about what fields will not be modified by what Tcl_Parse* routines. [Bug 910595] 2004-03-05 Mo DeJong <[email protected]> |
︙ | ︙ | |||
3976 3977 3978 3979 3980 3981 3982 | 2004-03-05 Kevin B. Kenny <[email protected]> * tests/registry.test: Applied fix from Patch #910174 to make the test for an English-language system include any country code, rather than just English-United States.1252. Thanks to Pat Thoyts for the changes. | | | | | | | | | | | | 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 7268 7269 7270 7271 7272 7273 7274 7275 7276 7277 7278 7279 7280 7281 7282 7283 7284 | 2004-03-05 Kevin B. Kenny <[email protected]> * tests/registry.test: Applied fix from Patch #910174 to make the test for an English-language system include any country code, rather than just English-United States.1252. Thanks to Pat Thoyts for the changes. 2004-03-04 Pat Thoyts <[email protected]> * tests/registry.test: Applied fixed from #766159 to skip two tests on Win98 that depend on a Unicode registry (NT specific). 2004-03-04 Don Porter <[email protected]> * generic/tclInt.h (TclParseInit): Factored the common code * generic/tclParse.c (TclParseInit): for initializing a Tcl_Parse * generic/tclParseExpr.c: struct into one routine. 2004-03-04 Pat Thoyts <[email protected]> * library/reg/pkgIndex.tcl: Added TIP #100 support to the * win/tclWinReg.c: registry package (patch #903831) This provides a Windows test of the TIP #100 mechanism and a sample to show how unloading an extension can be done. 2004-03-04 Donal K. Fellows <[email protected]> * unix/dltest/pkgua.c: Fix minor syntax problems. [Bug 909288] 2004-03-03 Jeff Hobbs <[email protected]> *** 8.5a1 TAGGED FOR RELEASE *** * changes: updated for 8.5a1 2004-03-03 David Gravereaux <[email protected]> * win/makefile.vc: default environment variable for VC++ is %MSDevDir% not %MSVCDir%, although vcvars32.bat sets both. * win/tclWinNotify.c (Tcl_WaitForEvent) : Allows an idling notifier to service "Asynchronous Procedure Calls" from its wait state. Only useful for extension authors who decide they might want to try "completion routines" with WriteFileEx(), as an example. From experience, I recommend that "completion ports" should be used instead as the execution of the callbacks are more managable. 2004-03-01 Jeff Hobbs <[email protected]> * README: update patchlevel to 8.5a1 * generic/tcl.h: * tools/tcl.wse.in, tools/tclSplash.bmp: * unix/configure, unix/configure.in, unix/tcl.spec: * win/README.binary, win/configure, win/configure.in: * unix/tcl.m4: update HP-11 build libs setup 2004-03-01 Don Porter <[email protected]> * unix/tcl.m4 (SC_CONFIG_CFLAGS): Allow 64-bit enabling on IRIX64-6.5* systems. [Bug 218561] * unix/configure: autoconf-2.57 * generic/tclTrace.c (TclCheckInterpTraces): The TIP 62 * generic/tclTest.c (TestcmdtraceCmd): implementation introduced a |
︙ | ︙ | |||
4070 4071 4072 4073 4074 4075 4076 | * generic/tclLoad.c (Tcl_LoadObjCmd): Missing dereference caused segfault with non-loadable extension. [Bug 904307] * unix/tclUnixChan.c (TcpGetOptionProc): Stop memory leak with very long hostnames. [Bug 888777] | | | | 7313 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 | * generic/tclLoad.c (Tcl_LoadObjCmd): Missing dereference caused segfault with non-loadable extension. [Bug 904307] * unix/tclUnixChan.c (TcpGetOptionProc): Stop memory leak with very long hostnames. [Bug 888777] 2004-02-25 Pat Thoyts <[email protected]> * win/tclWinDde.c: Removed some gcc warnings - except for the -Wconversion warning for GetGlobalAtomName. gcc is just wrong about this. 2004-02-24 Donal K. Fellows <[email protected]> IMPLEMENTATION OF TIP#100 FROM GEORGIOS PETASIS * generic/tclLoad.c (Tcl_UnloadObjCmd): Implementation. |
︙ | ︙ | |||
4110 4111 4112 4113 4114 4115 4116 | 2004-02-17 Don Porter <[email protected]> * doc/tcltest.n: * library/tcltest/tcltest.tcl: Changed -verbose default value to {body error} so that detailed information on unexpected errors in tests is provided by default, even after the fix for [Bug 725253] | | | | | | | 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 7403 | 2004-02-17 Don Porter <[email protected]> * doc/tcltest.n: * library/tcltest/tcltest.tcl: Changed -verbose default value to {body error} so that detailed information on unexpected errors in tests is provided by default, even after the fix for [Bug 725253] 2004-02-17 Jeff Hobbs <[email protected]> * tests/unixInit.test (unixInit-7.1): * unix/tclUnixInit.c (TclpInitPlatform): ensure the std fds exist to prevent crash condition [Bug #772288] 2004-02-17 Donal K. Fellows <[email protected]> * generic/tclCompCmds.c (TclCompileSwitchCmd): Bozo mistake in memory releasing order when in an error case. [Bug 898910] 2004-02-16 Jeff Hobbs <[email protected]> * generic/tclTrace.c (TclTraceExecutionObjCmd) (TclTraceCommandObjCmd): fix possible mem leak in trace info. 2004-02-12 Mo DeJong <[email protected]> * win/tclWinInit.c (AppendEnvironment): Use the tail component of the passed in lib path instead of just blindly using lib+4. That worked when lib was "lib/..." but fails for other values. Thanks go to Patrick Samson for pointing this out. 2004-02-10 David Gravereaux <[email protected]> * win/nmakehlp.c: better macro grepping logic. 2004-02-07 David Gravereaux <[email protected]> * win/makefile.vc: * win/rules.vc: * win/tcl.rc: * win/tclsh.rc: Added an 'unchecked' option to the OPTS macro so a core built with symbols can be linked to the non-debug enabled C run-time. As per discussion with Kevin Kenny. Called like this: nmake -af makefile.vc OPTS=unchecked,symbols This clarifies the meaning of the 'g' naming suffix to mean only that the binary requires the debug enabled C run-time. Whether the binary contains symbols or not is a different condition. |
︙ | ︙ | |||
4222 4223 4224 4225 4226 4227 4228 | 2004-01-29 Vince Darley <[email protected]> * generic/tclPathObj.c: fix to [Bug 883143] in file normalization 2004-01-29 Vince Darley <[email protected]> | | | 7465 7466 7467 7468 7469 7470 7471 7472 7473 7474 7475 7476 7477 7478 7479 | 2004-01-29 Vince Darley <[email protected]> * generic/tclPathObj.c: fix to [Bug 883143] in file normalization 2004-01-29 Vince Darley <[email protected]> * doc/file.n: * generic/tclFCmd.c * generic/tclTest.c * library/init.tcl * mac/tclMacFile.c * tests/fileSystem.test: fix to [Bug 886352] where 'file copy -force' had inconsistent behaviour wrt target files with insufficient permissions, particular from vfs->native fs. |
︙ | ︙ | |||
4255 4256 4257 4258 4259 4260 4261 | Many other minor whitespace/style fixes to this file too. 2004-01-27 David Gravereaux <[email protected]> * win/nmakehlp.c: Use '.\nul' as the sourcefile name instead of 'nul' so VC 5.2 doesn't try searching the path for it and failing with a possible dialogbox popping up about having to add a CD to | | | | | | | 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 7534 7535 7536 7537 7538 | Many other minor whitespace/style fixes to this file too. 2004-01-27 David Gravereaux <[email protected]> * win/nmakehlp.c: Use '.\nul' as the sourcefile name instead of 'nul' so VC 5.2 doesn't try searching the path for it and failing with a possible dialogbox popping up about having to add a CD to an empty drive. Also added a SetErrorMode() call to disable any dialogs that cl.exe or link.exe might create. [Bug 885537] 2004-01-22 Vince Darley <[email protected]> * doc/file.n: clarified documentation of 'file system' [Bug 883825] * tests/fCmd.test: improved test result in failure case. 2004-01-22 Vince Darley <[email protected]> * tests/fileSystem.test: 3 new tests * generic/tclPathObj.c: fix to [Bug 879555] in file normalization. * doc/filename.n: small clarification to Windows behaviour with filenames like '.....', 'a.....', '.....a'. * generic/tclIOUtil.c: slight improvement to native cwd caching on Windows. 2004-01-21 David Gravereaux <[email protected]> * doc/Panic.3: Mentions of 'panic' and 'panicVA' removed from the documentation. 2004-01-21 Vince Darley <[email protected]> * doc/FileSystem.3: * generic/tcl.decls: * generic/tclCmdAH.c * generic/tclDecls.h * generic/tclFCmd.c * generic/tclFileName.c * generic/tclFileSystem.h * generic/tclIOUtil.c * generic/tclInt.decls |
︙ | ︙ | |||
4313 4314 4315 4316 4317 4318 4319 | applied a round of filesystem optimisation with better handling and caching of relative and absolute paths, requiring fewer conversions. (3) clarifications to the documentation, particularly regarding the acceptable refCounts of objects. Some new tests added. Tcl benchmarks show a significant improvement over 8.4.5, and on Windows typically a small improvement over 8.3.5 (Unix still appears to require | | | | | 7556 7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 | applied a round of filesystem optimisation with better handling and caching of relative and absolute paths, requiring fewer conversions. (3) clarifications to the documentation, particularly regarding the acceptable refCounts of objects. Some new tests added. Tcl benchmarks show a significant improvement over 8.4.5, and on Windows typically a small improvement over 8.3.5 (Unix still appears to require optimisation). TCL_FILESYSTEM_VERSION_2 introduced, but for internal use only. There should be no public incompatibilities from these changes. Thanks to dgp for extensive testing. 2004-01-19 David Gravereaux <[email protected]> * win/tclWinPipe.c (Tcl_WaitPid): Fixed a thread-safety problem with the process list. The delayed cut operation after the wait was going stale by being outside the list lock. It now cuts within the lock and does a locked splice for when it needs to instead. [Bug 859820] 2004-01-18 Donal K. Fellows <[email protected]> * generic/tclCompile.c, generic/tclCompile.h: Two new opcodes, INST_LIST_INDEX_IMM and INST_LIST_RANGE_IMM, that have operand(s) |
︙ | ︙ | |||
4363 4364 4365 4366 4367 4368 4369 | 2004-01-15 David Gravereaux <[email protected]> * win/tclWinReg.c: Placed the requirement for advapi.lib into the object file itself with #paragma comment (lib, ...) when built with VC++. This will simplify linking for users of the static library. | | | | | | | 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 | 2004-01-15 David Gravereaux <[email protected]> * win/tclWinReg.c: Placed the requirement for advapi.lib into the object file itself with #paragma comment (lib, ...) when built with VC++. This will simplify linking for users of the static library. * win/rules.vc: Added new 'fullwarn' to the CHECKS commandline macro; sets $(FULLWARNINGS). * win/makefile.vc: Removed 'advapi.lib' from $(baselibs). Added new logic to crank-up the warning levels for both compile and link when $(FULLWARNINGS) is set. Some clean-up with how the resource files are built and how -DTCL_USE_STATIC_PACKAGES is sent when compiling the shells. * win/tclAppInit.c: Small change in how TCL_USE_STATIC_PACKAGES is used. * win/tcl.rc: * win/tclsh.rc: Some clean-up with how the resource files are built. Fixed 'OriginalFilename' problem that still thought a debug suffix was still 'd', now is 'g'. 2004-01-14 Donal K. Fellows <[email protected]> * generic/tclDictObj.c (TraceDictPath, DictExistsCmd): Adjusted behaviour of [dict exists] so a failure to look up a dictionary along the path of dicts doesn't trigger an error. This is how it was documented to behave previously... [Bug 871387] * generic/tclDictObj.c: Assorted dict fixes from Peter Spjuth relating to [Bug 876170]. (SetDictFromAny): Make sure that lists retain their ordering even when converted to dictionaries and back. (TraceDictPath): Correct object reference count handling! (DictReplaceCmd, DictRemoveCmd): Stop object leak. (DictIncrCmd,DictLappendCmd,DictAppendCmd,DictSetCmd,DictUnsetCmd): Simpler handling of reference counts when assigning to variables. * tests/dict.test (dict-19.2): Memory leak stress test 2004-01-13 Don Porter <[email protected]> * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Silence compiler warnings. Patch 876451: restores performance of [return]. Also allows forms such as [return -code error $msg] to be bytecompiled. * generic/tclInt.h: Factored Tcl_ReturnObjCmd() into two pieces: * generic/tclCmdMZ.c: TclMergeReturnOptions(), which can parse the options to [return], check their validity, and create the corresponding return options dictionary, and TclProcessReturn(), which takes that return options dictionary and performs the |
︙ | ︙ | |||
4444 4445 4446 4447 4448 4449 4450 | Create fresh objects instead of using the one currently in the interpreter, which isn't guaranteed to be fresh and unshared. The cost for the core will be minimal because of the object cache, and this fixes [Bug 875395]. 2004-01-12 Miguel Sofer <[email protected]> | | | | | | | | | | 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 | Create fresh objects instead of using the one currently in the interpreter, which isn't guaranteed to be fresh and unshared. The cost for the core will be minimal because of the object cache, and this fixes [Bug 875395]. 2004-01-12 Miguel Sofer <[email protected]> * generic/tclCompExpr.c (CompileLandOrLorExpr): cosmetic changes. 2004-01-12 Miguel Sofer <[email protected]> * generic/tclCompExpr.c (CompileLandOrLorExpr): new logic, fewer instructions. As a side effect, the instructions INST_LOR and INST_LAND are now never used. * generic/tclExecute.c (INST_JUMP*): small optimisation; fix a bug in debug code. 2004-01-11 David Gravereaux <[email protected]> * win/tclWinThrd.c (Tcl_ConditionNotify): condPtr must be dereferenced to see if there are waiters else uninitialized datum is manipulated. [Bug 849007 789338 745068] 2004-01-09 David Gravereaux <[email protected]> * generic/tcl.h: Renamed and deprecated #defines moved to within the #ifndef TCL_NO_DEPRECATED block. This allows us to build Tcl to check for deprecated functions in use, such as panic() and Tcl_Ckalloc(). By request from DKF. Extensions that build with -DTCL_NO_DEPRECATED now have these macros as restricted. ***POTENTIAL INCOMPATIBILITY*** * win/makefile.vc: * win/rules.vc: Added -DTCL_NO_DEPRECATED usage to makefile.vc. Called like this: nmake -af makefile.vc CHECKS=nodep 2004-01-09 Vince Darley <[email protected]> * generic/tclIOUtil.c: fix to infinite loop in TclFinalizeFilesystem [Bug 873311] ****************************************************************** *** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" *** *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" *** *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" *** *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" *** *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" *** ****************************************************************** |
Changes to README.
1 | README: Tcl | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | README: Tcl This is the Tcl 8.5a4 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.53.2.2 2005/07/12 20:36:11 kennykb 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.92.2.2 2005/07/12 20:36:11 kennykb 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 |
︙ | ︙ | |||
6195 6196 6197 6198 6199 6200 6201 | 2004-09-07 (bug fix)[1016167] [after] overwrites its imports (kenny) 2004-09-08 (bug fix) fixed [clock format 0 -format %k] (kenny) 2004-09-09 (bug fix)[560297] fixed broken [namespace forget] logic (porter) | | > | > | > | > | > | > | > | > | | < < < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 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 | 2004-09-07 (bug fix)[1016167] [after] overwrites its imports (kenny) 2004-09-08 (bug fix) fixed [clock format 0 -format %k] (kenny) 2004-09-09 (bug fix)[560297] fixed broken [namespace forget] logic (porter) 2004-09-09 (bug fix)[1017299] fixed [namespace import] cycle prevention (porter) 2004-09-10 (performance) $x[set x {}] is now fast [K $x [set x {}]] (sofer) 2004-09-10 (bug fix)[868489] better control over int <-> wideInt (fellows,kenny) 2004-09-10 (bug fix)[1025359] POSIX errorCode from wide seeks (kupries,fellows) 2004-09-10 (bug fix)[707104,1026493] fix [rename] of [interp alias] (porter) 2004-09-18 (bug fix)[868467] fix [expr 5>>32] => 0, not 5 (hintermayer,fellows) 2004-09-21 (bug fix) consistent errorinfo from [namespace eval x error foo bar] and [namespace eval c {error foo bar}] (porter) 2004-09-22 (feature change) syntax errors not reported at compile time; deferred to runtime. Support [return -errorline]. (porter) 2004-09-23 (bug fix)[1016726] fix `make clean` in static config (leitgeb,dejong) 2004-09-22 (feature change) report all compile errors at runtime (porter) 2004-09-29 (bug fix)[1036649] syntax error in [subst] => buffer overflow (sofer) 2004-09-30 (bug fix)[1038021] save/restore error state: var traces (porter) 2004-10-01 (performance) stackframe level values in internal reps (fellows) 2004-10-01 (feature change)[1037235] auto-create [dict] key paths (fellows) 2004-10-04 (bug fix)[884830] eq and ne parse in expr (fellows) 2004-10-05 (reform) errorInfo, errorCode management (porter) *** POTENTIAL INCOMPATIBILITY for traces on those vars *** 2004-10-06 (feature change)[1041072] re-bless and enhance Tcl_AppendResult (dkf) 2004-10-06 (reform) more robust interp result appends (porter) => dde 1.3.1 => registry 1.1.5 2004-10-06 (reform) re-write of [glob] guts (fellows) 2004-10-07 (reform)[925620] improved platform split of VFS code (darley) 2004-10-08 (new feature)[TIP 201] "in" and "ni" expr operators (fellows) 2004-10-08 (new feature)[TIP 212] [dict update]; [dict with] (fellows) 2004-10-08 (bug fix)[954263] case insensitive [file exec] for Win (hobbs,darley) 2004-10-14 (performance) [info commands/globals/procs/vars $pattern] faster when $pattern is trivial (fellows) 2004-10-14 (new feature)[TIP 217] [lsort -indices] (salsman,fellows) 2004-10-24 (reform) replaced bit flag values with macros for Var handling *** POTENTIAL INCOMPATIBILITY for accesses to Var internals *** 2004-10-26 (new feature)[1054370] install msgcat, http, tcltest as TM's (porter) 2004-10-26 (bug fix)[767676] negative PIDs with pipes (giese,gravereaux) 2004-10-27 (bug fix)[731778] stop critical section leaks (mistachkin,gravereaux) 2004-10-27 (bug fix)[926088] -load option to find tested packages (gravereaux) 2004-10-28 (bug fix)[1030548] restore the --enable-symbols --enable-threads build on Win (mistachkin,kenny,kupries) 2004-10-29 (bug fix)[1055673] fix command line syntax error message (porter) => tcltest 2.2.7 2004-10-30 (bug fix)[926106] fix [file mtime] DST anomaly (kenny) 2004-10-31 (bug fix)[1057461] fix [info globals ::varName] (fellows) 2004-11-02 (bug fix)[761471] fix [expr {NaN == NaN}] (sofer) 2004-11-02 (bug fix)[1017151] misleading errorInfo after tests (seeger,porter) 2004-11-03 (bug fix)[527164] preserve errorinfo from var traces (porter) 2004-11-08 (bug fix){947693] Made -blocking option of channel during [close] consistent on Windows with Unix (gravereaux) *** POTENTIAL INCOMPATIBILITY *** 2004-11-11 (bug fix)[1034337] recursive file delete, MacOSX (steffen) 2004-11-12 (new feature)[TIP 221] [interp bgerror] (porter) 2004-11-12 (new feature)[TIP 226] Tcl_(Save|Restore|Discard)InterpState (porter) 2004-11-12 (new feature)[TIP 227] Tcl_(Get|Set)ReturnOptions (porter) 2004-11-12 (bug fix)[1004065] stop crash when TCL_UTF_MAX==6 (hobbs,porter) 2004-11-15 (bug fix)[10653678] [trace variable],[trace remove] interop (porter) 2004-11-16 (bug fix)[1067709] crash in [fconfigure -ttycontrol] (hobbs) 2004-11-18 (new feature) configure options --enable-man-suffix (max) 2004-11-22 (bug fix)[1030465] Improve HAVE_TYPE_OFF64_T check (dejong) 2004-11-22 (bug fix)[1043129] Fixed the treatment of backslashes in file join on Windows (darley) 2004-11-22 (bug fix)[976438] Move init.tcl search path construction to tclInit (porter) 2004-11-24 (bug fix)[1072654] Fixed segfault in info vars trivial matching branch (new in 8.4.8) (porter) 2004-11-24 (bug fix)[1001325, 1071701] Fixed readdir_r detection and usage (dejong, kenny, porter) 2004-11-24 (bug fix)[1071807] Fixed all uses of 'select' to use standard macros rather than older bit-whacking style (kenny) 2004-11-26 (bug fix)[1073524] Simplify the code to check for correctness of strstr, strtoul and strtod on unix (fellows) 2004-11-26 (bug fix)[1072136] Remove file normalize on tcl_findLibrary search path uniqification added in 8.4.8 (porter) 2004-11-30 (bug fix)[976520] Rework startup/initialization of the Tcl library, encoding search initialization, and Tcl_FindExecutable structure. [tclInit] no longer driven by the value of $::tcl_libPath (TCLLIBPATH). (porter) *** POTENTIAL INCOMPATIBILITY : makes encoding names case sensitive on Windows, where they have been case insensitive *** 2004-12-02 (bug fix)[1074671] Ensure tilde paths are not returned specially by 'glob' (darley) Doc improvements [759545,926590,935853,1017072,1018486,1022527,1027849, 1032243,1047928,1048005,1058446,1062647,1065732,1073334,etc.] Test suite expansion [1036649,1001997,etc.] --- Released 8.5a2, December 7, 2004 --- See ChangeLog for details --- 2004-12-13 (bug fix)[1083082] encoding memory leaks (ade,porter) 2004-12-13 (bug fix)[1082349] restored C++ extension support (porter) 2004-12-14 (bug fix)[1081541] workaround automake-ism "$U" (porter) 2004-12-15 (new feature) CallFrames on execution, not C, stack (sofer) 2004-12-16 (bug fix)[1085023] [interp limit] support in [vwait], etc. (fellows) 2004-12-29 (bug fix)[1090413] make [clock scan 0030] work (morian,kenny) 2004-12-29 (bug fix)[1092789] make [clock scan 10000] work (porter,kenny) 2004-12-29 (platform support)[1092952,1091967] MSVC7, gcc OPT compiles (hobbs) 2005-01-06 (performance)[1020491] [http::mapReply] (fellows) => http 2.5.1 2005-01-09 (bug fix)[1095909] stopped use of readdir_r (english) 2005-01-10 (enhancement)[1081595] stopped use of TCL_DBGX (english) 2005-01-17 (bug fix)[1100542] [glob] of Windows shares (schar,darley) 2005-01-19 (new feature)[TIP 235] C API for ensembles (fellows) 2005-01-21 (new feature)[TIP 233] virtual time (kupries) 2005-01-25 (bug fix)[1101670] [auto_reset] update for [namespace] (porter) ***POTENTIAL INCOMPATIBILITY*** May cause re-[source]-ing of files that have not anticipated that before. 2005-01-27 (new feature)[TIP 218] Tcl_Channel API update for threads (kupries) 2005-01-27 (bug fix)[1109484] Tcl_Expr* updates for Tcl_WideInt (hobbs) 2005-01-28 (platform support)[1021871] Solaris gcc 64-bit support (hobbs) 2005-02-10 (bug fix)[1119369] Tcl_EvalObjEx: avoid shimmer loss of List intrep (sofer,macdonald) 2005-02-11 (platform support) correct gcc builds for AIX-4+, HP-UX-11 (hobbs) 2005-02-24 (bug fix)[1119798] prevent [source $directory] (porter,mpettigr) => tcltest 2.2.8 2005-03-10 (bug fix)[1153871] bad ClientData cast (porter,victorovich) 2005-03-15 (platform support) OpenBSD ports patch (thoyts) 2005-03-18 (bug fix)[1115904] restore recursion limit in direct eval (porter) 2005-03-24 (bug fix) stop conflict between Tcltest and Thread packages (porter) 2005-03-29 (platform support) allow msys builds without cygwin (hobbs) 2005-04-01 (internal change)[1158008] internal rep of "list" Tcl_Obj's now uses a refcounted struct (sofer) ***POTENTIAL INCOMPATIBILITY*** For any code that goes poking into the internals of "list" Tcl_Obj's 2005-04-05 (performance)[1174551] Tcl_DecrRefCount of Tcl_Obj "chains" (sofer) 2005-04-08 (performance)[1077262] better Tcl_Encoding cache lifetimes (porter) 2005-04-10 (bug fix)[1180368] [interp invokehidden] mem leak (kenny,porter) 2005-04-12 (performance)[1177363] startup encoding file scan (porter) 2005-04-12 (performance)[1182459] [clock format] (kenny) 2005-04-13 (bug fix) min buffer size dropped from 10 to 1 byte (gravereaux) 2005-04-16 (bug fix)[1178445] fix memory waste at thread exit (vasiljevic) 2004-04-16 (bug fix)[1084111] [array names] memory leak (ade,sofer) 2005-04-19 (bug fix)[1185933] [clock] init clobbered global vars (ring,kenny) 2005-04-19 (new feature) [::tcl::unsupported::EncodingDirs] - unsupported command to set search path for encoding files (porter) 2005-04-20 (bug fix)[1090869] Tcl_GetInt accept 0x80000000, 64-bit (porter,singh) 2005-04-22 (bug fix)[1187123] [string is boolean] respect EIAS (porter) 2005-04-25 (enhancement) update to tzdata2005i (kenny) 2005-04-25 (platform support) builds on Mac OS X 10.1 (steffen) 2005-04-27 (new feature)[TIP 183] [open $f {... BINARY ...}] (porter) 2005-04-29 (new feature)[TIP 176] simple index arithmetic (porter) 2005-05-06 (platform support) x86_64 Solarix cc and Solaris 10 builds (hobbs) 2005-05-10 (bug fix)[1198892] [expr {i**0}] error (kaitschu,markus) 2005-05-10 (new feature)[TIP 132] floating-point conversion to string (kenny) ***POTENTIAL INCOMPATIBILITY*** For scripts that rely on (tcl_precision==12) number formatting 2005-05-10 (new feature)[TIP 232] math functions as commands (kenny) ***POTENTIAL INCOMPATIBILITY*** Tcl_GetMathFuncInfo functioning is reduced; routine is now deprecated 2005-05-13 (feature removed) TCL_NO_MATH compiler directive (porter) 2005-05-14 (platform support) Mac OSX: configurable CoreFoundation API (steffen) 2005-05-14 (platform support) Mac OSX: use realpath when threadsafe (steffen) 2005-05-17 (feature removed) Tcl_ObjType's "list", "procbody", "index", "ensembleCommand", "localVarName", "levelReference, "boolean" are no longer registered (porter) ***POTENTIAL INCOMPATIBILITY*** For any callers of Tcl_GetObjType on those strings 2005-05-20 (bug fix)[1201589] boolean literal prefix in expressions (porter) 2005-05-24 (platform support) Darwin build support merged into unix (steffen) 2005-05-24 (new feature)[1202209] Mac OSX: support [load] of .bundle binaries Can support [load] from memory as well (steffen) 2005-05-24 (new feature)[1202178] [time] returns non-integer result (steffen) 2005-05-25 (new feature)[TIP 182] [expr {bool(...)}] (mistachkin,porter) 2005-05-30 (new feature)[TIP 229] [namespace path] (fellows) 2005-05-31 (bug fix)[1082283] Unix: notifier thread now joinable (vasiljevic) 2005-06-01 (new feature)[TIP 241] -nocase: lsort, lsearch, switch (mistachkin) 2005-06-01 (bug fix)[1209759] "return TCL_RETURN;" could cause panic (porter) Documentation improvements [1075433,1085127,1117017,1124160,1149605,etc.] --- Released 8.5a3, June 4, 2004 --- See ChangeLog for details --- |
Changes to compat/string.h.
1 2 3 4 5 6 7 8 9 10 11 | /* * string.h -- * * Declarations of ANSI C library procedures for string handling. * * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | /* * string.h -- * * Declarations of ANSI C library procedures for string handling. * * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: string.h,v 1.5.2.1 2005/05/05 17:55:18 kennykb Exp $ */ #ifndef _STRING #define _STRING #include <tcl.h> /* * The following #include is needed to define size_t. (This used to * include sys/stdtypes.h but that doesn't exist on older versions * of SunOS, e.g. 4.0.2, so I'm trying sys/types.h now.... hopefully * it exists everywhere) */ #include <sys/types.h> #ifdef __APPLE__ extern VOID * memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n)); #else extern char * memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n)); #endif extern int memcmp _ANSI_ARGS_((CONST VOID *s1, CONST VOID *s2, size_t n)); extern char * memcpy _ANSI_ARGS_((VOID *t, CONST VOID *f, size_t n)); #ifdef NO_MEMMOVE #define memmove(d, s, n) bcopy ((s), (d), (n)) #else extern char * memmove _ANSI_ARGS_((VOID *t, CONST VOID *f, |
︙ | ︙ |
Changes to compat/strstr.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * strstr.c -- * * Source code for the "strstr" library routine. * * Copyright (c) 1988-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | /* * strstr.c -- * * Source code for the "strstr" library routine. * * Copyright (c) 1988-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: strstr.c,v 1.4.2.1 2005/04/25 21:37:18 kennykb Exp $ */ #include "tcl.h" #ifndef NULL #define NULL 0 #endif /* *---------------------------------------------------------------------- * * strstr -- * * Locate the first instance of a substring in a string. |
︙ | ︙ |
Changes to compat/strtoll.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * strtoll.c -- * * Source code for the "strtoll" library procedure. * * Copyright (c) 1988 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * strtoll.c -- * * Source code for the "strtoll" library procedure. * * Copyright (c) 1988 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: strtoll.c,v 1.7.2.2 2005/01/20 19:12:26 kennykb Exp $ */ #include "tclInt.h" #include <ctype.h> #define TCL_WIDEINT_MAX (((Tcl_WideUInt)Tcl_LongAsWide(-1))>>1) |
︙ | ︙ |
Changes to compat/strtoull.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * strtoull.c -- * * Source code for the "strtoull" library procedure. * * Copyright (c) 1988 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * strtoull.c -- * * Source code for the "strtoull" library procedure. * * Copyright (c) 1988 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: strtoull.c,v 1.7.2.2 2005/01/20 19:12:27 kennykb Exp $ */ #include "tclInt.h" #include <ctype.h> /* * The table below is used to convert from ASCII digits to a |
︙ | ︙ |
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 16 17 18 | '\" '\" 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.13.2.2 2005/09/15 20:58:38 dgp Exp $ '\" .so man.macros .TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .VS 8.5 |
︙ | ︙ | |||
62 63 64 65 66 67 68 | .AP Tcl_Obj *errorObjPtr in The \fB-errorcode\fR return option will be set to this value. .AP char *element in String to record as one element of the \fB-errorcode\fR return option. Last \fIelement\fR argument must be NULL. .AP va_list argList in An argument list which must have been initialized using | | | | | 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 | .AP Tcl_Obj *errorObjPtr in The \fB-errorcode\fR return option will be set to this value. .AP char *element in String to record as one element of the \fB-errorcode\fR return option. Last \fIelement\fR argument must be NULL. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .AP "const char" *script in Pointer to first character in script containing command (must be <= command) .AP "const char" *command in Pointer to first character in command that generated the error .AP int commandLength in Number of bytes in command; -1 means use all bytes up to first null byte .BE .SH DESCRIPTION .PP .VS 8.5 The \fBTcl_SetReturnOptions\fR and \fBTcl_GetReturnOptions\fR routines expose the same capabilities as the \fBreturn\fR and \fBcatch\fR commands, respectively, in the form of a C interface. .PP \fBTcl_GetReturnOptions\fR retrieves the dictionary of return options from an interpreter following a script evaluation. Routines such as \fBTcl_Eval\fR are called to evaluate a script in an interpreter. These routines return an integer completion code. These routines also leave in the interpreter both a result and a dictionary of return options generated by script evaluation. Just as \fBTcl_GetObjResult\fR retrieves the result, \fBTcl_GetReturnOptions\fR retrieves the dictionary of return options. The integer completion code should be passed as the \fIcode\fR argument to \fBTcl_GetReturnOptions\fR so that all required options will be present in the dictionary. Specifically, a \fIcode\fR value of \fBTCL_ERROR\fR will ensure that entries for the keys \fB-errorinfo\fR, \fB-errorcode\fR, and \fB-errorline\fR will appear in the dictionary. Also, the entries for the keys \fB-code\fR and \fB-level\fR will be adjusted if necessary to agree with the value of \fIcode\fR. The \fB(Tcl_Obj *)\fR returned |
︙ | ︙ | |||
197 198 199 200 201 202 203 | The best time to call \fBTcl_AddErrorInfo\fR is just after a script evaluation routine has returned \fBTCL_ERROR\fR. The value of the \fB-errorline\fR return option (retrieved via a call to \fBTcl_GetReturnOptions\fR) often makes up a useful part of the \fImessage\fR passed to \fBTcl_AddErrorInfo\fR. .PP \fBTcl_AddObjErrorInfo\fR is nearly identical | | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 | The best time to call \fBTcl_AddErrorInfo\fR is just after a script evaluation routine has returned \fBTCL_ERROR\fR. The value of the \fB-errorline\fR return option (retrieved via a call to \fBTcl_GetReturnOptions\fR) often makes up a useful part of the \fImessage\fR passed to \fBTcl_AddErrorInfo\fR. .PP \fBTcl_AddObjErrorInfo\fR is nearly identical to \fBTcl_AddErrorInfo\fR, except that it has an additional \fIlength\fR argument. This allows the \fImessage\fR string to contain embedded null bytes. This is essentially never a good idea. If the \fImessage\fR needs to contain the null character \fBU+0000\fR, Tcl's usual internal encoding rules should be used to avoid the need for a null byte. If the \fBTcl_AddObjErrorInfo\fR interface is used at all, it should be with a negative \fIlength\fR value. .PP |
︙ | ︙ | |||
263 264 265 266 267 268 269 | corresponding return options. It has long been emphasized in this manual page that it is important to call the procedures described here rather than setting \fBerrorInfo\fR or \fBerrorCode\fR directly with \fBTcl_ObjSetVar2\fR. .PP If the procedure \fBTcl_ResetResult\fR is called, | | | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 | corresponding return options. It has long been emphasized in this manual page that it is important to call the procedures described here rather than setting \fBerrorInfo\fR or \fBerrorCode\fR directly with \fBTcl_ObjSetVar2\fR. .PP If the procedure \fBTcl_ResetResult\fR is called, it clears all of the state of the interpreter associated with script evaluation, including the entire return options dictionary. In particular, the \fB-errorinfo\fR and \fB-errorcode\fR options are reset. If an error had occurred, the \fBTcl_ResetResult\fR call will clear the error state to make it appear as if no error had occurred after all. The global variables \fBerrorInfo\fR and \fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR so they continue to hold a record of information about the most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_Interp, Tcl_ResetResult, Tcl_SetErrno .SH KEYWORDS error, object, object result, stack, trace, variable |
Changes to doc/Async.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Async.3,v 1.7.2.1 2004/12/13 22:03:09 kennykb Exp $ '\" .so man.macros .TH Tcl_AsyncCreate 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete, Tcl_AsyncReady \- handle asynchronous events .SH SYNOPSIS |
︙ | ︙ | |||
58 59 60 61 62 63 64 | allocation could have been in progress when the event occurred. The only safe approach is to set a flag indicating that the event occurred, then handle the event later when the world has returned to a clean state, such as after the current Tcl command completes. .PP \fBTcl_AsyncCreate\fR, \fBTcl_AsyncDelete\fR, and \fBTcl_AsyncReady\fR are thread sensitive. They access and/or set a thread-specific data | | | | | | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | allocation could have been in progress when the event occurred. The only safe approach is to set a flag indicating that the event occurred, then handle the event later when the world has returned to a clean state, such as after the current Tcl command completes. .PP \fBTcl_AsyncCreate\fR, \fBTcl_AsyncDelete\fR, and \fBTcl_AsyncReady\fR are thread sensitive. They access and/or set a thread-specific data structure in the event of a core built with \fI\-\-enable\-threads\fR. The token created by \fBTcl_AsyncCreate\fR contains the needed thread information it was called from so that calling \fBTcl_AsyncMark\fR(\fItoken\fR) will only yield the origin thread into the asynchronous handler. .PP \fBTcl_AsyncCreate\fR creates an asynchronous handler and returns a token for it. The asynchronous handler must be created before any occurrences of the asynchronous event that it is intended to handle (it is not safe to create a handler at the time of an event). When an asynchronous event occurs the code that detects the event |
︙ | ︙ |
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.5.2.1 2005/04/10 23:14:39 kennykb 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 |
︙ | ︙ | |||
26 27 28 29 30 31 32 | If \fIcountPtr\fR isn't NULL, \fI*countPtr\fR gets filled in with number of characters in the backslash sequence, including the backslash character. .BE .SH DESCRIPTION .PP | < < < < | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | If \fIcountPtr\fR isn't NULL, \fI*countPtr\fR gets filled in with number of characters in the backslash sequence, including the backslash character. .BE .SH DESCRIPTION .PP 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. \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. All of the sequences described in the Tcl manual entry are supported by \fBTcl_Backslash\fR. .SH "SEE ALSO" Tcl(n), Tcl_UtfBackslash(3) .SH KEYWORDS backslash, parse |
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 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 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2005. (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: BoolObj.3,v 1.5.2.2 2005/05/21 15:10:25 kennykb Exp $ '\" .so man.macros .TH Tcl_BooleanObj 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- store/retrieve boolean value in a Tcl_Obj .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewBooleanObj\fR(\fIboolValue\fR) .sp \fBTcl_SetBooleanObj\fR(\fIobjPtr, boolValue\fR) .sp int \fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, boolPtr\fR) .SH ARGUMENTS .AS Tcl_Interp boolValue in/out .AP int boolValue in Integer value to be stored as a boolean value in a Tcl_Obj. .AP Tcl_Obj *objPtr in/out Points to the Tcl_Obj in which to store, or from which to retrieve a boolean value. .AP Tcl_Interp *interp in/out If a boolean value cannot be retrieved, an error message is left in the interpreter's result object unless \fIinterp\fR is NULL. .AP int *boolPtr out Points to place where \fBTcl_GetBooleanFromObj\fR stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. .BE .SH DESCRIPTION .PP These procedures are used to pass boolean values to and from Tcl as Tcl_Obj's. When storing a boolean value into a Tcl_Obj, any non-zero integer value in \fIboolValue\fR is taken to be the boolean value \fB1\fR, and the integer value \fB0\fR is taken to be the boolean value \fB0\fR. .PP \fBTcl_NewBooleanObj\fR creates a new Tcl_Obj, stores the boolean value \fIboolValue\fR in it, and returns a pointer to the new Tcl_Obj. The new Tcl_Obj has reference count of zero. .PP \fBTcl_SetBooleanObj\fR accepts \fIobjPtr\fR, a pointer to an existing Tcl_Obj, and stores in the Tcl_Obj \fI*objPtr\fR the boolean value \fIboolValue\fR. This is a write operation on \fI*objPtr\fR, so \fIobjPtr\fR must be unshared. Attempts to write to a shared Tcl_Obj will panic. A successful write of \fIboolValue\fR into \fI*objPtr\fR implies the freeing of any former value stored in \fI*objPtr\fR. .PP \fBTcl_GetBooleanFromObj\fR attempts to retrive a boolean value from the value stored in \fI*objPtr\fR. If \fIobjPtr\fR holds a string value recognized by \fBTcl_GetBoolean\fR, then the recognized boolean value is written at the address given by \fIboolPtr\fR. If \fIobjPtr\fR holds any value recognized as a number by Tcl, then if that value is zero a 0 is written at the address given by \fIboolPtr\fR and if that value is non-zero a 1 is written at the address given by \fIboolPtr\fR. In all cases where a value is written at the address given by \fIboolPtr\fR, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR. If the value of \fIobjPtr\fR does not meet any of the conditions above, then \fBTCL_ERROR\fR is returned and an error message is left in the interpreter's result unless \fIinterp\fR is NULL. \fBTcl_GetBooleanFromObj\fR may also make changes to the internal fields of \fI*objPtr\fR so that future calls to \fBTcl_GetBooleanFromObj\fR on the same \fIobjPtr\fR can be performed more efficiently. .PP Note that the routines \fBTcl_GetBooleanFromObj\fR and \fBTcl_GetBoolean\fR are not functional equivalents. The set of values for which \fBTcl_GetBooleanFromObj\fR will return \fBTCL_OK\fR is strictly larger than the set of values for which \fBTcl_GetBoolean\fR will do the same. For example, the value "5" passed to \fBTcl_GetBooleanFromObj\fR will lead to a \fBTCL_OK\fR return (and the boolean value 1), while the same value passed to \fBTcl_GetBoolean\fR will lead to a \fBTCL_ERROR\fR return. .SH "SEE ALSO" Tcl_NewObj, Tcl_IsShared, Tcl_GetBoolean .SH KEYWORDS boolean, object |
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 | '\" '\" 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.7.2.1 2005/04/10 23:14:39 kennykb 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 |
︙ | ︙ | |||
40 41 42 43 44 45 46 | .PP \fBTcl_Concat\fR eliminates leading and trailing white space as it copies strings from \fBargv\fR to the result. If an element of \fBargv\fR consists of nothing but white space, then that string is ignored entirely. This white-space removal was added to make the output of the \fBconcat\fR command cleaner-looking. .PP | < < < | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | .PP \fBTcl_Concat\fR eliminates leading and trailing white space as it copies strings from \fBargv\fR to the result. If an element of \fBargv\fR consists of nothing but white space, then that string is ignored entirely. This white-space removal was added to make the output of the \fBconcat\fR command cleaner-looking. .PP The result string is dynamically allocated using \fBTcl_Alloc\fR; the caller must eventually release the space by calling \fBTcl_Free\fR. .SH "SEE ALSO" Tcl_ConcatObj .SH KEYWORDS concatenate, strings |
Changes to doc/CrtChannel.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" Copyright (c) 1997-2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 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 | '\" '\" 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.24.2.5 2005/10/08 13:44:37 dgp Exp $ .so man.macros .TH Tcl_CreateChannel 3 8.4 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelTruncateProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_ChannelThreadActionProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Channel \fBTcl_CreateChannel\fR(\fItypePtr, channelName, instanceData, mask\fR) .sp ClientData \fBTcl_GetChannelInstanceData\fR(\fIchannel\fR) .sp Tcl_ChannelType * \fBTcl_GetChannelType\fR(\fIchannel\fR) .sp const char * \fBTcl_GetChannelName\fR(\fIchannel\fR) .sp int \fBTcl_GetChannelHandle\fR(\fIchannel, direction, handlePtr\fR) .sp Tcl_ThreadId \fBTcl_GetChannelThread\fR(\fIchannel\fR) .sp int \fBTcl_GetChannelMode\fR(\fIchannel\fR) .sp int \fBTcl_GetChannelBufferSize\fR(\fIchannel\fR) .sp \fBTcl_SetChannelBufferSize\fR(\fIchannel, size\fR) .sp \fBTcl_NotifyChannel\fR(\fIchannel, mask\fR) .sp int \fBTcl_BadChannelOption\fR(\fIinterp, optionName, optionList\fR) .sp int \fBTcl_IsChannelShared\fR(\fIchannel\fR) .sp int \fBTcl_IsChannelRegistered\fR(\fIinterp, channel\fR) .sp int \fBTcl_IsChannelExisting\fR(\fIchannelName\fR) .sp void \fBTcl_CutChannel\fR(\fIchannel\fR) .sp void \fBTcl_SpliceChannel\fR(\fIchannel\fR) .sp void \fBTcl_ClearChannelHandlers\fR(\fIchannel\fR) .sp int \fBTcl_ChannelBuffered\fR(\fIchannel\fR) .sp const char * \fBTcl_ChannelName\fR(\fItypePtr\fR) .sp |
︙ | ︙ | |||
92 93 94 95 96 97 98 | .sp Tcl_DriverOutputProc * \fBTcl_ChannelOutputProc\fR(\fItypePtr\fR) .sp Tcl_DriverSeekProc * \fBTcl_ChannelSeekProc\fR(\fItypePtr\fR) .sp | < > > > > > > > | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | .sp Tcl_DriverOutputProc * \fBTcl_ChannelOutputProc\fR(\fItypePtr\fR) .sp Tcl_DriverSeekProc * \fBTcl_ChannelSeekProc\fR(\fItypePtr\fR) .sp Tcl_DriverWideSeekProc * \fBTcl_ChannelWideSeekProc\fR(\fItypePtr\fR) .sp Tcl_DriverThreadActionProc * \fBTcl_ChannelThreadActionProc\fR(\fItypePtr\fR) .sp .VS 8.5 Tcl_DriverTruncateProc * \fBTcl_ChannelTruncateProc\fR(\fItypePtr\fR) .VE 8.5 .sp Tcl_DriverSetOptionProc * \fBTcl_ChannelSetOptionProc\fR(\fItypePtr\fR) .sp Tcl_DriverGetOptionProc * \fBTcl_ChannelGetOptionProc\fR(\fItypePtr\fR) .sp |
︙ | ︙ | |||
231 232 233 234 235 236 237 | \fBTcl_GetChannelHandle\fR places the OS-specific device handle associated with \fIchannel\fR for the given \fIdirection\fR in the location specified by \fIhandlePtr\fR and returns \fBTCL_OK\fR. If the channel does not have a device handle for the specified direction, then \fBTCL_ERROR\fR is returned instead. Different channel drivers will return different types of handle. Refer to the manual entries for each driver to determine what type of handle is returned. | < < | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 | \fBTcl_GetChannelHandle\fR places the OS-specific device handle associated with \fIchannel\fR for the given \fIdirection\fR in the location specified by \fIhandlePtr\fR and returns \fBTCL_OK\fR. If the channel does not have a device handle for the specified direction, then \fBTCL_ERROR\fR is returned instead. Different channel drivers will return different types of handle. Refer to the manual entries for each driver to determine what type of handle is returned. .PP \fBTcl_GetChannelThread\fR returns the id of the thread currently managing the specified \fIchannel\fR. This allows channel drivers to send their file events to the correct event queue even for a multi-threaded core. .PP \fBTcl_GetChannelMode\fR returns an OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input and output. .PP \fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers allocated to store input or output in \fIchannel\fR. If the value was not set |
︙ | ︙ | |||
269 270 271 272 273 274 275 | error message. .PP \fBTcl_ChannelBuffered\fR returns the number of bytes of input currently buffered in the internal buffer (push back area) of the channel itself. It does not report about the data in the overall buffers for the stack of channels the supplied channel is part of. .PP | < > > > > > > > > > > < | 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 | error message. .PP \fBTcl_ChannelBuffered\fR returns the number of bytes of input currently buffered in the internal buffer (push back area) of the channel itself. It does not report about the data in the overall buffers for the stack of channels the supplied channel is part of. .PP \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. .VS 8.5 Also notifies the driver if the \fBTcl_ChannelType\fR version is \fBTCL_CHANNEL_VERSION_4\fR (or higher), and \fBTcl_DriverThreadActionProc\fR is defined for it. .VE 8.5 .PP \fBTcl_SpliceChannel\fR adds the specified \fIchannel\fR to the (thread)global list of all channels (of the current thread). Application to a channel registered in some interpreter is not allowed. .VS 8.5 Also notifies the driver if the \fBTcl_ChannelType\fR version is \fBTCL_CHANNEL_VERSION_4\fR (or higher), and \fBTcl_DriverThreadActionProc\fR is defined for it. .VE 8.5 .PP \fBTcl_ClearChannelHandlers\fR removes all channelhandlers and event scripts associated with the specified \fIchannel\fR, thus shutting down all event processing for this channel. .SH TCL_CHANNELTYPE .PP A channel driver provides a \fBTcl_ChannelType\fR structure that contains pointers to functions that implement the various operations on a channel; these operations are invoked as needed by the generic layer. The structure was versioned starting in Tcl 8.3.2/8.4 to correct a problem with stacked channel drivers. See the \fBOLD CHANNEL TYPES\fR section below for |
︙ | ︙ | |||
322 323 324 325 326 327 328 329 330 331 | Tcl_DriverWatchProc *\fIwatchProc\fR; Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; Tcl_DriverClose2Proc *\fIclose2Proc\fR; Tcl_DriverBlockModeProc *\fIblockModeProc\fR; Tcl_DriverFlushProc *\fIflushProc\fR; Tcl_DriverHandlerProc *\fIhandlerProc\fR; Tcl_DriverWideSeekProc *\fIwideSeekProc\fR; } Tcl_ChannelType; .CE .PP | > > > > | > | | > | | | | > | | | > | > > > | > > > > | | > | | | > | 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 | Tcl_DriverWatchProc *\fIwatchProc\fR; Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; Tcl_DriverClose2Proc *\fIclose2Proc\fR; Tcl_DriverBlockModeProc *\fIblockModeProc\fR; Tcl_DriverFlushProc *\fIflushProc\fR; Tcl_DriverHandlerProc *\fIhandlerProc\fR; Tcl_DriverWideSeekProc *\fIwideSeekProc\fR; Tcl_DriverThreadActionProc *\fIthreadActionProc\fR; .VS 8.5 Tcl_DriverTruncateProc *\fItruncateProc\fR; .VE 8.5 } Tcl_ChannelType; .CE .PP It is not necessary to provide implementations for all channel operations. Those which are not necessary may be set to NULL in the struct: \fIblockModeProc\fR, \fIseekProc\fR, \fIsetOptionProc\fR, \fIgetOptionProc\fR, and \fIclose2Proc\fR, in addition to \fIflushProc\fR, \fIhandlerProc\fR, \fIthreadActionProc\fR, and \fItruncateProc\fR. Other functions that cannot be implemented in a meaningful way should return \fBEINVAL\fR when called, to indicate that the operations they represent are not available. Also note that \fIwideSeekProc\fR can be NULL if \fIseekProc\fR is. .PP The user should only use the above structure for \fBTcl_ChannelType\fR instantiation. When referencing fields in a \fBTcl_ChannelType\fR structure, the following functions should be used to obtain the values: \fBTcl_ChannelName\fR, \fBTcl_ChannelVersion\fR, \fBTcl_ChannelBlockModeProc\fR, \fBTcl_ChannelCloseProc\fR, \fBTcl_ChannelClose2Proc\fR, \fBTcl_ChannelInputProc\fR, \fBTcl_ChannelOutputProc\fR, \fBTcl_ChannelSeekProc\fR, \fBTcl_ChannelWideSeekProc\fR, \fBTcl_ChannelThreadActionProc\fR, .VS 8.5 \fBTcl_ChannelTruncateProc\fR, .VE 8.5 \fBTcl_ChannelSetOptionProc\fR, \fBTcl_ChannelGetOptionProc\fR, \fBTcl_ChannelWatchProc\fR, \fBTcl_ChannelGetHandleProc\fR, \fBTcl_ChannelFlushProc\fR, or \fBTcl_ChannelHandlerProc\fR. .PP The change to the structures was made in such a way that standard channel types are binary compatible. However, channel types that use stacked channels (i.e. TLS, Trf) have new versions to correspond to the above change since the previous code for stacked channels had problems. .SS TYPENAME .PP The \fItypeName\fR field contains a null-terminated string that identifies the type of the device implemented by this driver, e.g. \fBfile\fR or \fBsocket\fR. .PP This value can be retrieved with \fBTcl_ChannelName\fR, which returns a pointer to the string. .SS VERSION .PP The \fIversion\fR field should be set to the version of the structure that you require. \fBTCL_CHANNEL_VERSION_2\fR is the minimum recommended. \fBTCL_CHANNEL_VERSION_3\fR must be set to specifiy the \fIwideSeekProc\fR member. .VS 8.5 \fBTCL_CHANNEL_VERSION_4\fR must be set to specifiy the \fIthreadActionProc\fR and \fItruncateProc\fR members (includes \fIwideSeekProc\fR). .VE 8.5 If it is not set to any of these, then this \fBTcl_ChannelType\fR is assumed to have the original structure. See \fBOLD CHANNEL TYPES\fR for more details. While Tcl will recognize and function with either structures, stacked channels must be of at least \fBTCL_CHANNEL_VERSION_2\fR to function correctly. .PP This value can be retrieved with \fBTcl_ChannelVersion\fR, which returns one of .VS 8.5 \fBTCL_CHANNEL_VERSION_4\fR, .VE 8.5 \fBTCL_CHANNEL_VERSION_3\fR, \fBTCL_CHANNEL_VERSION_2\fR or \fBTCL_CHANNEL_VERSION_1\fR. .SS BLOCKMODEPROC .PP The \fIblockModeProc\fR field contains the address of a function called by the generic layer to set blocking and nonblocking mode on the device. \fIBlockModeProc\fR should match the following prototype: .PP |
︙ | ︙ | |||
572 573 574 575 576 577 578 | function should set this variable to a POSIX error code if an error occurs. The function should store an \fBEINVAL\fR error code if the channel type does not implement seeking. .PP The return value is the new access point or -1 in case of error. If an error occurred, the function should not move the access point. .PP | < | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 | function should set this variable to a POSIX error code if an error occurs. The function should store an \fBEINVAL\fR error code if the channel type does not implement seeking. .PP The return value is the new access point or -1 in case of error. If an error occurred, the function should not move the access point. .PP If there is a non-NULL \fIseekProc\fR field, the \fIwideSeekProc\fR field may contain the address of an alternative function to use which handles wide (i.e. larger than 32-bit) offsets, so allowing seeks within files larger than 2GB. The \fIwideSeekProc\fR will be called in preference to the \fIseekProc\fR, but both must be defined if the \fIwideSeekProc\fR is defined. \fIWideSeekProc\fR must match the following prototype: |
︙ | ︙ | |||
597 598 599 600 601 602 603 | \fIseekProc\fR above, except that the type of offsets and the return type are different. .PP The \fIseekProc\fR value can be retrieved with \fBTcl_ChannelSeekProc\fR, which returns a pointer to the function, and similarly the \fIwideSeekProc\fR can be retrieved with \fBTcl_ChannelWideSeekProc\fR. | < | 621 622 623 624 625 626 627 628 629 630 631 632 633 634 | \fIseekProc\fR above, except that the type of offsets and the return type are different. .PP The \fIseekProc\fR value can be retrieved with \fBTcl_ChannelSeekProc\fR, which returns a pointer to the function, and similarly the \fIwideSeekProc\fR can be retrieved with \fBTcl_ChannelWideSeekProc\fR. .SS SETOPTIONPROC .PP The \fIsetOptionProc\fR field contains the address of a function called by the generic layer to set a channel type specific option on a channel. \fIsetOptionProc\fR must match the following prototype: .PP .CS |
︙ | ︙ | |||
771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 | \fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR when this channel was created. The \fIinterestMask\fR is an OR-ed combination of \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR; it indicates what type of event occurred on this channel. .PP This value can be retrieved with \fBTcl_ChannelHandlerProc\fR, which returns a pointer to the function. .SH TCL_BADCHANNELOPTION .PP This procedure generates a "bad option" error message in an (optional) interpreter. It is used by channel drivers when an invalid Set/Get option is requested. Its purpose is to concatenate the generic options list to the specific ones and factorize the generic options error message string. .PP | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 | \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. .SS "THREADACTIONPROC" .PP The \fIthreadActionProc\fR field contains the address of the function called by the generic layer when a channel is created, closed, or going to move to a different thread, i.e. whenever thread-specific driver state might have to initialized or updated. It can be NULL. The action \fITCL_CHANNEL_THREAD_REMOVE\fR is used to notify the driver that it should update or remove any thread-specific data it might be maintaining for the channel. .PP The action \fITCL_CHANNEL_THREAD_INSERT\fR is used to notify the driver that it should update or initialize any thread-specific data it might be maintaining using the calling thread as the associate. See \fBTcl_CutChannel\fR and \fBTcl_SpliceChannel\fR for more detail. .PP .CS typedef void Tcl_DriverThreadActionProc( ClientData \fIinstanceData\fR, int \fIaction\fR); .CE .PP \fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR when this channel was created. .PP These values can be retrieved with \fBTcl_ChannelThreadActionProc\fR, which returns a pointer to the function. .SS "TRUNCATEPROC" .PP The \fItruncateProc\fR field contains the address of the function called by the generic layer when a channel is truncated to some length. It can be NULL. .PP .CS typedef int Tcl_DriverTruncateProc( ClientData \fIinstanceData\fR, Tcl_WideInt \fIlength\fR); .CE .PP \fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR when this channel was created, and \fIlength\fR is the new length of the underlying file, which should not be negative. The result should be 0 on success or an errno code (suitable for use with \fBTcl_SetErrno\fR) on failure. .PP These values can be retrieved with \fBTcl_ChannelTruncateProc\fR, which returns a pointer to the function. .SH TCL_BADCHANNELOPTION .PP This procedure generates a "bad option" error message in an (optional) interpreter. It is used by channel drivers when an invalid Set/Get option is requested. Its purpose is to concatenate the generic options list to the specific ones and factorize the generic options error message string. .PP It always returns \fBTCL_ERROR\fR .PP An error message is generated in \fIinterp\fR's result object to indicate that a command was invoked with a bad option. The message has the form .CS bad option "blah": should be one of <...generic options...>+<...specific options...> |
︙ | ︙ | |||
826 827 828 829 830 831 832 | .PP It is still possible to create channel with the above structure. The internal channel code will determine the version. It is imperative to use the new \fBTcl_ChannelType\fR structure if you are creating a stacked channel driver, due to problems with the earlier stacked channel implementation (in 8.2.0 to 8.3.1). .PP | < > < | 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 | .PP It is still possible to create channel with the above structure. The internal channel code will determine the version. It is imperative to use the new \fBTcl_ChannelType\fR structure if you are creating a stacked channel driver, due to problems with the earlier stacked channel implementation (in 8.2.0 to 8.3.1). .PP Prior to 8.4.0 (i.e. during the later releases of 8.3 and early part of the 8.4 development cycle) the \fBTcl_ChannelType\fR structure contained the following fields: .PP .CS typedef struct Tcl_ChannelType { char *\fItypeName\fR; Tcl_ChannelTypeVersion \fIversion\fR; Tcl_DriverCloseProc *\fIcloseProc\fR; Tcl_DriverInputProc *\fIinputProc\fR; Tcl_DriverOutputProc *\fIoutputProc\fR; Tcl_DriverSeekProc *\fIseekProc\fR; Tcl_DriverSetOptionProc *\fIsetOptionProc\fR; Tcl_DriverGetOptionProc *\fIgetOptionProc\fR; Tcl_DriverWatchProc *\fIwatchProc\fR; Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; Tcl_DriverClose2Proc *\fIclose2Proc\fR; Tcl_DriverBlockModeProc *\fIblockModeProc\fR; Tcl_DriverFlushProc *\fIflushProc\fR; Tcl_DriverHandlerProc *\fIhandlerProc\fR; Tcl_DriverTruncateProc *\fItruncateProc\fR; } Tcl_ChannelType; .CE .PP When the above structure is registered as a channel type, the \fIversion\fR field should always be \fBTCL_CHANNEL_VERSION_2\fR. .SH "SEE ALSO" Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3), Tcl_QueueEvent(3), Tcl_StackChannel(3), Tcl_GetStdChannel(3) .SH KEYWORDS blocking, channel driver, channel registration, channel type, nonblocking |
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.10.2.1 2005/04/10 23:14:40 kennykb Exp $ '\" .so man.macros .TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateCommand \- implement new commands in C .SH SYNOPSIS |
︙ | ︙ | |||
91 92 93 94 95 96 97 | data structure that describes what to do when the command procedure is invoked. \fIArgc\fR and \fIargv\fR describe the arguments to the command, \fIargc\fR giving the number of arguments (including the command name) and \fIargv\fR giving the values of the arguments as strings. The \fIargv\fR array will contain \fIargc\fR+1 values; the first \fIargc\fR values point to the argument strings, and the last value is NULL. | < < < < | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | data structure that describes what to do when the command procedure is invoked. \fIArgc\fR and \fIargv\fR describe the arguments to the command, \fIargc\fR giving the number of arguments (including the command name) and \fIargv\fR giving the values of the arguments as strings. The \fIargv\fR array will contain \fIargc\fR+1 values; the first \fIargc\fR values point to the argument strings, and the last value is NULL. Note that the argument strings should not be modified as they may point to constant strings or may be shared with other parts of the interpreter. .PP Note that the argument strings are encoded in normalized UTF-8 since version 8.1 of Tcl. .PP \fIProc\fR must return an integer code that is expected to be one of \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page for details on what these codes mean. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, \fIproc\fR must set the interpreter result to point to a string value; |
︙ | ︙ |
Changes to doc/CrtFileHdlr.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1990-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 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | '\" '\" Copyright (c) 1990-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: CrtFileHdlr.3,v 1.3.2.1 2005/04/10 23:14:41 kennykb Exp $ '\" .so man.macros .TH Tcl_CreateFileHandler 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateFileHandler, Tcl_DeleteFileHandler \- associate procedure callbacks with files or devices (Unix only) .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_CreateFileHandler\fR(\fIfd, mask, proc, clientData\fR) .sp \fBTcl_DeleteFileHandler\fR(\fIfd\fR) .SH ARGUMENTS .AS Tcl_FileProc clientData .AP int fd in Unix file descriptor for an open file or device. .AP int mask in Conditions under which \fIproc\fR should be called: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR, and \fBTCL_EXCEPTION\fR. May be set to 0 to temporarily disable a handler. .AP Tcl_FileProc *proc in Procedure to invoke whenever the file or device indicated by \fIfile\fR meets the conditions specified by \fImask\fR. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP \fBTcl_CreateFileHandler\fR arranges for \fIproc\fR to be invoked in the future whenever I/O becomes possible on a file or an exceptional condition exists for the file. The file is indicated by \fIfd\fR, and the conditions of interest are indicated by \fImask\fR. For example, if \fImask\fR is \fBTCL_READABLE\fR, \fIproc\fR will be called when the file is readable. The callback to \fIproc\fR is made by \fBTcl_DoOneEvent\fR, so \fBTcl_CreateFileHandler\fR is only useful in programs that dispatch events through \fBTcl_DoOneEvent\fR or through Tcl commands such as \fBvwait\fR. |
︙ | ︙ | |||
85 86 87 88 89 90 91 | correctly, the application may need to use non-blocking I/O operations on the files for which handlers are declared. Otherwise the application may block if it reads or writes too much data; while waiting for the I/O to complete the application won't be able to service other events. Use \fBTcl_SetChannelOption\fR with \fB\-blocking\fR to set the channel into blocking or nonblocking mode as required. .PP | < < | 81 82 83 84 85 86 87 88 89 90 91 92 | correctly, the application may need to use non-blocking I/O operations on the files for which handlers are declared. Otherwise the application may block if it reads or writes too much data; while waiting for the I/O to complete the application won't be able to service other events. Use \fBTcl_SetChannelOption\fR with \fB\-blocking\fR to set the channel into blocking or nonblocking mode as required. .PP Note that these interfaces are only supported by the Unix implementation of the Tcl notifier. .SH KEYWORDS callback, file, handler |
Changes to doc/CrtMathFnc.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: CrtMathFnc.3,v 1.11.2.2 2005/04/25 19:59:45 kennykb Exp $ '\" .so man.macros .TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void \fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) .sp int \fBTcl_GetMathFuncInfo\fR(\fIinterp, name, numArgsPtr, argTypesPtr, procPtr, clientDataPtr\fR) .sp Tcl_Obj * \fBTcl_ListMathFuncs\fR(\fIinterp, pattern\fR) .SH ARGUMENTS .AS Tcl_ValueType *clientDataPtr out .AP Tcl_Interp *interp in Interpreter in which new function will be defined. .AP "const char" *name in Name for new function. .AP int numArgs in |
︙ | ︙ | |||
62 63 64 65 66 67 68 | passing to \fITcl_StringMatch\fR), or NULL to not apply any filter. .BE .SH DESCRIPTION .PP Tcl allows a number of mathematical functions to be used in expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR. | > > | > > > > > | > | < < < < < < < < < | > | | | > > > < | | 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 | passing to \fITcl_StringMatch\fR), or NULL to not apply any filter. .BE .SH DESCRIPTION .PP Tcl allows a number of mathematical functions to be used in expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR. These functions are represented by commands in the namespace, \fBtcl::mathfunc\fR. The \fBTcl_CreateMathFunc\fR function is an obsolete way for applications to add additional functions to those already provided by Tcl or to replace existing functions. It should not be used by new applications, which should create math functions using \fBTcl_CreateObjCommand\fR to create a command in the \fBtcl::mathfunc\fR namespace. .PP In the \fBTcl_CreateMathFunc\fR interface, \fIName\fR is the name of the function as it will appear in expressions. If \fIname\fR doesn't already exist in the \fB::tcl::mathfunc\fR namespace, then a new command is created in that namespace. If \fIname\fR does exist, then the existing function is replaced. \fINumArgs\fR and \fIargTypes\fR describe the arguments to the function. Each entry in the \fIargTypes\fR array must be one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR, \fBTCL_WIDE_INT\fR, or \fBTCL_EITHER\fR to indicate whether the corresponding argument must be an integer, a double-precision floating value, a wide (64-bit) integer, or any, respectively. .PP Whenever the function is invoked in an expression Tcl will invoke \fIproc\fR. \fIProc\fR should have arguments and result that match the type \fBTcl_MathProc\fR: .CS typedef int Tcl_MathProc( ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, Tcl_Value *\fIargs\fR, Tcl_Value *\fIresultPtr\fR); .CE .PP When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR arguments will be the same as those passed to \fBTcl_CreateMathFunc\fR. \fIArgs\fR will point to an array of \fInumArgs\fR Tcl_Value structures, which describe the actual arguments to the function: .CS typedef struct Tcl_Value { Tcl_ValueType \fItype\fR; long \fIintValue\fR; double \fIdoubleValue\fR; Tcl_WideInt \fIwideValue\fR; } Tcl_Value; .CE .PP The \fItype\fR field indicates the type of the argument and is one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR. It will match the \fIargTypes\fR value specified for the function unless the \fIargTypes\fR value was \fBTCL_EITHER\fR. Tcl converts the argument supplied in the expression to the type requested in \fIargTypes\fR, if that is necessary. Depending on the value of the \fItype\fR field, the \fIintValue\fR, \fIdoubleValue\fR or \fIwideValue\fR field will contain the actual value of the argument. .PP \fIProc\fR should compute its result and store it either as an integer in \fIresultPtr->intValue\fR or as a floating value in \fIresultPtr->doubleValue\fR. It should set also \fIresultPtr->type\fR to one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR to indicate which value was set. Under normal circumstances \fIproc\fR should return \fBTCL_OK\fR. If an error occurs while executing the function, \fIproc\fR should return \fBTCL_ERROR\fR and leave an error message in the interpreter's result. .PP \fBTcl_GetMathFuncInfo\fR retrieves the values associated with function \fIname\fR that were passed to a preceding \fBTcl_CreateMathFunc\fR call. Normally, the return code is \fBTCL_OK\fR but if the named function does not exist, \fBTCL_ERROR\fR is returned and an error message is placed in the interpreter's result. .PP If an error did not occur, the array reference placed in the variable pointed to by \fIargTypesPtr\fR is newly allocated, and should be released by passing it to \fBTcl_Free\fR. Some functions (the standard set implemented in the core, and those defined by placing commands in the \fBtcl::mathfunc\fR namespace) do not have argument type information; attempting to retrieve values for them causes a NULL to be stored in the variable pointed to by \fIprocPtr\fR and the variable pointed to by \fIclientDataPtr\fR will not be modified. The variable pointed to by \fInumArgsPointer\fR will contain -1, and no argument types will be stored in the variable pointed to by \fIargTypesPointer\fR. .PP \fBTcl_ListMathFuncs\fR returns a Tcl object containing a list of all the math functions defined in the interpreter whose name matches \fIpattern\fR. In the case of an error, NULL is returned and an error message is left in the interpreter result, and otherwise the returned object will have a reference count of zero. .SH KEYWORDS expression, mathematical function .SH "SEE ALSO" expr(n), info(n), Tcl_CreateObjCommand(3), Tcl_Free(3), Tcl_NewListObj(3) |
Changes to doc/CrtObjCmd.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: CrtObjCmd.3,v 1.11.2.1 2005/04/10 23:14:41 kennykb Exp $ '\" .so man.macros .TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C .SH SYNOPSIS |
︙ | ︙ | |||
26 27 28 29 30 31 32 | .sp int \fBTcl_GetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR) .sp int \fBTcl_SetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR) .sp | < < < < | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | .sp int \fBTcl_GetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR) .sp int \fBTcl_SetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR) .sp int \fBTcl_GetCommandInfoFromToken\fR(\fItoken, infoPtr\fR) .sp int \fBTcl_SetCommandInfoFromToken\fR(\fItoken, infoPtr\fR) .sp const char * \fBTcl_GetCommandName\fR(\fIinterp, token\fR) .sp void \fBTcl_GetCommandFullName\fR(\fIinterp, token, objPtr\fR) .sp Tcl_Command \fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR) |
︙ | ︙ | |||
95 96 97 98 99 100 101 | \fIproc\fR should have arguments and result that match the type \fBTcl_ObjCmdProc\fR: .CS typedef int Tcl_ObjCmdProc( ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIobjc\fR, | < | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 | \fIproc\fR should have arguments and result that match the type \fBTcl_ObjCmdProc\fR: .CS typedef int Tcl_ObjCmdProc( ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIobjc\fR, Tcl_Obj *const \fIobjv\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_CreateObjCommand\fR. Typically, \fIclientData\fR points to an application-specific data structure that describes what to do when the command procedure is invoked. \fIObjc\fR and \fIobjv\fR describe the |
︙ | ︙ | |||
121 122 123 124 125 126 127 | compilers to report any such attempted assignment as an error. However, it is acceptable to modify the internal representation of any individual object argument. For instance, the user may call \fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer representation of that object; that call may change the type of the object that \fIobjv\fR[\fB2\fR] points at, but will not change where \fIobjv\fR[\fB2\fR] points. | < | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | compilers to report any such attempted assignment as an error. However, it is acceptable to modify the internal representation of any individual object argument. For instance, the user may call \fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer representation of that object; that call may change the type of the object that \fIobjv\fR[\fB2\fR] points at, but will not change where \fIobjv\fR[\fB2\fR] points. .PP \fIproc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page for details on what these codes mean. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, if \fIproc\fR needs to return a non-empty result, |
︙ | ︙ |
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.14.2.1 2005/03/09 15:57:15 kennykb 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 |
︙ | ︙ | |||
75 76 77 78 79 80 81 | .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. | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | .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_Obj **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 |
︙ | ︙ |
Changes to doc/DString.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 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. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: DString.3,v 1.11.2.1 2005/05/05 17:55:20 kennykb Exp $ '\" .so man.macros .TH Tcl_DString 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_DStringInit\fR(\fIdsPtr\fR) .sp char * \fBTcl_DStringAppend\fR(\fIdsPtr, bytes, length\fR) .sp char * \fBTcl_DStringAppendElement\fR(\fIdsPtr, element\fR) .sp \fBTcl_DStringStartSublist\fR(\fIdsPtr\fR) .sp \fBTcl_DStringEndSublist\fR(\fIdsPtr\fR) .sp int \fBTcl_DStringLength\fR(\fIdsPtr\fR) |
︙ | ︙ | |||
43 44 45 46 47 48 49 | \fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) .sp \fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR) .SH ARGUMENTS .AS Tcl_DString newLength in/out .AP Tcl_DString *dsPtr in/out Pointer to structure that is used to manage a dynamic string. | | | > > | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | \fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) .sp \fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR) .SH ARGUMENTS .AS Tcl_DString newLength in/out .AP Tcl_DString *dsPtr in/out Pointer to structure that is used to manage a dynamic string. .AP "const char" *bytes in Pointer to characters to append to dynamic string. .AP "const char" *element in Pointer to characters to append as list element to dynamic string. .AP int length in Number of bytes from \fIbytes\fR to add to dynamic string. If -1, add all characters up to null terminating character. .AP int newLength in New length for dynamic string, not including null terminating character. .AP Tcl_Interp *interp in/out Interpreter whose result is to be set from or moved to the dynamic string. |
︙ | ︙ | |||
73 74 75 76 77 78 79 | anything already in it is discarded. If the structure has been used previously, \fBTcl_DStringFree\fR should be called first to free up any memory allocated for the old string. .PP \fBTcl_DStringAppend\fR adds new information to a dynamic string, allocating more memory for the string if needed. | | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | anything already in it is discarded. If the structure has been used previously, \fBTcl_DStringFree\fR should be called first to free up any memory allocated for the old string. .PP \fBTcl_DStringAppend\fR adds new information to a dynamic string, allocating more memory for the string if needed. If \fIlength\fR is less than zero then everything in \fIbytes\fR is appended to the dynamic string; otherwise \fIlength\fR specifies the number of bytes to append. \fBTcl_DStringAppend\fR returns a pointer to the characters of the new string. The string can also be retrieved from the \fIstring\fR field of the Tcl_DString structure. .PP \fBTcl_DStringAppendElement\fR is similar to \fBTcl_DStringAppend\fR except that it doesn't take a \fIlength\fR argument (it appends all of \fIelement\fR) and it converts the string to a proper list element before appending. \fBTcl_DStringAppendElement\fR adds a separator space before the new list element unless the new list element is the first in a list or sub-list (i.e. either the current string is empty, or it contains the single character ``{'', or the last two characters of the current string are `` {''). \fBTcl_DStringAppendElement\fR returns a pointer to the |
︙ | ︙ |
Added doc/Ensemble.3.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | '\" '\" Copyright (c) 2005 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Ensemble.3,v 1.1.2.1 2005/01/20 19:12:28 kennykb Exp $ '\" '\" This documents the C API introduced in TIP#235 '\" .so man.macros .TH Tcl_Ensemble 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateEnsemble, Tcl_FindEnsemble, Tcl_GetEnsembleFlags, Tcl_GetEnsembleMappingDict, Tcl_GetEnsembleNamespace, Tcl_GetEnsembleUnknownHandler, Tcl_GetEnsmelbeSubcommandList, Tcl_IsEnsemble, Tcl_SetEnsembleFlags, Tcl_SetEnsembleMappingDict, Tcl_SetEnsembleSubcommandList, Tcl_SetEnsembleUnknownHandler \- manipulate ensemble commands .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Command \fBTcl_CreateEnsemble\fR(\fIinterp, name, namespacePtr, ensFlags\fR) .sp Tcl_Command \fBTcl_FindEnsemble\fR(\fIinterp, cmdNameObj, flags\fR) .sp int \fBTcl_IsEnsemble\fR(\fItoken\fR) .sp int \fBTcl_GetEnsembleFlags\fR(\fIinterp, token, ensFlagsPtr\fR) .sp int \fBTcl_SetEnsembleFlags\fR(\fIinterp, token, ensFlags\fR) .sp int \fBTcl_GetEnsembleMappingDict\fR(\fIinterp, token, dictObjPtr\fR) .sp int \fBTcl_SetEnsembleMappingDict\fR(\fIinterp, token, dictObj\fR) .sp int \fBTcl_GetEnsembleSubcommandList\fR(\fIinterp, token, listObjPtr\fR) .sp int \fBTcl_SetEnsembleSubcommandList\fR(\fIinterp, token, listObj\fR) .sp int \fBTcl_GetEnsembleUnknownHandler\fR(\fIinterp, token, listObjPtr\fR) .sp int \fBTcl_SetEnsembleUnknownHandler\fR(\fIinterp, token, listObj\fR) .sp int \fBTcl_GetEnsembleNamespace\fR(\fIinterp, token, namespacePtrPtr\fR) .SH ARGUMENTS .AS Tcl_Namespace **namespacePtrPtr in/out .AP Tcl_Interp *interp in/out The interpreter in which the ensemble is to be created or found. Also where error result messages are written. .AP "const char" *name in The name of the ensemble command to be created. .AP Tcl_Namespace *namespacePtr in The namespace to which the ensemble command is to be bound, or NULL for the current namespace. .AP int ensFlags in An ORed set of flag bits describing the basic configuration of the ensemble. Currently only one bit has meaning, TCL_ENSEMBLE_PREFIX, which is present when the ensemble command should also match unambiguous prefixes of subcommands. .AP Tcl_Obj *cmdNameObj in A value holding the name of the ensemble command to look up. .AP int flags in An ORed set of flag bits controlling the behavior of \fBTcl_FindEnsemble\fR. Currently only TCL_LEAVE_ERR_MSG is supported. .AP Tcl_Command token in A normal command token that refers to an ensemble command, or which you wish to use for testing as an ensemble command in \fBTcl_IsEnsemble\fR. .AP int *ensFlagsPtr out Pointer to a variable into which to write the current ensemble flag bits; currently only the bit TCL_ENSEMBLE_PREFIX is defined. .AP Tcl_Obj *dictObj in A dictionary value to use for the subcommand to implementation command prefix mapping dictionary in the ensemble. May be NULL if the mapping dictionary is to be removed. .AP Tcl_Obj **dictObjPtr out Pointer to a variable into which to write the current ensemble mapping dictionary. .AP Tcl_Obj *listObj in A list value to use for the defined list of subcommands in the dictionary or the unknown subcommmand handler command prefix. May be NULL if the subcommand list or unknown handler are to be removed. .AP Tcl_Obj **listObjPtr out Pointer to a variable into which to write the current defiend list of subcommands or the current unknown handler prefix. .AP Tcl_Namespace **namespacePtrPtr out Pointer to a variable into which to write the handle of the namespace to which the ensemble is bound. .BE .SH DESCRIPTION An ensemble is a command, bound to some namespace, which consists of a collection of subcommands implemented by other Tcl commands. The first argument to the ensemble command is always interpreted as a selector that states what subcommand to execute. .PP Ensembles are created using \fBTcl_CreateEnsemble\fR, which takes four arguments: the interpreter to work within, the name of the ensemble to create, the namespace within the interpreter to bind the ensemble to, and the default set of ensemble flags. The result of the function is the command token for the ensemble, which may be used to further configure the ensemble using the API descibed below in \fBENSEMBLE PROPERTIES\fR. .PP Given the name of an ensemble command, the token for that command may be retrieved using \fBTcl_FindEnsemble\fR. If the given command name (in \fIcmdNameObj\fR) does not refer to an ensemble command, the result of the function is NULL and (if the TCL_LEAVE_ERR_MSG bit is set in \fIflags\fR) an error message is left in the interpreter result. .PP A command token may be checked to see if it refers to an ensemble using \fBTcl_IsEnsemble\fR. This returns 1 if the token refers to an ensemble, or 0 otherwise. .SS "ENSEMBLE PROPERTIES" Every ensemble has four read-write properties and a read-only property. The properties are: .TP \fBflags\fR (read-write) The set of flags for the ensemble, expressed as a bit-field. Currently, the only public flag is TCL_ENSEMBLE_PREFIX which is set when unambiguous prefixes of subcommands are permitted to be resolved to implementations as well as exact matches. The flags may be read and written using \fBTcl_GetEnsembleFlags\fR and \fBTcl_SetEnsembleFlags\fR respectively. The result of both of those functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does not refer to an ensemble). .TP \fBmapping dictionary\fR (read-write) A dictionary containing a mapping from subcommand names to lists of words to use as a command prefix (replacing the first two words of the command which are the ensemble command itself and the subcommand name), or NULL if every subcommand is to be mapped to the command with the same unqualified name in the ensemble's bound namespace. Defaults to NULL. May be read and written using \fBTcl_GetEnsembleMappingDict\fR and \fBTcl_SetEnsembleMappingDict\fR respectively. The result of both of those functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does not refer to an ensemble) and the dictionary obtained from \fBTcl_GetEnsembleMappingDict\fR should always be treated as immutable even if it is unshared. .TP \fBsubcommand list\fR (read-write) A list of all the subcommand names for the ensemble, or NULL if this is to be derived from either the keys of the mapping dictionary (see above) or (if that is also NULL) from the set of commands exported by the bound namespace. May be read and written using \fBTcl_GetEnsembleSubcommandList\fR and \fBTcl_SetEnsembleSubcommandList\fR respectively. The result of both of those functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does not refer to an ensemble) and the list obtained from \fBTcl_GetEnsembleSubcommandList\fR should alays be treated as immutable even if it is unshared. .TP \fBunknown subcommand handler command prefix\fR (read-write) A list of words to prepend on the front of any subcommand when the subcommand is unknown to the ensemble (according to the current prefix handling rule); see the \fBnamespace ensemble\fR command for more details. If NULL, the default behavior \- generate a suitable error message \- will be used when an unknown subcommand is encountered. May be read and written using \fBTcl_GetEnsembleUnknownHandler\fR and \fBTcl_SetEnsembleUnknownHandler\fR respectively. The result of both functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does not refer to an ensemble) and the list obtained from \fBTcl_GetEnsembleUnknownHandler\fR should always be treated as immutable even if it is unshared. .TP \fBbound namespace\fR (read-only) The namespace to which the ensemble is bound; when the namespace is deleted, so too will the ensemble, and this namespace is also the namespace whose list of exported commands is used if both the mapping dictionary and the subcommand list properties are NULL. May be read using \fBTcl_GetEnsembleNamespace\fR which returns a Tcl result code (TCL_OK, or TCL_ERROR if the token does not refer to an ensemble). .SH "SEE ALSO" namespace(n), Tcl_DeleteCommandFromToken(3) |
Changes to doc/Environment.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Environment.3,v 1.4.2.1 2005/05/05 17:55:20 kennykb Exp $ '\" .so man.macros .TH Tcl_PutEnv 3 "7.5" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_PutEnv \- procedures to manipulate the environment .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_PutEnv\fR(\fIassignment\fR) .SH ARGUMENTS .AS "const char" *assignment .AP "const char" *assignnment in Info about environment variable in the format NAME=value. The \fIassignment\fR argument is in the system encoding. .BE .SH DESCRIPTION .PP \fBTcl_PutEnv\fR sets an environment variable. The information is passed in a single string of the form NAME=value. This procedure is intended to be a stand-in for the UNIX \fBputenv\fR system call. All |
︙ | ︙ |
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.18.2.3 2005/09/15 20:58:38 dgp Exp $ '\" .so man.macros .TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts .SH SYNOPSIS |
︙ | ︙ | |||
35 36 37 38 39 40 41 | int \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | int \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_VarEval\fR(\fIinterp, part, part, ... \fB(char *) NULL\fR) .sp int \fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is |
︙ | ︙ | |||
63 64 65 66 67 68 69 | 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). | | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | 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 *part in String forming part of a Tcl script. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .BE .SH DESCRIPTION .PP The procedures described here are invoked to execute Tcl scripts in various forms. \fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others. |
︙ | ︙ | |||
96 97 98 99 100 101 102 | result; it can be retrieved using \fBTcl_GetObjResult\fR. .PP \fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates its contents as a Tcl script. It returns the same information as \fBTcl_EvalObjEx\fR. If the file couldn't be read then a Tcl error is returned to describe why the file couldn't be read. | < < | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 | result; it can be retrieved using \fBTcl_GetObjResult\fR. .PP \fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates its contents as a Tcl script. It returns the same information as \fBTcl_EvalObjEx\fR. If the file couldn't be read then a Tcl error is returned to describe why the file couldn't be read. The eofchar for files is '\\32' (^Z) for all platforms. If you require a ``^Z'' in code for string comparison, you can use ``\\032'' or ``\\u001a'', which will be safely substituted by the Tcl interpreter into ``^Z''. .PP \fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a script. The \fIobjc\fR and \fIobjv\fR arguments contain the values of the words for the Tcl command, one word in each object in \fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns a completion code and result just like \fBTcl_EvalObjEx\fR. .PP |
︙ | ︙ |
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 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | '\" '\" Copyright (c) 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.9.2.1 2005/05/05 17:55:21 kennykb 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 .nf \fB#include <tcl.h>\fR .sp int \fBTcl_ExprLong\fR(\fIinterp, expr, longPtr\fR) .sp int \fBTcl_ExprDouble\fR(\fIinterp, expr, doublePtr\fR) .sp int \fBTcl_ExprBoolean\fR(\fIinterp, expr, booleanPtr\fR) .sp int \fBTcl_ExprString\fR(\fIinterp, expr\fR) .SH ARGUMENTS .AS Tcl_Interp *booleanPtr out .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIexpr\fR. .AP "const char" *expr in 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 Pointer to location in which to store the 0/1 boolean value of the expression. .BE .SH DESCRIPTION .PP These four procedures all evaluate the expression given by the \fIexpr\fR argument and return the result in one of four different forms. The expression can have any of the forms accepted by the \fBexpr\fR command. Note that these procedures have been largely replaced by the object-based procedures \fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR, \fBTcl_ExprBooleanObj\fR, and \fBTcl_ExprObj\fR. Those object-based procedures evaluate an expression held in a Tcl object instead of a string. |
︙ | ︙ | |||
92 93 94 95 96 97 98 | the value was zero and 1 otherwise. If the expression's actual value is a non-numeric string then it must be one of the values accepted by \fBTcl_GetBoolean\fR such as ``yes'' or ``no'', or else an error occurs. .PP \fBTcl_ExprString\fR returns the value of the expression as a string stored in the interpreter's result. | < < < < < < | 92 93 94 95 96 97 98 99 100 101 102 103 104 | the value was zero and 1 otherwise. If the expression's actual value is a non-numeric string then it must be one of the values accepted by \fBTcl_GetBoolean\fR such as ``yes'' or ``no'', or else an error occurs. .PP \fBTcl_ExprString\fR returns the value of the expression as a string stored in the interpreter's result. .SH "SEE ALSO" Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj .SH KEYWORDS boolean, double, evaluate, expression, integer, object, string |
Changes to doc/ExprLongObj.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: ExprLongObj.3,v 1.3.16.1 2005/05/05 17:55:21 kennykb Exp $ '\" .so man.macros .TH Tcl_ExprLongObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj \- evaluate an expression .SH SYNOPSIS |
︙ | ︙ | |||
25 26 27 28 29 30 31 | \fBTcl_ExprBooleanObj\fR(\fIinterp, objPtr, booleanPtr\fR) .sp int \fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR) .SH ARGUMENTS .AS Tcl_Interp **resultPtrPtr out .AP Tcl_Interp *interp in | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | \fBTcl_ExprBooleanObj\fR(\fIinterp, objPtr, booleanPtr\fR) .sp int \fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR) .SH ARGUMENTS .AS Tcl_Interp **resultPtrPtr out .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIobjPtr\fR. .AP Tcl_Obj *objPtr in Pointer to an object containing the expression to evaluate. .AP long *longPtr out Pointer to location in which to store the integer value of the expression. .AP int *doublePtr out Pointer to location in which to store the floating-point value of the |
︙ | ︙ |
Changes to doc/FileSystem.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2001 Vincent Darley '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2001 Vincent Darley '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: FileSystem.3,v 1.50.2.4 2005/09/09 18:48:40 dgp Exp $ '\" .so man.macros .TH Filesystem 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSLoadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_AllocStatBuf \- procedures to interact with any filesystem .SH SYNOPSIS |
︙ | ︙ | |||
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 | .AP Tcl_PackageInitProc **proc1Ptr out Filled with the init function for this code. .AP Tcl_PackageInitProc **proc2Ptr out Filled with the safe-init function for this code. .AP ClientData *clientDataPtr out Filled with the clientData value to pass to this code's unload function when it is called. .AP Tcl_FSUnloadFileProc **unloadProcPtr out Filled with the function to use to unload this piece of code. .AP utimbuf *tval in The access and modification times in this structure are read and used to set those values for a given file. .AP "const char" *modeString in Specifies how the file is to be accessed. May have any of the values allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. .AP int *lenPtr out If non-NULL, filled with the number of elements in the split path. .AP Tcl_Obj *basePtr in The base path on to which to join the given elements. May be NULL. .AP int objc in The number of elements in \fIobjv\fR. .AP "Tcl_Obj *const" objv[] in The elements to join to the given base path. .BE .SH DESCRIPTION .PP There are several reasons for calling the \fBTcl_FS\fR API functions (e.g. \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR) rather than calling system level functions like \fBaccess\fR and | > > > > > > > > > > > > > | 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 | .AP Tcl_PackageInitProc **proc1Ptr out Filled with the init function for this code. .AP Tcl_PackageInitProc **proc2Ptr out Filled with the safe-init function for this code. .AP ClientData *clientDataPtr out Filled with the clientData value to pass to this code's unload function when it is called. .AP Tcl_LoadHandle *handlePtr out Filled with an abstract token representing the loaded file. .AP Tcl_FSUnloadFileProc **unloadProcPtr out Filled with the function to use to unload this piece of code. .AP utimbuf *tval in The access and modification times in this structure are read and used to set those values for a given file. .AP "const char" *modeString in Specifies how the file is to be accessed. May have any of the values allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. .AP int *lenPtr out If non-NULL, filled with the number of elements in the split path. .AP Tcl_Obj *basePtr in The base path on to which to join the given elements. May be NULL. .AP int objc in The number of elements in \fIobjv\fR. .AP "Tcl_Obj *const" objv[] in The elements to join to the given base path. .AP Tcl_Obj *linkNamePtr in The name of the link to be created or read. .AP Tcl_Obj *toPtr in What the link called \fIlinkNamePtr\fR should be linked to, or NULL if the symbolic link specified by \fIlinkNamePtr\fR is to be read. .AP int linkAction in OR-ed combination of flags indicating what kind of link should be created (will be ignored if \fItoPtr\fR is NULL). Valid bits to set are \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR. When both flags are set and the underlying filesystem can do either, symbolic links are preferred. .BE .SH DESCRIPTION .PP There are several reasons for calling the \fBTcl_FS\fR API functions (e.g. \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR) rather than calling system level functions like \fBaccess\fR and |
︙ | ︙ | |||
359 360 361 362 363 364 365 | message is left in the \fIinterp\fR's result. .PP \fBTcl_FSMatchInDirectory\fR is used by the globbing code to search a directory for all files which match a given pattern. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP The return value is a standard Tcl result indicating whether an error | | > | | 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 | message is left in the \fIinterp\fR's result. .PP \fBTcl_FSMatchInDirectory\fR is used by the globbing code to search a directory for all files which match a given pattern. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP The return value is a standard Tcl result indicating whether an error occurred in globbing. Error messages are placed in interp (unless interp is NULL, which is allowed), but good results are placed in the resultPtr given. .PP Note that the \fBglob\fR code implements recursive patterns internally, so this function will only ever be passed simple patterns, which can be matched using the logic of \fBstring match\fR. To handle recursion, Tcl will call this function frequently asking only for directories to be returned. .PP |
︙ | ︙ | |||
603 604 605 606 607 608 609 | \fBTcl_FSGetTranslatedStringPath\fR does the same as \fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL. The string returned is dynamically allocated and owned by the caller, which must store it or call \fBckfree\fR to ensure it is freed. Again, \fBTcl_FSGetNormalizedPath\fR or \fBTcl_GetNativePath\fR are usually better functions to use for most purposes. .PP | | | 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 | \fBTcl_FSGetTranslatedStringPath\fR does the same as \fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL. The string returned is dynamically allocated and owned by the caller, which must store it or call \fBckfree\fR to ensure it is freed. Again, \fBTcl_FSGetNormalizedPath\fR or \fBTcl_GetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSNewNativePath\fR performs something like the reverse of the usual obj->path->nativerep conversions. If some code retrieves a path in native form (from, e.g. \fBreadlink\fR or a native dialog), and that path is to be used at the Tcl level, then calling this function is an efficient way of creating the appropriate path object type. .PP The resulting object is a pure 'path' object, which will only receive a Utf-8 string representation if that is required by some Tcl code. |
︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 | which have the correct type. In either case, \fIpathPtr\fR can be assumed to be both non-NULL and non-empty. It is not currently documented whether \fIpathPtr\fR will have a file separator at its end of not, so code should be flexible to both possibilities. .PP The return value is a standard Tcl result indicating whether an error occurred in the matching process. Error messages are placed in | > | | | | 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 | which have the correct type. In either case, \fIpathPtr\fR can be assumed to be both non-NULL and non-empty. It is not currently documented whether \fIpathPtr\fR will have a file separator at its end of not, so code should be flexible to both possibilities. .PP The return value is a standard Tcl result indicating whether an error occurred in the matching process. Error messages are placed in \fIinterp\fR, unless \fIinterp\fR in NULL in which case no error message need be generated; on a \fBTCL_OK\fR result, results should be added to the \fIresultPtr\fR object given (which can be assumed to be a valid unshared Tcl list). The matches added to \fIresultPtr\fR should include any path prefix given in \fIpathPtr\fR (this usually means they will be absolute path specifications). Note that if no matches are found, that simply leads to an empty result; errors are only signaled for actual file or filesystem problems which may occur during the matching process. .PP The \fBTcl_GlobTypeData\fR structure passed in the \fItypes\fR |
︙ | ︙ | |||
1399 1400 1401 1402 1403 1404 1405 | .CE .PP Returns a standard Tcl completion code. If an error occurs, an error message is left in the \fIinterp\fR'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. | | | 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 | .CE .PP Returns a standard Tcl completion code. If an error occurs, an error message is left in the \fIinterp\fR'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 unload procedure will be called with the given \fBTcl_LoadHandle\fR as its only parameter when Tcl needs to unload the file. For example, for the native filesystem, the \fBTcl_LoadHandle\fR returned is currently a token which can be used in the private \fBTclpFindSymbol\fR to access functions in the new code. Each filesystem is free to define the \fBTcl_LoadHandle\fR as it requires. Finally, if the filesystem determines it cannot support the file load action, calling \fBTcl_SetErrno(EXDEV)\fR and returning a non-\fBTCL_OK\fR |
︙ | ︙ |
Changes to doc/GetIndex.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: GetIndex.3,v 1.16.2.1 2005/04/10 23:14:41 kennykb Exp $ '\" .so man.macros .TH Tcl_GetIndexFromObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct \- lookup string in table of keywords .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_GetIndexFromObj\fR(\fIinterp, objPtr, tablePtr, msg, flags, indexPtr\fR) .sp int \fBTcl_GetIndexFromObjStruct\fR(\fIinterp, objPtr, structTablePtr, offset, msg, flags, indexPtr\fR) .SH ARGUMENTS .AS "const char" *structTablePtr in/out .AP Tcl_Interp *interp in Interpreter to use for error reporting; if NULL, then no message is provided on errors. .AP Tcl_Obj *objPtr in/out The string value of this object is used to search through \fItablePtr\fR. |
︙ | ︙ | |||
82 83 84 85 86 87 88 | arguments (e.g. during a reinvocation of a Tcl command), it returns the matching index immediately without having to redo the lookup operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries in \fItablePtr\fR are static: they must not change between invocations. If the value of \fIobjPtr\fR is the empty string, \fBTcl_GetIndexFromObj\fR will treat it as a non-matching value and return \fBTCL_ERROR\fR. | < < | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | arguments (e.g. during a reinvocation of a Tcl command), it returns the matching index immediately without having to redo the lookup operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries in \fItablePtr\fR are static: they must not change between invocations. If the value of \fIobjPtr\fR is the empty string, \fBTcl_GetIndexFromObj\fR will treat it as a non-matching value and return \fBTCL_ERROR\fR. .PP \fBTcl_GetIndexFromObjStruct\fR works just like \fBTcl_GetIndexFromObj\fR, except that instead of treating \fItablePtr\fR as an array of string pointers, it treats it as a pointer to the first string in a series of strings that have \fIoffset\fR bytes between them (i.e. that there is a pointer to the first array of characters at \fItablePtr\fR, a pointer to the second array of characters at \fItablePtr\fR+\fIoffset\fR bytes, etc.) This is particularly useful when processing things like \fBTk_ConfigurationSpec\fR, whose string keys are in the same place in each of several array elements. .SH "SEE ALSO" Tcl_WrongNumArgs .SH KEYWORDS index, object, table lookup |
Changes to doc/GetInt.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 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 | '\" '\" 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: GetInt.3,v 1.7.2.2 2005/05/05 17:55:21 kennykb Exp $ '\" .so man.macros .TH Tcl_GetInt 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_GetInt, Tcl_GetDouble, Tcl_GetBoolean \- convert from string to integer, double, or boolean .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_GetInt\fR(\fIinterp, src, intPtr\fR) .sp int \fBTcl_GetDouble\fR(\fIinterp, src, doublePtr\fR) .sp int \fBTcl_GetBoolean\fR(\fIinterp, src, boolPtr\fR) .SH ARGUMENTS .AS Tcl_Interp *doublePtr out .AP Tcl_Interp *interp in Interpreter to use for error reporting. .AP "const char" *src in Textual value to be converted. .AP int *intPtr out Points to place to store integer value converted from \fIsrc\fR. .AP double *doublePtr out Points to place to store double-precision floating-point value converted from \fIsrc\fR. .AP int *boolPtr out Points to place to store boolean value (0 or 1) converted from \fIsrc\fR. .BE .SH DESCRIPTION .PP These procedures convert from strings to integers or double-precision floating-point values or booleans (represented as 0- or 1-valued integers). Each of the procedures takes a \fIsrc\fR argument, converts it to an internal form of a particular type, and stores the converted value at the location indicated by the procedure's third argument. If all goes well, each of the procedures returns \fBTCL_OK\fR. If \fIsrc\fR doesn't have the proper syntax for the desired type then \fBTCL_ERROR\fR is returned, an error message is left in the interpreter's result, and nothing is stored at *\fIintPtr\fR or *\fIdoublePtr\fR or *\fIboolPtr\fR. .PP \fBTcl_GetInt\fR expects \fIsrc\fR to consist of a collection of integer digits, optionally signed and optionally preceded by white space. If the first two characters of \fIsrc\fR after the optional white space and sign are ``0x'' then \fIsrc\fR is expected to be in hexadecimal form; otherwise, if the first such character is ``0'' then \fIsrc\fR is expected to be in octal form; otherwise, \fIsrc\fR is expected to be in decimal form. .PP \fBTcl_GetDouble\fR expects \fIsrc\fR to consist of a floating-point number, which is: white space; a sign; a sequence of digits; a decimal point; a sequence of digits; the letter ``e''; a signed decimal exponent ; and more white space. Any of the fields may be omitted, except that the digits either before or after the decimal point must be present and if the ``e'' is present then it must be followed by the exponent number. .PP \fBTcl_GetBoolean\fR expects \fIsrc\fR to specify a boolean value. If \fIsrc\fR is any of \fB0\fR, \fBfalse\fR, \fBno\fR, or \fBoff\fR, then \fBTcl_GetBoolean\fR stores a zero value at \fI*boolPtr\fR. If \fIsrc\fR is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR, then 1 is stored at \fI*boolPtr\fR. Any of these values may be abbreviated, and upper-case spellings are also acceptable. .SH KEYWORDS boolean, conversion, double, floating-point, integer |
Changes to doc/GetOpnFl.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 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | '\" '\" Copyright (c) 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: GetOpnFl.3,v 1.8.2.2 2005/05/05 17:55:22 kennykb Exp $ .so man.macros .TH Tcl_GetOpenFile 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_GetOpenFile \- Return a FILE* for a channel registered in the given interpreter (Unix only) .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_GetOpenFile\fR(\fIinterp, chanID, write, checkUsage, filePtr\fR) .sp .SH ARGUMENTS .AS Tcl_Interp checkUsage out .AP Tcl_Interp *interp in Tcl interpreter from which file handle is to be obtained. .AP "const char" *chanID in String identifying channel, such as \fBstdin\fR or \fBfile4\fR. .AP int write in Non-zero means the file will be used for writing, zero means it will be used for reading. .AP int checkUsage in If non-zero, then an error will be generated if the file wasn't opened for the access indicated by \fIwrite\fR. .AP ClientData *filePtr out Points to word in which to store pointer to FILE structure for the file given by \fIchanID\fR. .BE .SH DESCRIPTION .PP \fBTcl_GetOpenFile\fR takes as argument a file identifier of the form returned by the \fBopen\fR command and returns at \fI*filePtr\fR a pointer to the FILE structure for the file. The \fIwrite\fR argument indicates whether the FILE pointer will be used for reading or writing. In some cases, such as a channel that connects to a pipeline of subprocesses, different FILE pointers will be returned for reading and writing. \fBTcl_GetOpenFile\fR normally returns \fBTCL_OK\fR. If an error occurs in \fBTcl_GetOpenFile\fR (e.g. \fIchanID\fR didn't make any sense or \fIcheckUsage\fR was set and the file wasn't opened for the access specified by \fIwrite\fR) then \fBTCL_ERROR\fR is returned and the interpreter's result will contain an error message. In the current implementation \fIcheckUsage\fR is ignored and consistency checks are always performed. .PP Note that this interface is only supported on the Unix platform. .SH KEYWORDS channel, file handle, permissions, pipeline, read, write |
Changes to doc/GetTime.3.
︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | .SH NAME Tcl_GetTime \- get date and time .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_GetTime\fR(\fItimePtr\fR) .SH ARGUMENTS .AS "Tcl_Time *" timePtr out .AP "Tcl_Time *" timePtr out Points to memory in which to store the date and time information. .BE .SH DESCRIPTION .PP The \fBTcl_GetTime\fR function retrieves the current time as a \fITcl_Time\fR structure in memory the caller provides. This structure has the following definition: .CS | > > > > > > > > > > > > > > > > > > > > > > > | 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 | .SH NAME Tcl_GetTime \- get date and time .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_GetTime\fR(\fItimePtr\fR) .sp \fBTcl_SetTimeProc\fR(\fIgetProc, scaleProc, clientData\fR) .sp \fBTcl_QueryTimeProc\fR(\fIgetProcPtr, scaleProcPtr, clientDataPtr\fR) .SH ARGUMENTS .AS "Tcl_Time *" timePtr out .AP "Tcl_Time *" timePtr out Points to memory in which to store the date and time information. .AS "Tcl_GetTimeProc *" getProc in .AP "Tcl_GetTimeProc *" getProc in Pointer to handler function replacing Tcl_GetTime's access to the OS. .AS "Tcl_ScaleTimeProc *" scaleProc in .AP "Tcl_ScaleTimeProc *" scaleProc in Pointer to handler function for the conversion of time delays in the virtual domain to real-time. .AS "ClientData *" clientData in .AP "ClientData *" clientData in Value passed through to the two handler functions. .AS "Tcl_GetTimeProc **" getProcPtr inout .AP "Tcl_GetTimeProc **" getProcPtr inout Pointer to place the currently registered get handler function into. .AS "Tcl_ScaleTimeProc **" scaleProcPtr inout .AP "Tcl_ScaleTimeProc **" scaleProcPtr inout Pointer to place the currently registered scale handler function into. .AS "ClientData **" clientDataPtr inout .AP "ClientData **" clientDataPtr inout Pointer to place the currently registered pass-through value into. .BE .SH DESCRIPTION .PP The \fBTcl_GetTime\fR function retrieves the current time as a \fITcl_Time\fR structure in memory the caller provides. This structure has the following definition: .CS |
︙ | ︙ | |||
43 44 45 46 47 48 49 50 51 52 53 | microseconds that have elapsed since the start of the second designated by \fIsec\fR. The Tcl library makes every effort to keep this number as precise as possible, subject to the limitations of the computer system. On multiprocessor variants of Windows, this number may be limited to the 10- or 20-ms granularity of the system clock. (On single-processor Windows systems, the \fIusec\fR field is derived from a performance counter and is highly precise.) .SH "SEE ALSO" clock .SH KEYWORDS date, time | > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | microseconds that have elapsed since the start of the second designated by \fIsec\fR. The Tcl library makes every effort to keep this number as precise as possible, subject to the limitations of the computer system. On multiprocessor variants of Windows, this number may be limited to the 10- or 20-ms granularity of the system clock. (On single-processor Windows systems, the \fIusec\fR field is derived from a performance counter and is highly precise.) .PP The \fBTcl_SetTime\fR function registers two related handler functions with the core. The first handler function is a replacement for \fBTcl_GetTime\fR, or rather the OS access made by \fBTcl_GetTime\fR. The other handler function is used by the Tcl notifier to convert wait/block times from the virtual domain into real time. .PP The \fBTcl_QueryTime\fR function returns the currently registered handler functions. If no external handlers were set then this will return the standard handlers accessing and processing the native time of the OS. The arguments to the function are allowed to be NULL; and any argument which is NULL is ignored and not set. .PP Any handler pair specified has to return data which is consistent between them. In other words, setting one handler of the pair to something assuming a 10-times slowdown, and the other handler of the pair to something assuming a two-times slowdown is wrong and not allowed. .PP The set handler functions are allowed to run the delivered time backwards, however this should be avoided. We have to allow it as the native time can run backwards as the user can fiddle with the system time one way or other. Note that the insertion of the hooks will not change the behaviour of the Tcl core with regard to this situation, i.e. the existing behaviour is retained. .SH "SEE ALSO" clock .SH KEYWORDS date, time |
Changes to doc/IntObj.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 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 | '\" '\" 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: IntObj.3,v 1.6.2.1 2005/04/10 23:14:41 kennykb Exp $ '\" .so man.macros .TH Tcl_IntObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj \- manipulate Tcl objects as integers and wide integers .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewIntObj\fR(\fIintValue\fR) .sp Tcl_Obj * \fBTcl_NewLongObj\fR(\fIlongValue\fR) .sp Tcl_Obj * \fBTcl_NewWideIntObj\fR(\fIwideValue\fR) .sp \fBTcl_SetIntObj\fR(\fIobjPtr, intValue\fR) .sp \fBTcl_SetLongObj\fR(\fIobjPtr, longValue\fR) .sp \fBTcl_SetWideIntObj\fR(\fIobjPtr, wideValue\fR) .sp int \fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR) .sp int \fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR) .sp int \fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR) .SH ARGUMENTS .AS Tcl_WideInt longValue in/out .AP int intValue in Integer value used to initialize or set an integer object. .AP long longValue in Long integer value used to initialize or set an integer object. .AP Tcl_WideInt wideValue in Wide integer value (minimum 64-bits wide where supported by the compiler) used to initialize or set a wide integer object. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, and \fBTcl_SetWideIntObj\fR, this points to the object to be converted to integer type. For \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, and \fBTcl_GetWideIntFromObj\fR, this refers to the object from which to get an integer or long integer value; if \fIobjPtr\fR does not already point to an integer object (or a wide integer object in the case of \fBTcl_SetWideIntObj\fR and \fBTcl_GetWideIntFromObj\fR), an attempt will be made to convert it to one. .AP Tcl_Interp *interp in/out If an error occurs during conversion, an error message is left in the interpreter's result object unless \fIinterp\fR is NULL. .AP int *intPtr out Points to place to store the integer value obtained by \fBTcl_GetIntFromObj\fR from \fIobjPtr\fR. .AP long *longPtr out Points to place to store the long integer value obtained by \fBTcl_GetLongFromObj\fR from \fIobjPtr\fR. .AP Tcl_WideInt *widePtr out Points to place to store the wide integer value obtained by \fBTcl_GetWideIntFromObj\fR from \fIobjPtr\fR. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read integer and wide integer Tcl objects from C code. \fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR, \fBTcl_SetIntObj\fR, and \fBTcl_SetLongObj\fR create a new object of integer type or modify an existing object to have integer type, and \fBTcl_NewWideIntObj\fR and \fBTcl_SetWideIntObj\fR create a new object of wide integer type or modify an existing object to have wide integer type. \fBTcl_NewIntObj\fR and \fBTcl_SetIntObj\fR set the object to have the integer value given by \fIintValue\fR, \fBTcl_NewLongObj\fR and \fBTcl_SetLongObj\fR set the object to have the long integer value given by \fIlongValue\fR, and \fBTcl_NewWideIntObj\fR and \fBTcl_SetWideIntObj\fR set the object to have the wide integer value given by \fIwideValue\fR. \fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR and \fBTcl_NewWideIntObj\fR return a pointer to a newly created object with reference count zero. These procedures set the object's type to be integer and assign the integer value to the object's internal representation \fIlongValue\fR or \fIwideValue\fR member (as appropriate). \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR and \fBTcl_SetWideIntObj\fR invalidate any old string representation and, if the object is not already an integer object, free any old internal representation. .PP \fBTcl_GetIntFromObj\fR and \fBTcl_GetLongFromObj\fR attempt to return an integer value from the Tcl object \fIobjPtr\fR, and \fBTcl_GetWideIntFromObj\fR attempts to return a wide integer value from the Tcl object \fIobjPtr\fR. If the object is not already an integer object, or a wide integer object in the case of \fBTcl_GetWideIntFromObj\fR they will attempt to convert it to one. If an error occurs during conversion, they return \fBTCL_ERROR\fR and leave an error message in the interpreter's result object unless \fIinterp\fR is NULL. Also, if the long integer held in the object's internal representation \fIlongValue\fR member can not be represented in a (non-long) integer, \fBTcl_GetIntFromObj\fR returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result object unless \fIinterp\fR is NULL. Otherwise, all three procedures return \fBTCL_OK\fR and store the integer, long integer value or wide integer in the address given by \fIintPtr\fR, \fIlongPtr\fR and \fIwidePtr\fR respectively. If the object is not already an integer or wide integer object, the conversion will free any old internal representation. .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS integer, integer object, integer type, internal representation, object, object type, string representation |
Changes to doc/Interp.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: Interp.3,v 1.7.2.1 2005/04/10 23:14:41 kennykb Exp $ '\" .so man.macros .TH Tcl_Interp 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Interp \- client-visible fields of interpreter structures .SH SYNOPSIS |
︙ | ︙ | |||
56 57 58 59 60 61 62 | being returned by the command. The \fIresult\fR field must always point to a valid string. If a command wishes to return no result then \fIinterp->result\fR should point to an empty string. Normally, results are assumed to be statically allocated, which means that the contents will not change before the next time \fBTcl_Eval\fR is called or some other command procedure is invoked. | < < < < | 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 | being returned by the command. The \fIresult\fR field must always point to a valid string. If a command wishes to return no result then \fIinterp->result\fR should point to an empty string. Normally, results are assumed to be statically allocated, which means that the contents will not change before the next time \fBTcl_Eval\fR is called or some other command procedure is invoked. In this case, the \fIfreeProc\fR field must be zero. Alternatively, a command procedure may dynamically allocate its return value (e.g. using \fBTcl_Alloc\fR) and store a pointer to it in \fIinterp->result\fR. In this case, the command procedure must also set \fIinterp->freeProc\fR to the address of a procedure that can free the value, or \fBTCL_DYNAMIC\fR if the storage was allocated directly by Tcl or by a call to \fBTcl_Alloc\fR. If \fIinterp->freeProc\fR is non-zero, then Tcl will call \fIfreeProc\fR to free the space pointed to by \fIinterp->result\fR before it invokes the next command. If a client procedure overwrites \fIinterp->result\fR when \fIinterp->freeProc\fR is non-zero, then it is responsible for calling \fIfreeProc\fR to free the old \fIinterp->result\fR (the \fBTcl_FreeResult\fR macro should be used for this purpose). .PP \fIFreeProc\fR should have arguments and result that match the \fBTcl_FreeProc\fR declaration above: it receives a single argument which is a pointer to the result value to free. In most applications \fBTCL_DYNAMIC\fR is the only non-zero value ever used for \fIfreeProc\fR. However, an application may store a different procedure address in \fIfreeProc\fR in order to use an alternate memory allocator or in order to do other cleanup when the result memory is freed. .PP As part of processing each command, \fBTcl_Eval\fR initializes \fIinterp->result\fR and \fIinterp->freeProc\fR just before calling the command procedure for |
︙ | ︙ |
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.9.2.2 2005/09/09 18:48:40 dgp Exp $ '\" .so man.macros .TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable .SH SYNOPSIS |
︙ | ︙ | |||
24 25 26 27 28 29 30 | \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 | | | | > > > > > > | > | | | 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 | \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 \fBTCL_LINK_INT\fR, .VS 8.5 \fBTCL_LINK_UINT\fR, \fBTCL_LINK_CHAR\fR, \fBTCL_LINK_UCHAR\fR, \fBTCL_LINK_SHORT\fR, \fBTCL_LINK_USHORT\fR, \fBTCL_LINK_LONG\fR, \fBTCL_LINK_ULONG\fR, .VE 8.5 \fBTCL_LINK_WIDE_INT\fR, .VS 8.5 \fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR, .VE 8.5 \fBTCL_LINK_DOUBLE\fR, \fBTCL_LINK_BOOLEAN\fR, or \fBTCL_LINK_STRING\fR, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR to make Tcl variable read-only. .BE .SH DESCRIPTION .PP \fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable named by \fIvarName\fR in sync with the C variable at the address given by \fIaddr\fR. |
︙ | ︙ | |||
59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | .TP \fBTCL_LINK_INT\fR The C variable is of type \fBint\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_DOUBLE\fR The C variable is of type \fBdouble\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR; attempts to write non-real values into \fIvarName\fR will be rejected with Tcl errors. .TP | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > | > > > > > > > > > > > > > > | < < | 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 | .TP \fBTCL_LINK_INT\fR The C variable is of type \fBint\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. .VS 8.5 .TP \fBTCL_LINK_UINT\fR The C variable is of type \fBunsigned int\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned int\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_CHAR\fR The C variable is of type \fBchar\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBchar\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_UCHAR\fR The C variable is of type \fBunsigned char\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned char\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_SHORT\fR The C variable is of type \fBshort\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBshort\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_USHORT\fR The C variable is of type \fBunsigned short\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned short\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_LONG\fR The C variable is of type \fBlong\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetLongFromObj\fR; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_ULONG\fR The C variable is of type \fBunsigned long\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned long\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. .VE 8.5 .TP \fBTCL_LINK_DOUBLE\fR The C variable is of type \fBdouble\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR; attempts to write non-real values into \fIvarName\fR will be rejected with Tcl errors. .VS 8.5 .TP \fBTCL_LINK_FLOAT\fR The C variable is of type \fBfloat\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR and must be within the range acceptable for a \fBfloat\fR; attempts to write non-real values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. .VE 8.5 .TP \fBTCL_LINK_WIDE_INT\fR The C variable is of type \fBTcl_WideInt\fR (which is an integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetWideIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. .VS 8.5 .TP \fBTCL_LINK_WIDE_UINT\fR The C variable is of type \fBTcl_WideUInt\fR (which is an unsigned integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR (it will be cast to unsigned); '\" FIXME! Use bignums instead. attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. .VE 8.5 .TP \fBTCL_LINK_BOOLEAN\fR The C variable is of type \fBint\fR. If its value is zero then it will read from Tcl as ``0''; otherwise it will read from Tcl as ``1''. Whenever \fIvarName\fR is modified, the C variable will be set to a 0 or 1 value. Any value written into the Tcl variable must have a proper boolean form acceptable to \fBTcl_GetBooleanFromObj\fR; attempts to write non-boolean values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_STRING\fR The C variable is of type \fBchar *\fR. If its value is not NULL then it must be a pointer to a string allocated with \fBTcl_Alloc\fR or \fBckalloc\fR. Whenever the Tcl variable is modified the current C string will be freed and new memory will be allocated to hold a copy of the variable's new value. If the C variable contains a NULL pointer then the Tcl variable will read as ``NULL''. .PP If the \fBTCL_LINK_READ_ONLY\fR flag is present in \fItype\fR then the |
︙ | ︙ |
Changes to doc/ListObj.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: ListObj.3,v 1.8.2.1 2005/04/10 23:14:41 kennykb Exp $ '\" .so man.macros .TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_ListObjAppendList, Tcl_ListObjAppendElement, Tcl_NewListObj, Tcl_SetListObj, Tcl_ListObjGetElements, Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjReplace \- manipulate Tcl objects as lists .SH SYNOPSIS |
︙ | ︙ | |||
147 148 149 150 151 152 153 | The new list object returned by \fBTcl_NewListObj\fR has reference count zero. .PP \fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of the elements in a list object. It returns the count by storing it in the address \fIobjcPtr\fR. Similarly, it returns the array pointer by storing it in the address \fIobjvPtr\fR. | | | > | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 | The new list object returned by \fBTcl_NewListObj\fR has reference count zero. .PP \fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of the elements in a list object. It returns the count by storing it in the address \fIobjcPtr\fR. Similarly, it returns the array pointer by storing it in the address \fIobjvPtr\fR. The memory pointed to is managed by Tcl and should not be freed or written to by the caller. If the list is empty, 0 is stored at \fIobjcPtr\fR and NULL at \fIobjvPtr\fR. If \fIlistPtr\fR is not already a list object, \fBTcl_ListObjGetElements\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result object if \fIinterp\fR is not NULL. Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer. .PP \fBTcl_ListObjLength\fR returns the number of elements in the list object |
︙ | ︙ |
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.13.2.1 2005/04/10 23:14:42 kennykb 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 |
︙ | ︙ | |||
23 24 25 26 27 28 29 | \fBTcl_DeleteEventSource\fR(\fIsetupProc, checkProc, clientData\fR) .sp void \fBTcl_SetMaxBlockTime\fR(\fItimePtr\fR) .sp void \fBTcl_QueueEvent\fR(\fIevPtr, position\fR) | < | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | \fBTcl_DeleteEventSource\fR(\fIsetupProc, checkProc, clientData\fR) .sp void \fBTcl_SetMaxBlockTime\fR(\fItimePtr\fR) .sp void \fBTcl_QueueEvent\fR(\fIevPtr, position\fR) .sp void \fBTcl_ThreadQueueEvent\fR(\fIthreadId, evPtr, position\fR) .sp void \fBTcl_ThreadAlert\fR(\fIthreadId\fR) .sp |
︙ | ︙ | |||
63 64 65 66 67 68 69 | \fBTcl_ServiceEvent\fR(\fIflags\fR) .sp int \fBTcl_GetServiceMode\fR() .sp int \fBTcl_SetServiceMode\fR(\fImode\fR) | < | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | \fBTcl_ServiceEvent\fR(\fIflags\fR) .sp int \fBTcl_GetServiceMode\fR() .sp int \fBTcl_SetServiceMode\fR(\fImode\fR) .SH ARGUMENTS .AS Tcl_EventDeleteProc *deleteProc .AP Tcl_EventSetupProc *setupProc in Procedure to invoke to prepare for event wait in \fBTcl_DoOneEvent\fR. .AP Tcl_EventCheckProc *checkProc in Procedure for \fBTcl_DoOneEvent\fR to invoke after waiting for |
︙ | ︙ |
Changes to doc/Object.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: Object.3,v 1.10.2.1 2005/04/10 23:14:42 kennykb Exp $ '\" .so man.macros .TH Tcl_Obj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl objects .SH SYNOPSIS |
︙ | ︙ | |||
125 126 127 128 129 130 131 | void *\fIptr1\fR; void *\fIptr2\fR; } \fItwoPtrValue\fR; } \fIinternalRep\fR; } Tcl_Obj; .CE The \fIbytes\fR and the \fIlength\fR members together hold | < < | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | void *\fIptr1\fR; void *\fIptr2\fR; } \fItwoPtrValue\fR; } \fIinternalRep\fR; } Tcl_Obj; .CE The \fIbytes\fR and the \fIlength\fR members together hold an object's UTF-8 string representation, which is a \fIcounted string\fR not containing null bytes (UTF-8 null characters should be encoded as a two byte sequence: 192, 128.) \fIbytes\fR points to the first byte of the string representation. The \fIlength\fR member gives the number of bytes. The byte array must always have a null byte after the last data byte, at offset \fIlength\fR; this allows string representations to be treated as conventional null-terminated C strings. C programs use \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR to get an object's string representation. If \fIbytes\fR is NULL, the string representation is invalid. .PP An object's type manages its internal representation. The member \fItypePtr\fR points to the Tcl_ObjType structure |
︙ | ︙ |
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 15 16 17 18 19 20 | '\" '\" 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.29.2.2 2005/07/12 20:36:15 kennykb 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_TruncateChannel, 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 .nf \fB#include <tcl.h>\fR .sp Tcl_Channel \fBTcl_OpenFileChannel\fR(\fIinterp, fileName, mode, permissions\fR) .sp |
︙ | ︙ | |||
85 86 87 88 89 90 91 | \fBTcl_Flush\fR(\fIchannel\fR) .sp int \fBTcl_InputBlocked\fR(\fIchannel\fR) .sp int \fBTcl_InputBuffered\fR(\fIchannel\fR) | < < > > > > > | 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 | \fBTcl_Flush\fR(\fIchannel\fR) .sp int \fBTcl_InputBlocked\fR(\fIchannel\fR) .sp int \fBTcl_InputBuffered\fR(\fIchannel\fR) .sp int \fBTcl_OutputBuffered\fR(\fIchannel\fR) .sp Tcl_WideInt \fBTcl_Seek\fR(\fIchannel, offset, seekMode\fR) .sp Tcl_WideInt \fBTcl_Tell\fR(\fIchannel\fR) .sp .VS 8.5 int \fBTcl_TruncateChannel\fR(\fIchannel, length\fR) .VE 8.5 .sp int \fBTcl_GetChannelOption\fR(\fIinterp, channel, optionName, optionValue\fR) .sp int \fBTcl_SetChannelOption\fR(\fIinterp, channel, optionName, newValue\fR) .sp |
︙ | ︙ | |||
194 195 196 197 198 199 200 201 202 203 204 205 206 207 | How far to move the access point in the channel at which the next input or output operation will be applied, measured in bytes from the position given by \fIseekMode\fR. May be either positive or negative. .AP int seekMode in Relative to which point to seek; used with \fIoffset\fR to calculate the new access point for the channel. Legal values are \fBSEEK_SET\fR, \fBSEEK_CUR\fR, and \fBSEEK_END\fR. .AP "const char" *optionName in The name of an option applicable to this channel, such as \fB\-blocking\fR. May have any of the values accepted by the \fBfconfigure\fR command. .AP Tcl_DString *optionValue in Where to store the value of an option or a list of all options and their values. Must have been initialized by the caller. .AP "const char" *newValue in | > > | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 | How far to move the access point in the channel at which the next input or output operation will be applied, measured in bytes from the position given by \fIseekMode\fR. May be either positive or negative. .AP int seekMode in Relative to which point to seek; used with \fIoffset\fR to calculate the new access point for the channel. Legal values are \fBSEEK_SET\fR, \fBSEEK_CUR\fR, and \fBSEEK_END\fR. .AP Tcl_WideInt length in The (non-negative) length to truncate the channel the channel to. .AP "const char" *optionName in The name of an option applicable to this channel, such as \fB\-blocking\fR. May have any of the values accepted by the \fBfconfigure\fR command. .AP Tcl_DString *optionValue in Where to store the value of an option or a list of all options and their values. Must have been initialized by the caller. .AP "const char" *newValue in |
︙ | ︙ | |||
589 590 591 592 593 594 595 596 597 598 599 600 601 602 | code that can be retrieved with \fBTcl_GetErrno\fR. After an error, the access point may or may not have been moved. .SH TCL_TELL .PP \fBTcl_Tell\fR returns the current access point for a channel. The returned value is \-1 if the channel does not support seeking. .SH TCL_GETCHANNELOPTION .PP \fBTcl_GetChannelOption\fR retrieves, in \fIoptionValue\fR, the value of one of the options currently in effect for a channel, or a list of all options and their values. The \fIchannel\fR argument identifies the channel for which to query an option or retrieve all options and their values. | > > > > > > > > | 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 | code that can be retrieved with \fBTcl_GetErrno\fR. After an error, the access point may or may not have been moved. .SH TCL_TELL .PP \fBTcl_Tell\fR returns the current access point for a channel. The returned value is \-1 if the channel does not support seeking. .SH TCL_TRUNCATECHANNEL .PP .VS 8.5 \fBTcl_TruncateChannel\fR truncates the file underlying \fIchannel\fR to a given \fIlength\fR of bytes. It returns \fBTCL_OK\fR if the operation succeeded, and \fBTCL_ERROR\fR otherwise. .VE 8.5 .SH TCL_GETCHANNELOPTION .PP \fBTcl_GetChannelOption\fR retrieves, in \fIoptionValue\fR, the value of one of the options currently in effect for a channel, or a list of all options and their values. The \fIchannel\fR argument identifies the channel for which to query an option or retrieve all options and their values. |
︙ | ︙ | |||
639 640 641 642 643 644 645 | .SH TCL_INPUTBUFFERED .PP \fBTcl_InputBuffered\fR returns the number of bytes of input currently buffered in the internal buffers for a channel. If the channel is not open for reading, this function always returns zero. .SH TCL_OUTPUTBUFFERED | < < | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 | .SH TCL_INPUTBUFFERED .PP \fBTcl_InputBuffered\fR returns the number of bytes of input currently buffered in the internal buffers for a channel. If the channel is not open for reading, this function always returns zero. .SH TCL_OUTPUTBUFFERED \fBTcl_OutputBuffered\fR returns the number of bytes of output currently buffered in the internal buffers for a channel. If the channel is not open for writing, this function always returns zero. .SH "PLATFORM ISSUES" .PP The handles returned from \fBTcl_GetChannelHandle\fR depend on the platform and the channel type. On Unix platforms, the handle is always a Unix file descriptor as returned from the \fBopen\fR system call. On Windows platforms, the handle is a file \fBHANDLE\fR when |
︙ | ︙ |
Changes to doc/OpenTcp.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996-7 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-7 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: OpenTcp.3,v 1.8.2.1 2005/04/10 23:14:42 kennykb Exp $ .so man.macros .TH Tcl_OpenTcpClient 3 8.0 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_OpenTcpClient, Tcl_MakeTcpClientChannel, Tcl_OpenTcpServer \- procedures to open channels using TCP sockets .SH SYNOPSIS |
︙ | ︙ | |||
159 160 161 162 163 164 165 | .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. | < < | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 | .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 "PLATFORM ISSUES" .PP On Unix platforms, the socket handle is a Unix file descriptor as returned by the \fBsocket\fR system call. On the Windows platform, the socket handle is a \fBSOCKET\fR as defined in the WinSock API. .SH "SEE ALSO" Tcl_OpenFileChannel(3), Tcl_RegisterChannel(3), vwait(n) .SH KEYWORDS client, server, TCP |
Changes to doc/Panic.3.
1 2 3 4 | '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Panic.3,v 1.7.2.1 2005/09/15 20:58:38 dgp Exp $ '\" .so man.macros .TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc \- report fatal error and abort |
︙ | ︙ | |||
27 28 29 30 31 32 33 | .AS Tcl_PanicProc *panicProc .AP "const char*" format in A printf-style format string. .AP "" arg in Arguments matching the format string. .AP va_list argList in An argument list of arguments matching the format string. | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | .AS Tcl_PanicProc *panicProc .AP "const char*" format in A printf-style format string. .AP "" arg in Arguments matching the format string. .AP va_list argList in An argument list of arguments matching the format string. Must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .AP Tcl_PanicProc *panicProc in Procedure to report fatal error message and abort. .BE .SH DESCRIPTION |
︙ | ︙ |
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 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 | '\" '\" 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.18.2.3 2005/09/26 20:16:53 kennykb 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 .nf \fB#include <tcl.h>\fR .sp int \fBTcl_ParseCommand\fR(\fIinterp, start, numBytes, nested, parsePtr\fR) .sp int \fBTcl_ParseExpr\fR(\fIinterp, start, numBytes, parsePtr\fR) .sp int \fBTcl_ParseBraces\fR(\fIinterp, start, numBytes, parsePtr, append, termPtr\fR) .sp int \fBTcl_ParseQuotedString\fR(\fIinterp, start, numBytes, parsePtr, append, termPtr\fR) .sp int \fBTcl_ParseVarName\fR(\fIinterp, start, numBytes, parsePtr, append\fR) .sp const char * \fBTcl_ParseVar\fR(\fIinterp, start, termPtr\fR) .sp \fBTcl_FreeParse\fR(\fIusedParsePtr\fR) .sp Tcl_Obj * \fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR) .sp int \fBTcl_EvalTokensStandard\fR(\fIinterp, tokenPtr, numTokens\fR) .SH ARGUMENTS .AS Tcl_Interp *usedParsePtr out .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" *start in Pointer to first character in string to parse. .AP int numBytes in Number of bytes in string to parse, not including any terminating null character. If less than 0 then the script consists of all characters following \fIstart\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 unquoted close bracket should be treated as a command terminator. If zero, close brackets have no special meaning. .AP int append in Non-zero means that \fI*parsePtr\fR already contains valid tokens; the new tokens should be appended to those already present. Zero means that |
︙ | ︙ | |||
104 105 106 107 108 109 110 | structure of the command (see below for details). If an error occurred in parsing the command then \fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's result, and no information is left at \fI*parsePtr\fR. .PP \fBTcl_ParseExpr\fR parses Tcl expressions. Given a pointer to a script containing an expression, | | | | | | | | | | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 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 | structure of the command (see below for details). If an error occurred in parsing the command then \fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's result, and no information is left at \fI*parsePtr\fR. .PP \fBTcl_ParseExpr\fR parses Tcl expressions. Given a pointer to a script containing an expression, \fBTcl_ParseExpr\fR parses the expression. If the expression was parsed successfully, \fBTcl_ParseExpr\fR returns \fBTCL_OK\fR and fills in the structure pointed to by \fIparsePtr\fR with information about the structure of the expression (see below for details). If an error occurred in parsing the command then \fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's result, and no information is left at \fI*parsePtr\fR. .PP \fBTcl_ParseBraces\fR parses a string or command argument enclosed in braces such as \fB{hello}\fR or \fB{string \\t with \\t tabs}\fR from the beginning of its argument \fIstart\fR. The first character of \fIstart\fR must be \fB{\fR. 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 \fIstart\fR. The first character of \fIstart\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 \fIstart\fR argument. The first character of \fIstart\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 \fIstart\fR argument. The first character of \fIstart\fR must be \fB$\fR. If the variable name is parsed successfully, \fBTcl_ParseVar\fR returns a pointer to the string value of the variable. If an error occurs while parsing, then NULL is returned and an error message is left in \fIinterp\fR's result. .PP The information left at \fI*parsePtr\fR by \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, |
︙ | ︙ | |||
291 292 293 294 295 296 297 | .VS 8.5 This token has the same meaning as \fBTCL_TOKEN_WORD\fR, except that the command parser notes this word began with the expansion prefix \fB{expand}\fR, indicating that after substitution, the list value of this word should be expanded to form multiple arguments in command evaluation. This token type can only be created by Tcl_ParseCommand. | | | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 | .VS 8.5 This token has the same meaning as \fBTCL_TOKEN_WORD\fR, except that the command parser notes this word began with the expansion prefix \fB{expand}\fR, indicating that after substitution, the list value of this word should be expanded to form multiple arguments in command evaluation. This token type can only be created by Tcl_ParseCommand. .VE 8.5 .TP \fBTCL_TOKEN_TEXT\fR The token describes a range of literal text that is part of a word. The \fInumComponents\fR field is always 0. .TP \fBTCL_TOKEN_BS\fR The token describes a backslash sequence such as \fB\en\fR or \fB\e0xa3\fR. |
︙ | ︙ | |||
427 428 429 430 431 432 433 | .PP After \fBTcl_ParseQuotedString\fR returns, the array of tokens pointed to by the \fItokenPtr\fR field of the Tcl_Parse structure depends on the contents of the quoted string. It will consist of one or more \fBTCL_TOKEN_TEXT\fR, \fBTCL_TOKEN_BS\fR, \fBTCL_TOKEN_COMMAND\fR, and \fBTCL_TOKEN_VARIABLE\fR sub-tokens. The array always contains at least one token; | | | | 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 | .PP After \fBTcl_ParseQuotedString\fR returns, the array of tokens pointed to by the \fItokenPtr\fR field of the Tcl_Parse structure depends on the contents of the quoted string. It will consist of one or more \fBTCL_TOKEN_TEXT\fR, \fBTCL_TOKEN_BS\fR, \fBTCL_TOKEN_COMMAND\fR, and \fBTCL_TOKEN_VARIABLE\fR sub-tokens. The array always contains at least one token; for example, if the argument \fIstart\fR is empty, the array returned consists of a single \fBTCL_TOKEN_TEXT\fR token with a zero \fIsize\fR field. Only the token information in the Tcl_Parse structure is modified: the \fIcommentStart\fR, \fIcommentSize\fR, \fIcommandStart\fR, and \fIcommandSize\fR fields are not modified. .PP After \fBTcl_ParseVarName\fR returns, the first token pointed to by the \fItokenPtr\fR field of the Tcl_Parse structure always has type \fBTCL_TOKEN_VARIABLE\fR. It is followed by the sub-tokens that make up the variable name as described above. The total length of the variable name is contained in the \fIsize\fR field of the first token. As in \fBTcl_ParseExpr\fR, only the token information in the Tcl_Parse structure is modified by \fBTcl_ParseVarName\fR: the \fIcommentStart\fR, \fIcommentSize\fR, \fIcommandStart\fR, and \fIcommandSize\fR fields are not modified. .PP All of the character pointers in the Tcl_Parse and Tcl_Token structures refer to characters in the \fIstart\fR argument passed to \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR. .PP There are additional fields in the Tcl_Parse structure after the \fInumTokens\fR field, but these are for the private use of \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR; they should not be referenced by code outside of these procedures. .SH KEYWORDS backslash substitution, braces, command, expression, parse, token, variable substitution |
Changes to doc/PrintDbl.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 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | '\" '\" Copyright (c) 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: PrintDbl.3,v 1.5.2.2 2005/04/10 23:14:42 kennykb Exp $ '\" .so man.macros .TH Tcl_PrintDouble 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_PrintDouble \- Convert floating value to string .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR) .SH ARGUMENTS .AS Tcl_Interp *interp out .AP Tcl_Interp *interp in Before Tcl 8.0, the \fBtcl_precision\fR variable in this interpreter controlled the conversion. As of Tcl 8.0, this argument is ignored and the conversion is controlled by the \fBtcl_precision\fR variable that is now shared by all interpreters. .AP double value in Floating-point value to be converted. .AP char *dst out Where to store the string representing \fIvalue\fR. Must have at least \fBTCL_DOUBLE_SPACE\fR characters of storage. .BE .SH DESCRIPTION .PP \fBTcl_PrintDouble\fR generates a string that represents the value of \fIvalue\fR and stores it in memory at the location given by \fIdst\fR. It uses \fB%g\fR format to generate the string, with one special twist: the string is guaranteed to contain either a ``.'' or an ``e'' so that it doesn't look like an integer. Where \fB%g\fR would generate an integer with no decimal point, \fBTcl_PrintDouble\fR adds ``.0''. .VS 8.5 .PP If the \fBtcl_precision\fR value is non-zero, the result will have precisely that many digits of significance. If the value is zero (the default), the result will have the fewest digits needed to represent the number in such a way that \fBTcl_NewDoubleObj\fR will generate the same number when presented with the given string. IEEE semantics of rounding to even apply to the conversion. .VE .SH KEYWORDS conversion, double-precision, floating-point, string |
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 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 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.20.2.2 2005/05/05 17:55:22 kennykb 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 .nf \fB#include <tcl.h>\fR .sp int \fBTcl_RegExpMatchObj\fR(\fIinterp\fR, \fItextObj\fR, \fIpatObj\fR) .sp int \fBTcl_RegExpMatch\fR(\fIinterp\fR, \fItext\fR, \fIpattern\fR) .sp Tcl_RegExp \fBTcl_RegExpCompile\fR(\fIinterp\fR, \fIpattern\fR) .sp int \fBTcl_RegExpExec\fR(\fIinterp\fR, \fIregexp\fR, \fItext\fR, \fIstart\fR) .sp void \fBTcl_RegExpRange\fR(\fIregexp\fR, \fIindex\fR, \fIstartPtr\fR, \fIendPtr\fR) .sp Tcl_RegExp \fBTcl_GetRegExpFromObj\fR(\fIinterp\fR, \fIpatObj\fR, \fIcflags\fR) .sp int \fBTcl_RegExpExecObj\fR(\fIinterp\fR, \fIregexp\fR, \fItextObj\fR, \fIoffset\fR, \fInmatches\fR, \fIeflags\fR) .sp void \fBTcl_RegExpGetInfo\fR(\fIregexp\fR, \fIinfoPtr\fR) .SH ARGUMENTS .AS Tcl_RegExpInfo *interp in/out .AP Tcl_Interp *interp in Tcl interpreter to use for error reporting. The interpreter may be NULL if no error reporting is desired. .AP Tcl_Obj *textObj in/out Refers to the object from which to get the text to search. The internal representation of the object may be converted to a form that can be efficiently searched. .AP Tcl_Obj *patObj in/out Refers to the object from which to get a regular expression. The compiled regular expression is cached in the object. .AP char *text in Text to search for a match with a regular expression. .AP "const char" *pattern in String in the form of a regular expression pattern. .AP Tcl_RegExp regexp in Compiled regular expression. Must have been returned previously by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR. .AP char *start in If \fItext\fR is just a portion of some other string, this argument identifies the beginning of the larger string. If it isn't the same as \fItext\fR, then no \fB^\fR matches will be allowed. .AP int index in Specifies which range is desired: 0 means the range of the entire match, 1 or greater means the range that matched a parenthesized sub-expression. .AP "const char" **startPtr out The address of the first character in the range is stored here, or NULL if there is no such range. .AP "const char" **endPtr out The address of the character just after the last one in the range is stored here, or NULL if there is no such range. .AP int cflags in OR-ed combination of compilation flags. See below for more information. .AP int offset in The character offset into the text where matching should begin. The value of the offset has no impact on \fB^\fR matches. This behavior is controlled by \fIeflags\fR. .AP int nmatches in The number of matching subexpressions that should be remembered for later use. If this value is 0, then no subexpression match information will be computed. If the value is -1, then all of the matching subexpressions will be remembered. Any other |
︙ | ︙ | |||
111 112 113 114 115 116 117 | reference page. If there is a match then \fBTcl_RegExpMatch\fR returns 1. If there is no match then \fBTcl_RegExpMatch\fR returns 0. If an error occurs in the matching process (e.g. \fIpattern\fR is not a valid regular expression) then \fBTcl_RegExpMatch\fR returns \-1 and leaves an error message in the interpreter result. \fBTcl_RegExpMatchObj\fR is similar to \fBTcl_RegExpMatch\fR except it | | | | | | | | 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 | reference page. If there is a match then \fBTcl_RegExpMatch\fR returns 1. If there is no match then \fBTcl_RegExpMatch\fR returns 0. If an error occurs in the matching process (e.g. \fIpattern\fR is not a valid regular expression) then \fBTcl_RegExpMatch\fR returns \-1 and leaves an error message in the interpreter result. \fBTcl_RegExpMatchObj\fR is similar to \fBTcl_RegExpMatch\fR except it operates on the Tcl objects \fItextObj\fR and \fIpatObj\fR instead of UTF strings. \fBTcl_RegExpMatchObj\fR is generally more efficient than \fBTcl_RegExpMatch\fR, so it is the preferred interface. .PP \fBTcl_RegExpCompile\fR, \fBTcl_RegExpExec\fR, and \fBTcl_RegExpRange\fR provide lower-level access to the regular expression pattern matcher. \fBTcl_RegExpCompile\fR compiles a regular expression string into the internal form used for efficient pattern matching. The return value is a token for this compiled form, which can be used in subsequent calls to \fBTcl_RegExpExec\fR or \fBTcl_RegExpRange\fR. If an error occurs while compiling the regular expression then \fBTcl_RegExpCompile\fR returns NULL and leaves an error message in the interpreter result. Note: the return value from \fBTcl_RegExpCompile\fR is only valid up to the next call to \fBTcl_RegExpCompile\fR; it is not safe to retain these values for long periods of time. .PP \fBTcl_RegExpExec\fR executes the regular expression pattern matcher. It returns 1 if \fItext\fR contains a range of characters that match \fIregexp\fR, 0 if no match is found, and \-1 if an error occurs. In the case of an error, \fBTcl_RegExpExec\fR leaves an error message in the interpreter result. When searching a string for multiple matches of a pattern, it is important to distinguish between the start of the original string and the start of the current search. For example, when searching for the second occurrence of a match, the \fItext\fR argument might point to the character just after the first match; however, it is important for the pattern matcher to know that this is not the start of the entire string, so that it doesn't allow \fB^\fR atoms in the pattern to match. The \fIstart\fR argument provides this information by pointing to the start of the overall string containing \fItext\fR. \fIStart\fR will be less than or equal to \fItext\fR; if it is less than \fItext\fR then no \fB^\fR matches will be allowed. .PP \fBTcl_RegExpRange\fR may be invoked after \fBTcl_RegExpExec\fR returns; it provides detailed information about what ranges of the string matched what parts of the pattern. \fBTcl_RegExpRange\fR returns a pair of pointers in \fI*startPtr\fR and \fI*endPtr\fR that identify a range of characters in the source string for the most recent call to \fBTcl_RegExpExec\fR. |
︙ | ︙ |
Changes to doc/SaveResult.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1997 by Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | '\" '\" Copyright (c) 1997 by Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (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: SaveResult.3,v 1.4.2.2 2005/04/10 23:14:42 kennykb Exp $ '\" .so man.macros .TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- save and restore an interpreter's state .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_InterpState \fBTcl_SaveInterpState\fR(\fIinterp, status\fR) .sp int \fBTcl_RestoreInterpState\fR(\fIinterp, state\fR) .sp \fBTcl_DiscardInterpState\fR(\fIstate\fR) .sp \fBTcl_SaveResult\fR(\fIinterp, savedPtr\fR) .sp \fBTcl_RestoreResult\fR(\fIinterp, savedPtr\fR) .sp \fBTcl_DiscardResult\fR(\fIsavedPtr\fR) .SH ARGUMENTS .AS Tcl_InterpState savedPtr .AP Tcl_Interp *interp in Interpreter for which state should be saved. .AP int status in Return code value to save as part of interpreter state. .AP Tcl_InterpState state in |
︙ | ︙ | |||
62 63 64 65 66 67 68 | that is used to store enough information to restore the interpreter result. This structure can be allocated on the stack of the calling procedure. These routines do not save the state of any error information in the interpreter (e.g. the \fB-errorcode\fR or \fB-errorinfo\fR return options, when an error is in progress). .PP Because the routines \fBTcl_SaveInterpState\fR, | | | | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | that is used to store enough information to restore the interpreter result. This structure can be allocated on the stack of the calling procedure. These routines do not save the state of any error information in the interpreter (e.g. the \fB-errorcode\fR or \fB-errorinfo\fR return options, when an error is in progress). .PP Because the routines \fBTcl_SaveInterpState\fR, \fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR perform a superset of the functions provided by the other routines, any new code should only make use of the more powerful routines. The older, weaker routines \fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, and \fBTcl_DiscardResult\fR continue to exist only for the sake of existing programs that may already be using them. .PP \fBTcl_SaveInterpState\fR takes a snapshot of those portions of interpreter state that make up the full result of script evaluation. This include the interpreter result, the return code (passed in as the \fIstatus\fR argument, and any return options, including \fB-errorinfo\fR and \fB-errorcode\fR when an error is in progress. |
︙ | ︙ | |||
95 96 97 98 99 100 101 | snapshot is not to be restored to an interp. .PP The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR must eventually be passed to either \fBTcl_RestoreInterpState\fR or \fBTcl_DiscardInterpState\fR to avoid a memory leak. Once the \fBTcl_InterpState\fR token is passed to one of them, the token is no longer valid and should not be used anymore. | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | snapshot is not to be restored to an interp. .PP The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR must eventually be passed to either \fBTcl_RestoreInterpState\fR or \fBTcl_DiscardInterpState\fR to avoid a memory leak. Once the \fBTcl_InterpState\fR token is passed to one of them, the token is no longer valid and should not be used anymore. .VE 8.5 .PP \fBTcl_SaveResult\fR moves the string and object results of \fIinterp\fR into the location specified by \fIstatePtr\fR. \fBTcl_SaveResult\fR clears the result for \fIinterp\fR and leaves the result in its normal empty initialized state. .PP \fBTcl_RestoreResult\fR moves the string and object results from |
︙ | ︙ |
Added doc/SetChanErr.3.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | '\" '\" Copyright (c) 2005 Andreas Kupries <[email protected]> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: SetChanErr.3,v 1.1.2.2 2005/08/25 15:46:30 dgp Exp $ .so man.macros .TH Tcl_SetChannelError 3 8.5 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_SetChannelError, Tcl_SetChannelErrorInterp, Tcl_GetChannelError, Tcl_GetChannelErrorInterp \- functions to create/intercept Tcl errors by channel drivers. .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void \fBTcl_SetChannelError\fR(\fIchan, msg\fR) .sp void \fBTcl_SetChannelErrorInterp\fR(\fIinterp, msg\fR) .sp void \fBTcl_GetChannelError\fR(\fIchan, msgPtr\fR) .sp void \fBTcl_GetChannelErrorInterp\fR(\fIinterp, msgPtr\fR) .sp .SH ARGUMENTS .AS Tcl_Channel chan .AP Tcl_Channel chan in Refers to the Tcl channel whose bypass area is accessed. .AP Tcl_Interp* interp in Refers to the Tcl interpreter whose bypass area is accessed. .AP Tcl_Obj* msg in Error message put into a bypass area. A list of return options and values, followed by a string message. Both message and the option/value information are optional. .AP Tcl_Obj** msgPtr out Reference to a place where the message stored in the accessed bypass area can be stored in. .BE .SH DESCRIPTION .PP The current definition of a Tcl channel driver does not permit the direct return of arbitrary error messages, except for the setting and retrieval of channel options. All other functions are restricted to POSIX error codes. .PP The functions described here overcome this limitation. Channel drivers are allowed to use \fBTcl_SetChannelError\fR and \fBTcl_SetChannelErrorInterp\fR to place arbitrary error messages in \fBbypass areas\fI defined for channels and interpreters. And the generic I/O layer uses \fBTcl_GetChannelError\fR and \fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass areas and arrange for their return as errors. The posix error codes set by a driver are used now if and only if no messages are present. .PP \fBTcl_SetChannelError\fR stores error information in the bypass area of the specified channel. The number of references to the \fBmsg\fI object goes up by one. Previously stored information will be discarded, by releasing the reference held by the channel. The channel reference must not be NULL. .PP \fBTcl_SetChannelErrorInterp\fR stores error information in the bypass area of the specified interpreter. The number of references to the \fBmsg\fI object goes up by one. Previously stored information will be discarded, by releasing the reference held by the interpreter. The interpreter reference must not be NULL. .PP \fBTcl_GetChannelError\fR places either the error message held in the bypass area of the specified channel into \fImsgPtr\fR, or NULL; and resets the bypass. I.e. after an invokation all following invokations will return NULL, until an intervening invokation of \fBTcl_SetChannelError\fR with a non-NULL message. The \fImsgPtr\fR must not be NULL. The reference count of the message is not touched. The reference previously held by the channel is now held by the caller of the function and it is its responsibility to release that reference when it is done with the object. .PP \fBTcl_GetChannelErrorInterp\fR places either the error message held in the bypass area of the specified interpreter into \fImsgPtr\fR, or NULL; and resets the bypass. I.e. after an invokation all following invokations will return NULL, until an intervening invokation of \fBTcl_SetChannelErrorInterp\fR with a non-NULL message. The \fImsgPtr\fR must not be NULL. The reference count of the message is not touched. The reference previously held by the interpreter is now held by the caller of the function and it is its responsibility to release that reference when it is done with the object. .PP Which functions of a channel driver are allowed to use which bypass function is listed below, as is which functions of the public channel API may leave a messages in the bypass areas. .PP .IP \fBTcl_DriverCloseProc\fR May use \fBTcl_SetChannelErrorInterp\fR, and only this function. .IP \fBTcl_DriverInputProc\fR May use \fBTcl_SetChannelError\fR, and only this function. .IP \fBTcl_DriverOutputProc\fR May use \fBTcl_SetChannelError\fR, and only this function. .IP \fBTcl_DriverSeekProc\fR May use \fBTcl_SetChannelError\fR, and only this function. .IP \fBTcl_DriverWideSeekProc May use \fBTcl_SetChannelError\fR, and only this function. .IP \fBTcl_DriverSetOptionProc\fR Has already the ability to pass arbitrary error messages. Must \fBnot\fR use any of the new functions. .IP \fBTcl_DriverGetOptionProc\fR Has already the ability to pass arbitrary error messages. Must \fBnot\fR use any of the new functions. .IP \fBTcl_DriverWatchProc\fR Must \fBnot\fR use any of the new functions. Is internally called and has no ability to return any type of error whatsoever. .IP \fBTcl_DriverBlockModeProc\fR May use \fBTcl_SetChannelError\fR, and only this function. .IP \fBTcl_DriverGetHandleProc\fR Must \fBnot\fR use any of the new functions. It is only a low-level function, and not used by Tcl commands. .IP \fBTcl_DriverHandlerProc\fR Must \fBnot\fR use any of the new functions. Is internally called and has no ability to return any type of error whatsoever. .PP Given the information above the following public functions of the Tcl C API are affected by these changes. I.e. when these functions are called the channel may now contain a stored arbitrary error message requiring processing by the caller. .PP .IP \fBTcl_StackChannel\fR .IP \fBTcl_Seek\fR .IP \fBTcl_Tell\fR .IP \fBTcl_ReadRaw\fR .IP \fBTcl_Read\fR .IP \fBTcl_ReadChars\fR .IP \fBTcl_Gets\fR .IP \fBTcl_GetsObj\fR .IP \fBTcl_Flush\fR .IP \fBTcl_WriteRaw\fR .IP \fBTcl_WriteObj\fR .IP \fBTcl_Write\fR .IP \fBTcl_WriteChars\fR .PP All other API functions are unchanged. Especially the functions below leave all their error information in the interpreter result. .PP .IP \fBTcl_Close\fR .IP \fBTcl_UnregisterChannel\fR .IP \fBTcl_UnstackChannel\fR .PP .SH "SEE ALSO" Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3) .SH KEYWORDS channel driver, error messages, channel type |
Changes to doc/SetResult.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 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | '\" '\" Copyright (c) 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: SetResult.3,v 1.11.2.2 2005/09/15 20:58:38 dgp Exp $ '\" .so man.macros .TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_FreeResult \- manipulate Tcl result .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_SetObjResult\fR(\fIinterp, objPtr\fR) .sp Tcl_Obj * \fBTcl_GetObjResult\fR(\fIinterp\fR) .sp \fBTcl_SetResult\fR(\fIinterp, result, freeProc\fR) .sp const char * \fBTcl_GetStringResult\fR(\fIinterp\fR) .sp \fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fB(char *) NULL\fR) .sp \fBTcl_AppendResultVA\fR(\fIinterp, argList\fR) .sp \fBTcl_AppendElement\fR(\fIinterp, element\fR) .sp \fBTcl_ResetResult\fR(\fIinterp\fR) .sp \fBTcl_FreeResult\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_FreeProc freeProc out .AP Tcl_Interp *interp out Interpreter whose result is to be modified or read. .AP Tcl_Obj *objPtr in Object value to become result for \fIinterp\fR. .AP char *result in String value to become result for \fIinterp\fR or to be appended to the existing result. .AP char *element in String value to append as a list element to the existing result of \fIinterp\fR. .AP Tcl_FreeProc *freeProc in Address of procedure to call to release storage at \fIresult\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or \fBTCL_VOLATILE\fR. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .BE .SH DESCRIPTION .PP The procedures described here are utilities for manipulating the result value in a Tcl interpreter. The interpreter result may be either a Tcl object or a string. |
︙ | ︙ | |||
83 84 85 86 87 88 89 | \fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as an object. The object's reference count is not incremented; if the caller needs to retain a long-term pointer to the object they should use \fBTcl_IncrRefCount\fR to increment its reference count in order to keep it from being freed too early or accidentally changed. .PP \fBTcl_SetResult\fR | | | | | | | | | | | 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 | \fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as an object. The object's reference count is not incremented; if the caller needs to retain a long-term pointer to the object they should use \fBTcl_IncrRefCount\fR to increment its reference count in order to keep it from being freed too early or accidentally changed. .PP \fBTcl_SetResult\fR arranges for \fIresult\fR to be the result for the current Tcl command in \fIinterp\fR, replacing any existing result. The \fIfreeProc\fR argument specifies how to manage the storage for the \fIresult\fR argument; it is discussed in the section \fBTHE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below. If \fIresult\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored and \fBTcl_SetResult\fR re-initializes \fIinterp\fR's result to point to an empty string. .PP \fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string. If the result was set to an object by a \fBTcl_SetObjResult\fR call, the object form will be converted to a string and returned. If the object's string representation contains null bytes, this conversion will lose information. For this reason, programmers are encouraged to write their code to use the new object API procedures and to call \fBTcl_GetObjResult\fR instead. .PP \fBTcl_ResetResult\fR clears the result for \fIinterp\fR and leaves the result in its normal empty initialized state. If the result is an object, its reference count is decremented and the result is left pointing to an unshared object representing an empty string. If the result is a dynamically allocated string, its memory is free*d and the result is left as a empty string. \fBTcl_ResetResult\fR also clears the error state managed by \fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR, and \fBTcl_SetErrorCode\fR. .PP \fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces. It takes each of its \fIresult\fR arguments and appends them in order to the current result associated with \fIinterp\fR. If the result is in its initialized empty state (e.g. a command procedure was just invoked or \fBTcl_ResetResult\fR was just called), then \fBTcl_AppendResult\fR sets the result to the concatenation of its \fIresult\fR arguments. \fBTcl_AppendResult\fR may be called repeatedly as additional pieces of the result are produced. \fBTcl_AppendResult\fR takes care of all the storage management issues associated with managing \fIinterp\fR's result, such as allocating a larger result area if necessary. It also manages conversion to and from the \fIresult\fR field of the \fIinterp\fR so as to handle backward-compatability with old-style extensions. Any number of \fIresult\fR arguments may be passed in a single call; the last argument in the list must be a NULL pointer. .PP \fBTcl_AppendResultVA\fR is the same as \fBTcl_AppendResult\fR except that instead of taking a variable number of arguments it takes an argument list. .SH "OLD STRING PROCEDURES" .PP Use of the following procedures (is deprecated since they manipulate the Tcl result as a string. Procedures such as \fBTcl_SetObjResult\fR that manipulate the result as an object can be significantly more efficient. .PP \fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in that it allows results to be built up in pieces. However, \fBTcl_AppendElement\fR takes only a single \fIelement\fR argument and it appends that argument to the current result as a proper Tcl list element. \fBTcl_AppendElement\fR adds backslashes or braces if necessary to ensure that \fIinterp\fR's result can be parsed as a list and that \fIelement\fR will be extracted as a single element. Under normal conditions, \fBTcl_AppendElement\fR will add a space character to \fIinterp\fR's result just before adding the new list element, so that the list elements in the result are properly separated. However if the new list element is the first in a list or sub-list (i.e. \fIinterp\fR's current result is empty, or consists of the single character ``{'', or ends in the characters `` {'') then no |
︙ | ︙ | |||
181 182 183 184 185 186 187 | Programs should always read the result using the procedures \fBTcl_GetObjResult\fR or \fBTcl_GetStringResult\fR, and write the result using \fBTcl_SetObjResult\fR or \fBTcl_SetResult\fR. .SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT" .PP \fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how | | | | | | | 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 | Programs should always read the result using the procedures \fBTcl_GetObjResult\fR or \fBTcl_GetStringResult\fR, and write the result using \fBTcl_SetObjResult\fR or \fBTcl_SetResult\fR. .SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT" .PP \fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how the Tcl system is to manage the storage for the \fIresult\fR argument. If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called at a time when \fIinterp\fR holds a string result, they do whatever is necessary to dispose of the old string result (see the \fBTcl_Interp\fR manual entry for details on this). .PP If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIresult\fR refers to an area of static storage that is guaranteed not to be modified until at least the next call to \fBTcl_Eval\fR. If \fIfreeProc\fR is \fBTCL_DYNAMIC\fR it means that \fIresult\fR was allocated with a call to \fBTcl_Alloc\fR and is now the property of the Tcl system. \fBTcl_SetResult\fR will arrange for the string's storage to be released by calling \fBTcl_Free\fR when it is no longer needed. If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIresult\fR points to an area of memory that is likely to be overwritten when \fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame). In this case \fBTcl_SetResult\fR will make a copy of the string in dynamically allocated storage and arrange for the copy to be the result for the current Tcl command. .PP If \fIfreeProc\fR isn't one of the values \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, and \fBTCL_VOLATILE\fR, then it is the address of a procedure that Tcl should call to free the string. This allows applications to use non-standard storage allocators. When Tcl no longer needs the storage for the string, it will call \fIfreeProc\fR. \fIFreeProc\fR should have arguments and result that match the type \fBTcl_FreeProc\fR: .CS typedef void Tcl_FreeProc(char *\fIblockPtr\fR); .CE When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to the value of \fIresult\fR passed to \fBTcl_SetResult\fR. .SH "SEE ALSO" Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp .SH KEYWORDS append, command, element, list, object, result, return value, interpreter |
Changes to doc/StrMatch.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 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | '\" '\" 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: StrMatch.3,v 1.6.2.2 2005/05/05 17:55:24 kennykb Exp $ '\" .so man.macros .TH Tcl_StringMatch 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_StringMatch, Tcl_StringCaseMatch \- test whether a string matches a pattern .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_StringMatch\fR(\fIstr\fR, \fIpattern\fR) .sp int \fBTcl_StringCaseMatch\fR(\fIstr\fR, \fIpattern\fR, \fInocase\fR) .SH ARGUMENTS .AS "const char" *pattern .AP "const char" *str in String to test. .AP "const char" *pattern in Pattern to match against string. May contain special characters from the set *?\e[]. .AP int nocase in Specifies whether the match should be done case-sensitive (0) or case-insensitive (1). .BE .SH DESCRIPTION .PP This utility procedure determines whether a string matches a given pattern. If it does, then \fBTcl_StringMatch\fR returns 1. Otherwise \fBTcl_StringMatch\fR returns 0. The algorithm used for matching is the same algorithm used in the ``string match'' Tcl command and is similar to the algorithm used by the C-shell for file name matching; see the Tcl manual entry for details. .PP In \fBTcl_StringCaseMatch\fR, the algorithm is the same, but you have the option to make the matching case-insensitive. If you choose this (by passing \fBnocase\fR as 1), then the string and pattern are essentially matched in the lower case. .SH KEYWORDS match, pattern, string |
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.17.2.2 2005/09/15 20:58:39 dgp Exp $ '\" .so man.macros .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj, Tcl_AttemptSetObjLength \- manipulate Tcl objects as strings .SH SYNOPSIS |
︙ | ︙ | |||
70 71 72 73 74 75 76 | \fBTcl_AttemptSetObjLength\fR(\fIobjPtr, newLength\fR) .sp Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in | < < | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | \fBTcl_AttemptSetObjLength\fR(\fIobjPtr, newLength\fR) .sp Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes used to set or append to a string object. This byte array may contain embedded null characters unless \fInumChars\fR is negative. (Applications needing null bytes should represent them as the two-byte sequence \fI\\700\\600\fR, use \fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if the string is a collection of uninterpreted bytes.) .AP int length in The number of bytes to copy from \fIbytes\fR when initializing, setting, or appending to a string object. If negative, all bytes up to the first null are used. .AP "const Tcl_UniChar" *unicode in Points to the first byte of an array of Unicode characters used to set or append to a string object. |
︙ | ︙ | |||
111 112 113 114 115 116 117 | .AP int *lengthPtr out If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store the length of an object's string representation. .AP "const char" *string in Null-terminated string value to append to \fIobjPtr\fR. .AP va_list argList in An argument list which must have been initialised using | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | .AP int *lengthPtr out If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store the length of an object's string representation. .AP "const char" *string in Null-terminated string value to append to \fIobjPtr\fR. .AP va_list argList in An argument list which must have been initialised using \fBva_start\fR, and cleared using \fBva_end\fR. .AP int newLength in New length for the string value of \fIobjPtr\fR, not including the final null character. .AP int objc in The number of elements to concatenate. .AP Tcl_Obj *objv[] in The array of objects to concatenate. |
︙ | ︙ |
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.20.2.2 2005/03/02 21:25:19 kennykb 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 |
︙ | ︙ | |||
92 93 94 95 96 97 98 | and use multiple interpreters.) .SH DESCRIPTION Tcl provides \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 | | | | | 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 | and use multiple interpreters.) .SH DESCRIPTION Tcl provides \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 only the values \fBTCL_THREAD_NOFLAGS\fR and \fBTCL_THREAD_JOINABLE\fR are 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 stack size of a thread. The specified value for the stack size is ignored on these systems. Windows currently does not support joinable threads. This flag value is therefore ignored on this platform. .PP Tcl provides the \fBTcl_ExitThread\fR and \fBTcl_FinalizeThread\fR functions for terminating threads and invoking optional per-thread exit handlers. See the \fBTcl_Exit\fR page for more information on these procedures. .PP The \fBTcl_JoinThread\fR function is provided to allow threads to wait upon the exit of another thread, which must have been marked as joinable through usage of the \fBTCL_THREAD_JOINABLE\fR-flag during |
︙ | ︙ | |||
187 188 189 190 191 192 193 | manage, or join threads, nor any script-level access to mutex or condition variables. It provides such facilities only via C interfaces, and leaves it up to packages to expose these matters to the script level. One such package is the \fBThread\fR package. .VE 8.5 .SH "SEE ALSO" Tcl_GetCurrentThread(3), Tcl_ThreadQueueEvent(3), Tcl_ThreadAlert(3), | | | < | 187 188 189 190 191 192 193 194 195 196 197 | manage, or join threads, nor any script-level access to mutex or condition variables. It provides such facilities only via C interfaces, and leaves it up to packages to expose these matters to the script level. One such package is the \fBThread\fR package. .VE 8.5 .SH "SEE ALSO" Tcl_GetCurrentThread(3), Tcl_ThreadQueueEvent(3), Tcl_ThreadAlert(3), Tcl_ExitThread(3), Tcl_FinalizeThread(3), Tcl_CreateThreadExitHandler(3), Tcl_DeleteThreadExitHandler(3), Thread .SH KEYWORDS thread, mutex, condition variable, thread local storage |
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.13.2.1 2005/04/10 23:14:42 kennykb 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 |
︙ | ︙ | |||
104 105 106 107 108 109 110 | \fBTCL_TRACE_ARRAY\fR Invoke \fIproc\fR whenever the array command is invoked. This gives the trace procedure a chance to update the array before array names or array get is called. Note that this is called before an array set, but that will trigger write traces. .TP \fBTCL_TRACE_RESULT_DYNAMIC\fR | < < < < | 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 | \fBTCL_TRACE_ARRAY\fR Invoke \fIproc\fR whenever the array command is invoked. This gives the trace procedure a chance to update the array before array names or array get is called. Note that this is called before an array set, but that will trigger write traces. .TP \fBTCL_TRACE_RESULT_DYNAMIC\fR The result of invoking the \fIproc\fR is a dynamically allocated string that will be released by the Tcl library via a call to \fBckfree\fR. Must not be specified at the same time as \fBTCL_TRACE_RESULT_OBJECT\fR. .TP \fBTCL_TRACE_RESULT_OBJECT\fR The result of invoking the \fIproc\fR is a Tcl_Obj* (cast to a char*) with a reference count of at least one. The ownership of that reference will be transferred to the Tcl core for release (when the core has finished with it) via a call to \fBTcl_DecrRefCount\fR. Must not be specified at the same time as \fBTCL_TRACE_RESULT_DYNAMIC\fR. .PP Whenever one of the specified operations occurs on the variable, \fIproc\fR will be invoked. It should have arguments and result that match the type \fBTcl_VarTraceProc\fR: .CS typedef char *Tcl_VarTraceProc( |
︙ | ︙ | |||
205 206 207 208 209 210 211 | .PP The procedures \fBTcl_TraceVar2\fR, \fBTcl_UntraceVar2\fR, and \fBTcl_VarTraceInfo2\fR are identical to \fBTcl_TraceVar\fR, \fBTcl_UntraceVar\fR, and \fBTcl_VarTraceInfo\fR, respectively, except that the name of the variable consists of two parts. \fIName1\fR gives the name of a scalar variable or array, and \fIname2\fR gives the name of an element within an array. | < < | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 | .PP The procedures \fBTcl_TraceVar2\fR, \fBTcl_UntraceVar2\fR, and \fBTcl_VarTraceInfo2\fR are identical to \fBTcl_TraceVar\fR, \fBTcl_UntraceVar\fR, and \fBTcl_VarTraceInfo\fR, respectively, except that the name of the variable consists of two parts. \fIName1\fR gives the name of a scalar variable or array, and \fIname2\fR gives the name of an element within an array. When \fIname2\fR is NULL, \fIname1\fR may contain both an array and an element name: if the name contains an open parenthesis and ends with a close parenthesis, then the value between the parentheses is treated as an element name (which can have any string value) and the characters before the first open parenthesis are treated as the name of an array variable. If \fIname2\fR is NULL and \fIname1\fR does not refer to an array element it means that either the variable is a scalar or the trace is to be set on the entire array rather than an individual element (see WHOLE-ARRAY TRACES below for more information). .SH "ACCESSING VARIABLES DURING TRACES" |
︙ | ︙ | |||
321 322 323 324 325 326 327 | .PP Under normal conditions trace procedures should return NULL, indicating successful completion. If \fIproc\fR returns a non-NULL value it signifies that an error occurred. The return value must be a pointer to a static character string containing an error message, | < < | 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 | .PP Under normal conditions trace procedures should return NULL, indicating successful completion. If \fIproc\fR returns a non-NULL value it signifies that an error occurred. The return value must be a pointer to a static character string containing an error message, unless (\fIexactly\fR one of) the \fBTCL_TRACE_RESULT_DYNAMIC\fR and \fBTCL_TRACE_RESULT_OBJECT\fR flags is set, which specify that the result is either a dynamic string (to be released with \fBckfree\fR) or a Tcl_Obj* (cast to char* and to be released with \fBTcl_DecrRefCount\fR) containing the error message. If a trace procedure returns an error, no further traces are invoked for the access and the traced access aborts with the given message. Trace procedures can use this facility to make variables read-only, for example (but note that the value of the variable will already have been modified before the trace procedure is called, so the trace procedure will have to restore the correct |
︙ | ︙ |
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 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 | '\" '\" 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.20.2.2 2005/05/05 17:55:24 kennykb 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 .nf \fB#include <tcl.h>\fR .sp typedef ... Tcl_UniChar; .sp int \fBTcl_UniCharToUtf\fR(\fIch, buf\fR) .sp int \fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR) .sp char * \fBTcl_UniCharToUtfDString\fR(\fIuniStr, uniLength, dsPtr\fR) .sp Tcl_UniChar * \fBTcl_UtfToUniCharDString\fR(\fIsrc, length, dsPtr\fR) .sp int \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int \fBTcl_UniCharNcmp\fR(\fIucs, uct, numChars\fR) .sp int \fBTcl_UniCharNcasecmp\fR(\fIucs, uct, numChars\fR) .sp int \fBTcl_UniCharCaseMatch\fR(\fIuniStr, uniPattern, nocase\fR) .sp int \fBTcl_UtfNcmp\fR(\fIcs, ct, numChars\fR) .sp int \fBTcl_UtfNcasecmp\fR(\fIcs, ct, numChars\fR) .sp int \fBTcl_UtfCharComplete\fR(\fIsrc, length\fR) .sp int \fBTcl_NumUtfChars\fR(\fIsrc, length\fR) .sp const char * \fBTcl_UtfFindFirst\fR(\fIsrc, ch\fR) .sp const char * \fBTcl_UtfFindLast\fR(\fIsrc, ch\fR) .sp const char * \fBTcl_UtfNext\fR(\fIsrc\fR) .sp const char * \fBTcl_UtfPrev\fR(\fIsrc, start\fR) .sp Tcl_UniChar \fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR) .sp const char * \fBTcl_UtfAtIndex\fR(\fIsrc, index\fR) .sp int \fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *uniPattern in/out .AP char *buf out Buffer in which the UTF-8 representation of the Tcl_UniChar is stored. At most \fBTCL_UTF_MAX\fR bytes are stored in the buffer. .AP int ch in The Tcl_UniChar to be converted or examined. .AP Tcl_UniChar *chPtr out Filled with the Tcl_UniChar represented by the head of the UTF-8 string. .AP "const char" *src in Pointer to a UTF-8 string. .AP "const char" *cs in Pointer to a UTF-8 string. .AP "const char" *ct in Pointer to a UTF-8 string. .AP "const Tcl_UniChar" *uniStr in A null-terminated Unicode string. .AP "const Tcl_UniChar" *ucs in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uct in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uniPattern in A null-terminated Unicode string. .AP int length in The length of the UTF-8 string in bytes (not UTF-8 characters). If negative, all bytes up to the first null byte are used. .AP int uniLength in The length of the Unicode string in characters. Must be greater than or equal to 0. .AP "Tcl_DString" *dsPtr in/out A pointer to a previously initialized \fBTcl_DString\fR. .AP "unsigned long" numChars in The number of characters to compare. .AP "const char" *start in Pointer to the beginning of a UTF-8 string. .AP int index in The index of a character (not byte) in the UTF-8 string. .AP int *readPtr out If non-NULL, filled with the number of bytes in the backslash sequence, including the backslash character. .AP char *dst out Buffer in which the bytes represented by the backslash sequence are stored. At most \fBTCL_UTF_MAX\fR bytes are stored in the buffer. .AP int nocase in Specifies whether the match should be done case-sensitive (0) or case-insensitive (1). .BE .SH DESCRIPTION .PP These routines convert between UTF-8 strings and Tcl_UniChars. A Tcl_UniChar is a Unicode character represented as an unsigned, fixed-size quantity. A UTF-8 character is a Unicode character represented as |
︙ | ︙ | |||
146 147 148 149 150 151 152 | is known to be null-terminated, this will not happen. If the input is not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x0000 and 0x00ff and return 1. .PP \fBTcl_UniCharToUtfDString\fR converts the given Unicode string to UTF-8, storing the result in a previously initialized \fBTcl_DString\fR. | | | > | | < < | | | | 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 | is known to be null-terminated, this will not happen. If the input is not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x0000 and 0x00ff and return 1. .PP \fBTcl_UniCharToUtfDString\fR converts the given Unicode string to UTF-8, storing the result in a previously initialized \fBTcl_DString\fR. You must specify \fIuniLength\fR, 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. In the argument \fIlength\fR, you may either specify the length of the given UTF-8 string in bytes or "-1", in which case \fBTcl_UtfToUniCharDString\fR uses \fBstrlen\fR to calculate the length. The return value is a pointer to the Unicode representation of the UTF-8 string. Storage for the return value is appended to the end of the \fBTcl_DString\fR. The Unicode string is terminated with a Unicode null character. .PP \fBTcl_UniCharLen\fR corresponds to \fBstrlen\fR for Unicode characters. It accepts a null-terminated Unicode string and returns the number of Unicode characters (not bytes) in that string. .PP \fBTcl_UniCharNcmp\fR and \fBTcl_UniCharNcasecmp\fR correspond to \fBstrncmp\fR and \fBstrncasecmp\fR, respectively, for Unicode characters. They accept two null-terminated Unicode strings and the number of characters to compare. Both strings are assumed to be at least \fInumChars\fR characters long. \fBTcl_UniCharNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the first string is greater than, equal to, or less than the second string respectively. \fBTcl_UniCharNcasecmp\fR is the Unicode case insensitive version. .PP \fBTcl_UniCharCaseMatch\fR is the Unicode equivalent to \fBTcl_StringCaseMatch\fR. It accepts a null-terminated Unicode string, a Unicode pattern, and a boolean value specifying whether the match should be case sensitive and returns whether the string matches the pattern. .PP \fBTcl_UtfNcmp\fR corresponds to \fBstrncmp\fR for UTF-8 strings. It accepts two null-terminated UTF-8 strings and the number of characters to compare. (Both strings are assumed to be at least \fInumChars\fR characters long.) \fBTcl_UtfNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the first string is greater than, equal to, or less than the second string respectively. .PP \fBTcl_UtfNcasecmp\fR corresponds to \fBstrncasecmp\fR for UTF-8 strings. It is similar to \fBTcl_UtfNcmp\fR except comparisons ignore differences in case when comparing upper, lower or title case characters. .PP \fBTcl_UtfCharComplete\fR returns 1 if the source UTF-8 string \fIsrc\fR of \fIlength\fR bytes is long enough to be decoded by \fBTcl_UtfToUniChar\fR, or 0 otherwise. This function does not guarantee that the UTF-8 string is properly formed. This routine is used by procedures that are operating on a byte at a time and need to know if a full Tcl_UniChar has been seen. .PP \fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings. It returns the number of Tcl_UniChars that are represented by the UTF-8 string \fIsrc\fR. The length of the source string is \fIlength\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 |
︙ | ︙ |
Changes to doc/array.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: array.n,v 1.13.2.1 2005/04/10 23:14:42 kennykb Exp $ '\" .so man.macros .TH array n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME array \- Manipulate array variables |
︙ | ︙ | |||
118 119 120 121 122 123 124 | search identifier that must be used in \fBarray nextelement\fR and \fBarray donesearch\fR commands; it allows multiple searches to be underway simultaneously for the same array. It is currently more efficient and easier to use either the \fBarray get\fR or \fBarray names\fR, together with \fBforeach\fR, to iterate over all but very large arrays. See the examples below for how to do this. | < < < < | 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 | search identifier that must be used in \fBarray nextelement\fR and \fBarray donesearch\fR commands; it allows multiple searches to be underway simultaneously for the same array. It is currently more efficient and easier to use either the \fBarray get\fR or \fBarray names\fR, together with \fBforeach\fR, to iterate over all but very large arrays. See the examples below for how to do this. .TP \fBarray statistics \fIarrayName\fR Returns statistics about the distribution of data within the hashtable that represents the array. This information includes the number of entries in the table, the number of buckets, and the utilization of the buckets. .TP \fBarray unset \fIarrayName\fR ?\fIpattern\fR? Unsets all of the elements in the array that match \fIpattern\fR (using the matching rules of \fBstring match\fR). If \fIarrayName\fR isn't the name of an array variable or there are no matching elements in the array, no error will be raised. If \fIpattern\fR is omitted and \fIarrayName\fR is an array variable, then the command unsets the entire array. The command always returns an empty string. .SH EXAMPLES .CS \fBarray set\fR colorcount { red 1 green 5 blue 4 white 9 |
︙ | ︙ |
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.24.2.1 2005/03/02 21:25:20 kennykb 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 |
︙ | ︙ | |||
427 428 429 430 431 432 433 | set signShort [\fBbinary format\fR s1 0x8000] \fBbinary scan\fR $signShort s1 val; \fI# val == 0xFFFF8000\fR .CE If you want to produce an unsigned value, then you can mask the return value to the desired size. For example, to produce an unsigned short value: .CS | | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 | set signShort [\fBbinary format\fR s1 0x8000] \fBbinary scan\fR $signShort s1 val; \fI# val == 0xFFFF8000\fR .CE If you want to produce an unsigned value, then you can mask the return value to the desired size. For example, to produce an unsigned short value: .CS set val [expr { $val & 0xFFFF }]; \fI# val == 0x8000\fR .CE .PP Each type-count pair moves an imaginary cursor through the binary data, reading bytes from the current position. The cursor is initially at position 0 at the beginning of the data. The type may be any one of the following characters: .IP \fBa\fR 5 |
︙ | ︙ | |||
525 526 527 528 529 530 531 | \fBbinary scan\fR \\x07\\x86\\x05 c2c* var1 var2 .CE will return \fB2\fR with \fB7 -122\fR stored in \fIvar1\fR and \fB5\fR stored in \fIvar2\fR. Note that the integers returned are signed, but they can be converted to unsigned 8-bit quantities using an expression like: .CS | | | | 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 | \fBbinary scan\fR \\x07\\x86\\x05 c2c* var1 var2 .CE will return \fB2\fR with \fB7 -122\fR stored in \fIvar1\fR and \fB5\fR stored in \fIvar2\fR. Note that the integers returned are signed, but they can be converted to unsigned 8-bit quantities using an expression like: .CS set num [expr { $num & 0xff }] .CE .RE .IP \fBs\fR 5 The data is interpreted as \fIcount\fR 16-bit signed integers represented in little-endian byte order. The integers are stored in the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 16-bit integer will be scanned. For example, .RS .CS \fBbinary scan\fR \\x05\\x00\\x07\\x00\\xf0\\xff s2s* var1 var2 .CE will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB-16\fR stored in \fIvar2\fR. Note that the integers returned are signed, but they can be converted to unsigned 16-bit quantities using an expression like: .CS set num [expr { $num & 0xffff }] .CE .RE .IP \fBS\fR 5 This form is the same as \fBs\fR except that the data is interpreted as \fIcount\fR 16-bit signed integers represented in big-endian byte order. For example, .RS |
︙ | ︙ | |||
579 580 581 582 583 584 585 | example, .RS .CS set str \\x05\\x00\\x00\\x00\\x07\\x00\\x00\\x00\\xf0\\xff\\xff\\xff \fBbinary scan\fR $str i2i* var1 var2 .CE will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB-16\fR | | | > > > > | 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 | example, .RS .CS set str \\x05\\x00\\x00\\x00\\x07\\x00\\x00\\x00\\xf0\\xff\\xff\\xff \fBbinary scan\fR $str i2i* var1 var2 .CE will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB-16\fR stored in \fIvar2\fR. Note that the integers returned are signed, but they can be converted to unsigned 32-bit quantities using an expression like: .CS set num [expr { $num & 0xffffffff }] .CE .RE .IP \fBI\fR 5 This form is the same as \fBI\fR except that the data is interpreted as \fIcount\fR 32-bit signed integers represented in big-endian byte order. For example, .RS .CS |
︙ | ︙ |
Added doc/chan.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | '\" '\" Copyright (c) 2005 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: chan.n,v 1.2.6.2 2005/07/12 20:36:15 kennykb Exp $ .so man.macros .TH chan n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME chan \- Read, write and manipulate channels .SH SYNOPSIS \fBchan \fIoption\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP This command provides several operations for reading from, writing to and otherwise manipulating open channels (such as have been created with the \fBopen\fR and \fBsocket\fR commands, or the default named channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR which correspond to the process's standard input, output and error streams respectively). \fIOption\fR indicates what to do with the channel; any unique abbreviation for \fIoption\fR is acceptable. Valid options are: .TP \fBchan blocked \fIchannelId\fR . This tests whether the last input operation on the channel called \fIchannelId\fR failed because it would have otherwise caused the process to block, and returns 1 if that was the case. It returns 0 otherwise. Note that this only ever returns 1 when the channel has been configured to be non-blocking; all Tcl channels have blocking turned on by default. .TP \fBchan close \fIchannelId\fR . Close and destroy the channel called \fIchannelId\fR. Note that this deletes all existing file-events registered on the channel. .RS .PP As part of closing the channel, all buffered output is flushed to the channel's outpuot device, any buffered input is discarded, the underlying operating system resource is closed and \fIchannelId\fR becomes unavailable for future use. .PP If the channel is blocking, the command does not return until all output is flushed. If the channel is nonblocking and there is unflushed output, the channel remains open and the command returns immediately; output will be flushed in the background and the channel will be closed when all the flushing is complete. .PP If \fIchannelId\fR is a blocking channel for a command pipeline then \fBchan close\fR waits for the child processes to complete. .PP If the channel is shared between interpreters, then \fBchan close\fR makes \fIchannelId\fR unavailable in the invoking interpreter but has no other effect until all of the sharing interpreters have closed the channel. When the last interpreter in which the channel is registered invokes \fBchan close\fR (or \fBclose\fR), the cleanup actions described above occur. See the \fBinterp\fR command for a description of channel sharing. .PP Channels are automatically closed when an interpreter is destroyed and when the process exits. Channels are switched to blocking mode, to ensure that all output is correctly flushed before the process exits. .PP The command returns an empty string, and may generate an error if an error occurs while flushing output. If a command in a command pipeline created with \fBopen\fR returns an error, \fBchan close\fR generates an error (similar to the \fBexec\fR command.) .RE .TP \fBchan configure \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... . Query or set the configuration options of the channel named \fIchannelId\fR. .RS .PP If no \fIoptionName\fR or \fIvalue\fR arguments are supplied, the command returns a list containing alternating option names and values for the channel. If \fIoptionName\fR is supplied but no \fIvalue\fR then the command returns the current value of the given option. If one or more pairs of \fIoptionName\fR and \fIvalue\fR are supplied, the command sets each of the named options to the corresponding \fIvalue\fR; in this case the return value is an empty string. .PP The options described below are supported for all channels. In addition, each channel type may add options that only it supports. See the manual entry for the command that creates each type of channels for the options that that specific type of channel supports. For example, see the manual entry for the \fBsocket\fR command for its additional options. .TP \fB\-blocking\fR \fIboolean\fR . The \fB\-blocking\fR option determines whether I/O operations on the channel can cause the process to block indefinitely. The value of the option must be a proper boolean value. Channels are normally in blocking mode; if a channel is placed into nonblocking mode it will affect the operation of the \fBchan gets\fR, \fBchan read\fR, \fBchan puts\fR, \fBchan flush\fR, and \fBchan close\fR commands; see the documentation for those commands for details. For nonblocking mode to work correctly, the application must be using the Tcl event loop (e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR command). .TP \fB\-buffering\fR \fInewValue\fR . If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output until its internal buffer is full or until the \fBchan flush\fR command is 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 a number of no more than one million, allowing buffers of up to one million bytes in size. .TP \fB\-encoding\fR \fIname\fR . This option is used to specify the encoding of the channel as one of the named encodings returned by \fBencoding names\fR or the special value \fBbinary\fR, so that the data can be converted to and from Unicode for use in Tcl. For instance, in order for Tcl to read characters from a Japanese file in \fBshiftjis\fR and properly process and display the contents, the encoding would be set to \fBshiftjis\fR. Thereafter, when reading from the channel, the bytes in the Japanese file would be converted to Unicode as they are read. Writing is also supported \- as Tcl strings are written to the channel they will automatically be converted to the specified encoding on output. .RS .PP If a file contains pure binary data (for instance, a JPEG image), the encoding for the channel should be configured to be \fBbinary\fR. Tcl will then assign no interpretation to the data in the file and simply read or write raw bytes. The Tcl \fBbinary\fR command can be used to manipulate this byte-oriented data. It is usually better to set the \fB\-translation\fR option to \fBbinary\fR when you want to transfer binary data, as this turns off the other automatic interpretations of the bytes in the stream as well. .PP The default encoding for newly opened channels is the same platform- and locale-dependent system encoding used for interfacing with the operating system, as returned by \fBencoding system\fR. .RE .TP \fB\-eofchar\fR \fIchar\fR .TP \fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR . This option supports DOS file systems that use Control-z (\ex1a) as an end of file marker. If \fIchar\fR is not an empty string, then this character signals end-of-file when it is encountered during input. For output, the end-of-file character is output when the channel is closed. If \fIchar\fR is the empty string, then there is no special end of file character marker. For read-write channels, a two-element list specifies the end of file marker for input and output, respectively. As a convenience, when setting the end-of-file character for a read-write channel you can specify a single value that will apply to both reading and writing. When querying the end-of-file character of a read-write channel, a two-element list will always be returned. The default value for \fB\-eofchar\fR is the empty string in all cases except for files under Windows. In that case the \fB\-eofchar\fR is Control-z (\ex1a) for reading and the empty string for writing. .TP \fB\-translation\fR \fImode\fR .TP \fB\-translation\fR \fB{\fIinMode outMode\fB}\fR . In Tcl scripts the end of a line is always represented using a single newline character (\en). However, in actual files and devices the end of a line may be represented differently on different platforms, or even for different devices on the same platform. For example, under UNIX newlines are used in files, whereas carriage-return-linefeed sequences are normally used in network connections. On input (i.e., with \fBchan gets\fP and \fBchan read\fP) the Tcl I/O system automatically translates the external end-of-line representation into newline characters. Upon output (i.e., with \fBchan puts\fP), the I/O system translates newlines to the external end-of-line representation. The default translation mode, \fBauto\fP, handles all the common cases automatically, but the \fB\-translation\fR option provides explicit control over the end of line translations. .RS .PP The value associated with \fB\-translation\fR is a single item for read-only and write-only channels. The value is a two-element list for read-write channels; the read translation mode is the first element of the list, and the write translation mode is the second element. As a convenience, when setting the translation mode for a read-write channel you can specify a single value that will apply to both reading and writing. When querying the translation mode of a read-write channel, a two-element list will always be returned. The following values are currently supported: .TP \fBauto\fR . As the input translation mode, \fBauto\fR treats any of newline (\fBlf\fP), carriage return (\fBcr\fP), or carriage return followed by a newline (\fBcrlf\fP) as the end of line representation. The end of line representation can even change from line-to-line, and all cases are translated to a newline. As the output translation mode, \fBauto\fR chooses a platform specific representation; for sockets on all platforms Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses \fBlf\fR, and for the various flavors of Windows it chooses \fBcrlf\fR. The default setting for \fB\-translation\fR is \fBauto\fR for both input and output. .TP \fBbinary\fR . No end-of-line translations are performed. This is nearly identical to \fBlf\fP mode, except that in addition \fBbinary\fP mode also sets the end-of-file character to the empty string (which disables it) and sets the encoding to \fBbinary\fR (which disables encoding filtering). See the description of \fB\-eofchar\fR and \fB\-encoding\fR for more information. .TP \fBcr\fR . The end of a line in the underlying file or device is represented by a single carriage return character. As the input translation mode, \fBcr\fP mode converts carriage returns to newline characters. As the output translation mode, \fBcr\fP mode translates newline characters to carriage returns. .TP \fBcrlf\fR . The end of a line in the underlying file or device is represented by a carriage return character followed by a linefeed character. As the input translation mode, \fBcrlf\fP mode converts carriage-return-linefeed sequences to newline characters. As the output translation mode, \fBcrlf\fP mode translates newline characters to carriage-return-linefeed sequences. This mode is typically used on Windows platforms and for network connections. .TP \fBlf\fR . The end of a line in the underlying file or device is represented by a single newline (linefeed) character. In this mode no translations occur during either input or output. This mode is typically used on UNIX platforms. .RE .RE .TP \fBchan copy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR? . Copy data from the channel \fIinputChan\fR, which must have been opened for reading, to the channel \fIoutputChan\fR, which must have been opened for writing. The \fBchan copy\fR command leverages the buffering in the Tcl I/O system to avoid extra copies and to avoid buffering too much data in main memory when copying large files to slow destinations like network sockets. .RS .PP The \fBchan copy\fP command transfers data from \fIinputChan\fR until end of file or \fIsize\fP bytes have been transferred. If no \fB\-size\fP argument is given, then the copy goes until end of file. All the data read from \fIinputChan\fR is copied to \fIoutputChan\fR. Without the \fB\-command\fP option, \fBchan copy\fP blocks until the copy is complete and returns the number of bytes written to \fIoutputChan\fR. .PP The \fB\-command\fP argument makes \fBchan copy\fP work in the background. In this case it returns immediately and the \fIcallback\fP is invoked later when the copy completes. The \fIcallback\fP is called with one or two additional arguments that indicates how many bytes were written to \fIoutputChan\fR. If an error occurred during the background copy, the second argument is the error string associated with the error. With a background copy, it is not necessary to put \fIinputChan\fR or \fIoutputChan\fR into non-blocking mode; the \fBchan copy\fP command takes care of that automatically. However, it is necessary to enter the event loop by using the \fBvwait\fP command or by using Tk. .PP You are not allowed to do other I/O operations with \fIinputChan\fR or \fIoutputChan\fR during a background \fBchan copy\fR. If either \fIinputChan\fR or \fIoutputChan\fR get closed while the copy is in progress, the current copy is stopped and the command callback is \fInot\fP made. If \fIinputChan\fR is closed, then all data already queued for \fIoutputChan\fR is written out. .PP Note that \fIinputChan\fR can become readable during a background copy. You should turn off any \fBchan event\fP or \fBfileevent\fR handlers during a background copy so those handlers do not interfere with the copy. Any I/O attempted by a \fBchan event\fR or \fBfileevent\fP handler will get a "channel busy" error. .PP \fBChan copy\fR translates end-of-line sequences in \fIinputChan\fR and \fIoutputChan\fR according to the \fB\-translation\fR option for these channels (see \fBchan configure\fR above). The translations mean that the number of bytes read from \fIinputChan\fR can be different than the number of bytes written to \fIoutputChan\fR. Only the number of bytes written to \fIoutputChan\fR is reported, either as the return value of a synchronous \fBchan copy\fP or as the argument to the callback for an asynchronous \fBchan copy\fP. .PP \fBChan copy\fR obeys the encodings and character translations configured for the channels. This means that the incoming characters are converted internally first UTF-8 and then into the encoding of the channel \fBchan copy\fR writes to (see \fBchan configure\fR above for details on the \fB\-encoding\fR and \fB\-translation\fR options). No conversion is done if both channels are set to encoding \fBbinary\fR and have matching translations. If only the output channel is set to encoding \fBbinary\fR the system will write the internal UTF-8 representation of the incoming characters. If only the input channel is set to encoding \fBbinary\fR the system will assume that the incoming bytes are valid UTF-8 characters and convert them according to the output encoding. The behaviour of the system for bytes which are not valid UTF-8 characters is undefined in this case. .RE .TP \fBchan eof \fIchannelId\fR . Test whether the last input operation on the channel called \fIchannelId\fR failed because the end of the data stream was reached, returning 1 if end-fo-file was reached, and 0 otherwise. .TP \fBchan event \fIchannelId event\fR ?\fIscript\fR? . Arrange for the Tcl script \fIscript\fR to be installed as a \fIfile event handler\fR to be called whenever the channel called \fIchannelId\fR enters the state described by \fIevent\fR (which must be either \fBreadable\fR or \fBwritable\fR); only one such handler may be installed per event per channel at a time. If \fIscript\fR is the empty string, the current handler is deleted (this also happens if the channel is closed or the interpreter deleted). If \fIscript\fR is omitted, the currently installed script is returned (or an empty string if no such handler is installed). The callback is only performed if the event loop is being serviced (e.g. via \fBvwait\fR or \fBupdate\fR). .RS .PP A file event handler is a binding between a channel and a script, such that the script is evaluated whenever the channel becomes readable or writable. File event handlers are most commonly used to allow data to be received from another process on an event-driven basis, so that the receiver can continue to interact with the user or with other channels while waiting for the data to arrive. If an application invokes \fBchan gets\fR or \fBchan read\fR on a blocking channel when there is no input data available, the process will block; until the input data arrives, it will not be able to service other events, so it will appear to the user to ``freeze up''. With \fBchan event\fR, the process can tell when data is present and only invoke \fBchan gets\fR or \fBchan read\fR when they won't block. .PP A channel is considered to be readable if there is unread data available on the underlying device. A channel is also considered to be readable if there is unread data in an input buffer, except in the special case where the most recent attempt to read from the channel was a \fBchan gets\fR call that could not find a complete line in the input buffer. This feature allows a file to be read a line at a time in nonblocking mode using events. A channel is also considered to be readable if an end of file or error condition is present on the underlying file or device. It is important for \fIscript\fR to check for these conditions and handle them appropriately; for example, if there is no special check for end of file, an infinite loop may occur where \fIscript\fR reads no data, returns, and is immediately invoked again. .PP A channel is considered to be writable if at least one byte of data can be written to the underlying file or device without blocking, or if an error condition is present on the underlying file or device. Note that client sockets opened in asynchronous mode become writable when they become connected or if the connection fails. .PP Event-driven I/O works best for channels that have been placed into nonblocking mode with the \fBchan configure\fR command. In blocking mode, a \fBchan puts\fR command may block if you give it more data than the underlying file or device can accept, and a \fBchan gets\fR or \fBchan read\fR command will block if you attempt to read more data than is ready; no events will be processed while the commands block. In nonblocking mode \fBchan puts\fR, \fBchan read\fR, and \fBchan gets\fR never block. .PP The script for a file event is executed at global level (outside the context of any Tcl procedure) in the interpreter in which the \fBchan event\fR command was invoked. If an error occurs while executing the script then the command registered with \fBinterp bgerror\fR is used to report the error. In addition, the file event handler is deleted if it ever returns an error; this is done in order to prevent infinite loops due to buggy handlers. .RE .TP \fBchan flush \fIchannelId\fR . Ensures that all pending output for the channel called \fIchannelId\fR is written. .RS .PP If the channel is in blocking mode the command does not return until all the buffered output has been flushed to the channel. If the channel is in nonblocking mode, the command may return before all buffered output has been flushed; the remainder will be flushed in the background as fast as the underlying file or device is able to absorb it. .RE .TP \fBchan gets \fIchannelId\fR ?\fIvarName\fR? . Reads the next line from the channel called \fIchannelId\fR. If \fIvarName\fR is not specified, the result of the command will be the line that has been read (without a trailing newline character) or an empty string upon end-of-file or, in non-blocking mode, if the data available is exhausted. If \fIvarName\fR is specified, the line that has been read will be written to the variable called \fIvarName\fR and result will be the number of characters that have been read or -1 if end-of-file was reached or, in non-blocking mode, if the data available is exhausted. .RS .PP If an end-of-file occurs while part way through reading a line, the partial line will be returned (or written into \fIvarName\fR). When \fIvarName\fR is not specified, the end-of-file case can be distinguished from an empty line using the \fBchan eof\fR command, and the partial-line-but-nonblocking case can be distinguished with the \fBchan blocked\fR command. .RE .TP \fBchan names\fR ?\fIpattern\fR? . Produces a list of all channel names. If \fIpattern\fR is specified, only those channel names that match it (according to the rules of \fBstring match\fR) will be returned. .TP \fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR . Writes \fIstring\fR to the channel named \fIchannelId\fR followed by a newline character. A trailing newline character is written unless the optional flag \fB\-nonewline\fR is given. If \fIchannelId\fR is omitted, the string is written to the standard output channel, \fBstdout\fR. .RS .PP Newline characters in the output are translated by \fBchan puts\fR to platform-specific end-of-line sequences according to the currently configured value of the \fB\-translation\fR option for the channel (for example, on PCs newlines are normally replaced with carriage-return-linefeed sequences; see \fBchan configure\fR above for details). .PP Tcl buffers output internally, so characters written with \fBchan puts\fR may not appear immediately on the output file or device; Tcl will normally delay output until the buffer is full or the channel is closed. You can force output to appear immediately with the \fBchan flush\fR command. .PP When the output buffer fills up, the \fBchan puts\fR command will normally block until all the buffered data has been accepted for output by the operating system. If \fIchannelId\fR is in nonblocking mode then the \fBchan puts\fR command will not block even if the operating system cannot accept the data. Instead, Tcl continues to buffer the data and writes it in the background as fast as the underlying file or device can accept it. The application must use the Tcl event loop for nonblocking output to work; otherwise Tcl never finds out that the file or device is ready for more output data. It is possible for an arbitrarily large amount of data to be buffered for a channel in nonblocking mode, which could consume a large amount of memory. To avoid wasting memory, nonblocking I/O should normally be used in an event-driven fashion with the \fBchan event\fR command (don't invoke \fBchan puts\fR unless you have recently been notified via a file event that the channel is ready for more output data). .RE .TP \fBchan read \fIchannelId\fR ?\fInumChars\fR? .TP \fBchan read \fR?\fB\-nonewline\fR? \fIchannelId\fR . In the first form, the result will be the next \fInumChars\fR characters read from the channel named \fIchannelId\fR; if \fInumChars\fR is omitted, all characters up to the point when the channel would signal a failure (whether an end-of-file, blocked or other error condition) are read. In the second form (i.e. when \fInumChars\fR has been omitted) the flag \fB\-nonewline\fR may be given to indicate that any trailing newline in the string that has been read should be trimmed. .RS .PP If \fIchannelId\fR is in nonblocking mode, \fBchan read\fR may not read as many characters as requested: once all available input has been read, the command will return the data that is available rather than blocking for more input. If the channel is configured to use a multi-byte encoding, then there may actually be some bytes remaining in the internal buffers that do not form a complete character. These bytes will not be returned until a complete character is available or end-of-file is reached. The \fB\-nonewline\fR switch is ignored if the command returns before reaching the end of the file. .PP \fBChan read\fR translates end-of-line sequences in the input into newline characters according to the \fB\-translation\fR option for the channel (see \fBchan configure\fR above for a discussion on the ways in which \fBchan configure\fR will alter input). .PP When reading from a serial port, most applications should configure the serial port channel to be nonblocking, like this: .CS \fBchan configure \fIchannelId \fB\-blocking \fI0\fR. .CE Then \fBchan read\fR behaves much like described above. Note that most serial ports are comparatively slow; it is entirely possible to get a \fBreadable\fR event for each character read from them. Care must be taken when using \fBchan read\fR on blocking serial ports: .TP \fBchan read \fIchannelId numChars\fR . In this form \fBchan read\fR blocks until \fInumChars\fR have been received from the serial port. .TP \fBchan read \fIchannelId\fR . In this form \fBchan read\fR blocks until the reception of the end-of-file character, see \fBchan configure -eofchar\fR. If there no end-of-file character has been configured for the channel, then \fBchan read\fR will block forever. .RE .TP \fBchan seek \fIchannelId offset\fR ?\fIorigin\fR? . Sets the current access position within the underlying data stream for the channel named \fIchannelId\fR to be \fIoffset\fR bytes relative to \fIorigin\fR. \fIOffset\fR must be an integer (which may be negative) and \fIorigin\fR must be one of the following: .RS .TP 10 \fBstart\fR . The new access position will be \fIoffset\fR bytes from the start of the underlying file or device. .TP 10 \fBcurrent\fR . The new access position will be \fIoffset\fR bytes from the current access position; a negative \fIoffset\fR moves the access position backwards in the underlying file or device. .TP 10 \fBend\fR . The new access position will be \fIoffset\fR bytes from the end of the file or device. A negative \fIoffset\fR places the access position before the end of file, and a positive \fIoffset\fR places the access position after the end of file. .PP The \fIorigin\fR argument defaults to \fBstart\fR. .PP \fBChan seek\fR flushes all buffered output for the channel before the command returns, even if the channel is in nonblocking mode. It also discards any buffered and unread input. This command returns an empty string. An error occurs if this command is applied to channels whose underlying file or device does not support seeking. .PP Note that \fIoffset\fR values are byte offsets, not character offsets. Both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes, not characters, unlike \fBchan read\fR. .RE .TP \fBchan tell \fIchannelId\fR . Returns a number giving the current access position within the underlying data stream for the channel named \fIchannelId\fR. This value returned is a byte offset that can be passed to \fBchan seek\fR in order to set the channel to a particular position. Note that this value is in terms of bytes, not characters like \fBchan read\fR. The value returned is -1 for channels that do not support seeking. .TP \fBchan truncate \fIchannelId\fR ?\fIlength\fR? . Sets the byte length of the underlying data stream for the channel named \fIchannelId\fR to be \fIlength\fR (or to the current byte offset within the underlying data stream if \fIlength\fR is omitted). The channel is flushed before truncation. .SH "SEE ALSO" close(n), eof(n), fblocked(n), fconfigure(n), fcopy(n), file(n), fileevent(n), flush(n), gets(n), open(n), puts(n), read(n), seek(n), socket(n), tell(n) .SH KEYWORDS channel, input, output, events, offset |
Changes to doc/clock.n.
︙ | ︙ | |||
815 816 817 818 819 820 821 | than 100, we treat the years 00-68 as 2000-2068 and the years 69-99 as 1969-1999. Not all platforms can represent the years 38-70, so an error may result if these years are used. .TP \fIISO 8601 point-in-time\fR An ISO 8601 point-in-time specification, such as \fBCCyymmddThhmmss\fR, where \fBT\fR is the literal T, "\fBCCyymmdd hhmmss\fR", or | | > > > | > | 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 | than 100, we treat the years 00-68 as 2000-2068 and the years 69-99 as 1969-1999. Not all platforms can represent the years 38-70, so an error may result if these years are used. .TP \fIISO 8601 point-in-time\fR An ISO 8601 point-in-time specification, such as \fBCCyymmddThhmmss\fR, where \fBT\fR is the literal T, "\fBCCyymmdd hhmmss\fR", or \fBCCyymmddThh:mm:ss\fR. Note that only these three formats are accepted. The command does \fInot\fR accept the full range of point-in-time specifications specified in ISO8601. Other formats can be recognized by giving an explicit \fI-format\fR option to the \fBclock scan\fR command. .TP \fIrelative time\fR A specification relative to the current time. The format is \fBnumber unit\fR. Acceptable units are \fByear\fR, \fBfortnight\fR, \fBmonth\fR, \fBweek\fR, \fBday\fR, \fBhour\fR, \fBminute\fR (or \fBmin\fR), and \fBsecond\fR (or \fBsec\fR). The unit can be specified as a singular or plural, as in \fB3 weeks\fR. These modifiers may also be specified: \fBtomorrow\fR, \fByesterday\fR, \fBtoday\fR, \fBnow\fR, \fBlast\fR, \fBthis\fR, \fBnext\fR, \fBago\fR. The actual date is calculated according to the following steps. .PP |
︙ | ︙ |
Changes to doc/close.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 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 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: close.n,v 1.8.2.1 2005/04/10 23:14:42 kennykb Exp $ '\" .so man.macros .TH close n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME close \- Close an open channel .SH SYNOPSIS \fBclose \fIchannelId\fR .BE .SH DESCRIPTION .PP Closes the channel given by \fIchannelId\fR. .PP \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. .PP All buffered output is flushed to the channel's output device, any buffered input is discarded, the underlying file or device is closed, and \fIchannelId\fR becomes unavailable for use. .PP If the channel is blocking, the command does not return until all output is flushed. If the channel is nonblocking and there is unflushed output, the channel remains open and the command returns immediately; output will be flushed in the background and the channel will be closed when all the flushing is complete. .PP If \fIchannelId\fR is a blocking channel for a command pipeline then \fBclose\fR waits for the child processes to complete. .PP If the channel is shared between interpreters, then \fBclose\fR makes \fIchannelId\fR unavailable in the invoking interpreter but has no other effect until all of the sharing interpreters have closed the channel. When the last interpreter in which the channel is registered invokes \fBclose\fR, the cleanup actions described above occur. See the \fBinterp\fR command for a description of channel sharing. .PP Channels are automatically closed when an interpreter is destroyed and when the process exits. Channels are switched to blocking mode, to ensure that all output is correctly flushed before the process exits. .PP The command returns an empty string, and may generate an error if an error occurs while flushing output. If a command in a command pipeline created with \fBopen\fR returns an error, \fBclose\fR generates an error (similar to the \fBexec\fR command.) .SH EXAMPLE This illustrates how you can use Tcl to ensure that files get closed |
︙ | ︙ |
Changes to doc/error.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: error.n,v 1.7.2.1 2004/12/08 18:24:35 kennykb Exp $ '\" .so man.macros .TH error n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME error \- Generate an error .SH SYNOPSIS \fBerror \fImessage\fR ?\fIinfo\fR? ?\fIcode\fR? .BE .SH DESCRIPTION .PP Returns a \fBTCL_ERROR\fR code, which causes command interpretation to be unwound. \fIMessage\fR is a string that is returned to the application to indicate what went wrong. .PP The \fB-errorinfo\fR return option of an interpreter is used to accumulate a stack trace of what was in progress when an error occurred; as nested commands unwind, the Tcl interpreter adds information to the \fB-errorinfo\fR return option. If the \fIinfo\fR argument is present, it is used to initialize the \fB-errorinfo\fR return options and the first increment of unwind information will not be added by the Tcl interpreter. |
︙ | ︙ |
Changes to doc/expr.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. '\" Copyright (c) 2005 by Kevin B. Kenny <[email protected]>. 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: expr.n,v 1.18.2.2 2005/07/12 20:36:15 kennykb Exp $ '\" .so man.macros .TH expr n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME expr \- Evaluate an expression |
︙ | ︙ | |||
80 81 82 83 84 85 86 | will be used as the operand without any substitutions. .IP [6] As a Tcl command enclosed in brackets. The command will be executed and its result will be used as the operand. .IP [7] As a mathematical function whose arguments have any of the above | | | | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | will be used as the operand without any substitutions. .IP [6] As a Tcl command enclosed in brackets. The command will be executed and its result will be used as the operand. .IP [7] As a mathematical function whose arguments have any of the above forms for operands, such as \fBsin($x)\fR. See MATH FUNCTIONS below for a discussion of how mathematical functions are handled. .LP Where the above substitutions occur (e.g. inside quoted strings), they are performed by the expression's instructions. However, the command parser may already have performed one round of substitution before the expression processor was called. As discussed below, it is usually best to enclose expressions in braces to prevent the command parser from performing substitutions |
︙ | ︙ | |||
207 208 209 210 211 212 213 | only one of \fB[a]\fR or \fB[b]\fR will actually be evaluated, depending on the value of \fB$v\fR. Note, however, that this is only true if the entire expression is enclosed in braces; otherwise the Tcl parser will evaluate both \fB[a]\fR and \fB[b]\fR before invoking the \fBexpr\fR command. .SS "MATH FUNCTIONS" .PP | > | < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | | < < < < | < < | < | < | < < < < | < < | > > | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > | 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 | only one of \fB[a]\fR or \fB[b]\fR will actually be evaluated, depending on the value of \fB$v\fR. Note, however, that this is only true if the entire expression is enclosed in braces; otherwise the Tcl parser will evaluate both \fB[a]\fR and \fB[b]\fR before invoking the \fBexpr\fR command. .SS "MATH FUNCTIONS" .PP .VS 8.5 When the expression parser encounters a mathematical function such as \fBsin($x)\fR, it replaces it with a call to an ordinary Tcl function in the \fBtcl::mathfunc\fR namespace. The processing of an expression such as: .CS \fBexpr {sin($x+$y)}\fR .CE is the same in every way as the processing of: .CS \fBexpr {[tcl::mathfunc::sin [expr {$x+$y}]]}\fR .CE The executor will search for \fBtcl::mathfunc::sin\fR using the usual rules for resolving functions in namespaces. Either \fB::tcl::mathfunc::sin\fR or \fB[namespace current]::tcl::mathfunc::sin\fR will satisfy the request, and others may as well (depending on the current \fBnamespace path\fR setting). .PP See the \fBmathfunc\fR(n) manual page for the math functions that are available by default. .VE 8.5 .SS "TYPES, OVERFLOW, AND PRECISION" .PP All internal computations involving integers are done with the C type \fIlong\fR, and all internal computations involving floating-point are done with the C type \fIdouble\fR. When converting a string to floating-point, exponent overflow is detected and results in a Tcl error. |
︙ | ︙ | |||
426 427 428 429 430 431 432 | unbraced expressions that contain command substitutions. These expressions must be implemented by generating new code each time the expression is executed. .SH EXAMPLES Define a procedure that computes an "interesting" mathematical function: .CS | | | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 | unbraced expressions that contain command substitutions. These expressions must be implemented by generating new code each time the expression is executed. .SH EXAMPLES Define a procedure that computes an "interesting" mathematical function: .CS proc tcl::mathfunc::calc {x y} { \fBexpr\fR { ($x**2 - $y**2) / exp($x**2 + $y**2) } } .CE .PP Convert polar coordinates into cartesian coordinates: .CS # convert from ($radius,$angle) |
︙ | ︙ | |||
466 467 468 469 470 471 472 | .PP Generate a random integer in the range 0..99 inclusive: .CS set randNum [\fBexpr\fR { int(100 * rand()) }] .CE .SH "SEE ALSO" | | > > > > > > > | 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 | .PP Generate a random integer in the range 0..99 inclusive: .CS set randNum [\fBexpr\fR { int(100 * rand()) }] .CE .SH "SEE ALSO" array(n), for(n), if(n), mathfunc(n), namespace(n), proc(n), string(n), Tcl(n), while(n) .SH KEYWORDS arithmetic, boolean, compare, expression, fuzzy comparison .SH COPYRIGHT Copyright (c) 1993 The Regents of the University of California. .br Copyright (c) 1994-2000 Sun Microsystems Incorporated. .br Copyright (c) 2005 by Kevin B. Kenny <[email protected]>. All rights reserved. |
Changes to doc/fblocked.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 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) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: fblocked.n,v 1.6.2.1 2005/04/10 23:14:43 kennykb Exp $ .so man.macros .TH fblocked n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fblocked \- Test whether the last input operation exhausted all available input .SH SYNOPSIS \fBfblocked \fIchannelId\fR .BE .SH DESCRIPTION .PP The \fBfblocked\fR command returns 1 if the most recent input operation on \fIchannelId\fR returned less information than requested because all available input was exhausted. For example, if \fBgets\fR is invoked when there are only three characters available for input and no end-of-line sequence, \fBgets\fR returns an empty string and a subsequent call to \fBfblocked\fR will return 1. .PP \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. .SH EXAMPLE The \fBfblocked\fR command is particularly useful when writing network servers, as it allows you to write your code in a line-by-line style without preventing the servicing of other connections. This can be seen in this simple echo-service: .PP .CS |
︙ | ︙ |
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.11.2.1 2005/04/25 21:37:18 kennykb 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 |
︙ | ︙ | |||
87 88 89 90 91 92 93 | will automatically be converted to the specified encoding on output. .RS .PP If a file contains pure binary data (for instance, a JPEG image), the encoding for the channel should be configured to be \fBbinary\fR. Tcl will then assign no interpretation to the data in the file and simply read or write raw bytes. The Tcl \fBbinary\fR command can be used to manipulate this | | > > > | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | will automatically be converted to the specified encoding on output. .RS .PP If a file contains pure binary data (for instance, a JPEG image), the encoding for the channel should be configured to be \fBbinary\fR. Tcl will then assign no interpretation to the data in the file and simply read or write raw bytes. The Tcl \fBbinary\fR command can be used to manipulate this byte-oriented data. It is usually better to set the \fB\-translation\fR option to \fBbinary\fR when you want to transfer binary data, as this turns off the other automatic interpretations of the bytes in the stream as well. .PP The default encoding for newly opened channels is the same platform- and locale-dependent system encoding used for interfacing with the operating system, as returned by \fBencoding system\fR. .RE .TP \fB\-eofchar\fR \fIchar\fR .TP \fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR . This option supports DOS file systems that use Control-z (\ex1a) as an |
︙ | ︙ |
Changes to doc/fcopy.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: fcopy.n,v 1.4.2.1 2005/04/25 21:37:19 kennykb Exp $ '\" .so man.macros .TH fcopy n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fcopy \- Copy data from one channel to another |
︙ | ︙ | |||
68 69 70 71 72 73 74 | \fB\-translation\fR option. The translations mean that the number of bytes read from \fIinchan\fR can be different than the number of bytes written to \fIoutchan\fR. Only the number of bytes written to \fIoutchan\fR is reported, either as the return value of a synchronous \fBfcopy\fP or as the argument to the callback for an asynchronous \fBfcopy\fP. .PP | > | > | > | | > > > > > > > > > > | | < | | | < | | 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 | \fB\-translation\fR option. The translations mean that the number of bytes read from \fIinchan\fR can be different than the number of bytes written to \fIoutchan\fR. Only the number of bytes written to \fIoutchan\fR is reported, either as the return value of a synchronous \fBfcopy\fP or as the argument to the callback for an asynchronous \fBfcopy\fP. .PP \fBFcopy\fR obeys the encodings and character translations configured for the channels. This means that the incoming characters are converted internally first UTF-8 and then into the encoding of the channel \fBfcopy\fR writes to. See the manual entry for \fBfconfigure\fR for details on the \fB\-encoding\fR and \fB\-translation\fR options. No conversion is done if both channels are set to encoding "binary" and have matching translations. If only the output channel is set to encoding "binary" the system will write the internal UTF-8 representation of the incoming characters. If only the input channel is set to encoding "binary" the system will assume that the incoming bytes are valid UTF-8 characters and convert them according to the output encoding. The behaviour of the system for bytes which are not valid UTF-8 characters is undefined in this case. .SH EXAMPLES .PP The first example transfers the contents of one channel exactly to another. Note that when copying one file to another, it is better to use \fBfile copy\fR which also copies file metadata (e.g. the file access permissions) where possible. .DS fconfigure $in -translation binary fconfigure $out -translation binary \fBfcopy\fR $in $out .DE .PP This second example shows how the callback gets passed the number of bytes transferred. It also uses vwait to put the application into the event loop. Of course, this simplified example could be done without the command callback. .DS proc Cleanup {in out bytes {error {}}} { global total set total $bytes close $in close $out if {[string length $error] != 0} { # error occurred during the copy } } set in [open $file1] set out [socket $server $port] \fBfcopy\fR $in $out -command [list Cleanup $in $out] vwait total .DE .PP The third example copies in chunks and tests for end of file in the command callback .DS proc CopyMore {in out chunk bytes {error {}}} { global total done incr total $bytes if {([string length $error] != 0) || [eof $in] { set done $total close $in close $out } else { \fBfcopy\fR $in $out -command [list CopyMore $in $out $chunk] \\ -size $chunk } } set in [open $file1] set out [socket $server $port] set chunk 1024 set total 0 \fBfcopy\fR $in $out -command [list CopyMore $in $out $chunk] -size $chunk vwait done .DE .SH "SEE ALSO" eof(n), fblocked(n), fconfigure(n), file(n) .SH KEYWORDS blocking, channel, end of line, end of file, nonblocking, read, translation |
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.38.2.1 2005/04/10 23:14:43 kennykb 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 |
︙ | ︙ | |||
77 78 79 80 81 82 83 | Finder creator type of the file. \fB-hidden\fR gives or sets or clears the hidden attribute of the file. \fB-readonly\fR gives or sets or clears the readonly attribute of the file. \fB-rsrclength\fR gives the length of the resource fork of the file, this attribute can only be set to the value 0, which results in the resource fork being stripped off the file. .RE | < < | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 | Finder creator type of the file. \fB-hidden\fR gives or sets or clears the hidden attribute of the file. \fB-readonly\fR gives or sets or clears the readonly attribute of the file. \fB-rsrclength\fR gives the length of the resource fork of the file, this attribute can only be set to the value 0, which results in the resource fork being stripped off the file. .RE .TP \fBfile channels ?\fIpattern\fR? . 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. .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, |
︙ | ︙ |
Changes to doc/fileevent.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: fileevent.n,v 1.7.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH fileevent n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fileevent \- Execute a script when a channel becomes readable or writable |
︙ | ︙ | |||
30 31 32 33 34 35 36 | application invokes \fBgets\fR or \fBread\fR on a blocking channel when there is no input data available, the process will block; until the input data arrives, it will not be able to service other events, so it will appear to the user to ``freeze up''. With \fBfileevent\fR, the process can tell when data is present and only invoke \fBgets\fR or \fBread\fR when they won't block. .PP | < < | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | application invokes \fBgets\fR or \fBread\fR on a blocking channel when there is no input data available, the process will block; until the input data arrives, it will not be able to service other events, so it will appear to the user to ``freeze up''. With \fBfileevent\fR, the process can tell when data is present and only invoke \fBgets\fR or \fBread\fR when they won't block. .PP The \fIchannelId\fR argument to \fBfileevent\fR refers to an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. .PP If the \fIscript\fR argument is specified, then \fBfileevent\fR creates a new event handler: \fIscript\fR will be evaluated whenever the channel becomes readable or writable (depending on the second argument to \fBfileevent\fR). In this case \fBfileevent\fR returns an empty string. The \fBreadable\fR and \fBwritable\fR event handlers for a file |
︙ | ︙ |
Changes to doc/flush.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: flush.n,v 1.6.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH flush n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME flush \- Flush buffered output for a channel .SH SYNOPSIS \fBflush \fIchannelId\fR .BE .SH DESCRIPTION .PP Flushes any output that has been buffered for \fIchannelId\fR. .PP \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. The channel must have been opened for writing. .PP If the channel is in blocking mode the command does not return until all the buffered output has been flushed to the channel. If the channel is in nonblocking mode, the command may return before all buffered output has been flushed; the remainder will be flushed in the background as fast as the underlying file or device is able to absorb it. .SH EXAMPLE |
︙ | ︙ |
Changes to doc/foreach.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: foreach.n,v 1.5.2.1 2004/12/08 18:24:35 kennykb Exp $ '\" .so man.macros .TH foreach n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME foreach \- Iterate over all elements in one or more lists |
︙ | ︙ | |||
51 52 53 54 55 56 57 | invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR command. \fBForeach\fR returns an empty string. .SH EXAMPLES This loop prints every value in a list together with the square and cube of the value: .CS '\" Maintainers: notice the tab hacking below! | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR command. \fBForeach\fR returns an empty string. .SH EXAMPLES This loop prints every value in a list together with the square and cube of the value: .CS '\" Maintainers: notice the tab hacking below! .ta 3i set values {1 3 5 7 2 4 6 8} ;# Odd numbers first, for fun! puts "Value\\tSquare\\tCube" ;# Neat-looking header \fBforeach\fR x $values { ;# Now loop and print... puts " $x\\t [expr {$x**2}]\\t [expr {$x**3}]" } .CE .PP |
︙ | ︙ |
Changes to doc/format.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: format.n,v 1.10.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH format n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME format \- Format a string in the style of sprintf |
︙ | ︙ | |||
126 127 128 129 130 131 132 | it must be a numeric string. .PP The fifth part of a conversion specifier is a length modifier, which must be \fBh\fR or \fBl\fR. If it is \fBh\fR it specifies that the numeric value should be truncated to a 16-bit value before converting. This option is rarely useful. | < < | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 | it must be a numeric string. .PP The fifth part of a conversion specifier is a length modifier, which must be \fBh\fR or \fBl\fR. If it is \fBh\fR it specifies that the numeric value should be truncated to a 16-bit value before converting. This option is rarely useful. If it is \fBl\fR it specifies that the numeric value should be (at least) a 64-bit value. If neither \fBh\fR nor \fBl\fR are present, numeric values are interpreted as being values of the width of the native machine word, as described by \fBtcl_platform(wordSize)\fR. .PP The last thing in a conversion specifier is an alphabetic character that determines what kind of conversion to perform. The following conversion characters are currently supported: .TP 10 \fBd\fR Convert integer to signed decimal string. |
︙ | ︙ | |||
154 155 156 157 158 159 160 | .TP 10 \fBo\fR Convert integer to unsigned octal string. .TP 10 \fBx\fR or \fBX\fR Convert integer to unsigned hexadecimal string, using digits ``0123456789abcdef'' for \fBx\fR and ``0123456789ABCDEF'' for \fBX\fR). | < < | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | .TP 10 \fBo\fR Convert integer to unsigned octal string. .TP 10 \fBx\fR or \fBX\fR Convert integer to unsigned hexadecimal string, using digits ``0123456789abcdef'' for \fBx\fR and ``0123456789ABCDEF'' for \fBX\fR). .TP 10 \fBc\fR Convert integer to the Unicode character it represents. .TP 10 \fBs\fR No conversion; just insert string. .TP 10 \fBf\fR Convert floating-point number to signed decimal string of the form \fIxx.yyy\fR, where the number of \fIy\fR's is determined by |
︙ | ︙ | |||
203 204 205 206 207 208 209 | .IP [1] \fB%p\fR and \fB%n\fR specifiers are not currently supported. .IP [2] For \fB%c\fR conversions the argument must be a decimal string, which will then be converted to the corresponding character value. .IP [3] The \fBl\fR modifier | < < | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 | .IP [1] \fB%p\fR and \fB%n\fR specifiers are not currently supported. .IP [2] For \fB%c\fR conversions the argument must be a decimal string, which will then be converted to the corresponding character value. .IP [3] The \fBl\fR modifier is ignored for real values and on 64-bit platforms, which are always converted as if the \fBl\fR modifier were present (i.e. the types \fBdouble\fR and \fBlong\fR are used for the internal representation of real and integer values, respectively). If the \fBh\fR modifier is specified then integer values are truncated to \fBshort\fR before conversion. Both \fBh\fR and \fBl\fR modifiers are ignored on all other conversions. .SH EXAMPLES Convert the output of \fBtime\fR into seconds to an accuracy of hundredths of a second: .CS |
︙ | ︙ |
Changes to doc/gets.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: gets.n,v 1.6.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH gets n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME gets \- Read a line from a channel .SH SYNOPSIS \fBgets \fIchannelId\fR ?\fIvarName\fR? .BE .SH DESCRIPTION .PP This command reads the next line from \fIchannelId\fR, returns everything in the line up to (but not including) the end-of-line character(s), and discards the end-of-line character(s). .PP \fIChannelId\fR must be an identifier for an open channel such as the Tcl standard input channel (\fBstdin\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. The channel must have been opened for input. .PP If \fIvarName\fR is omitted the line is returned as the result of the command. If \fIvarName\fR is specified then the line is placed in the variable by that name and the return value is a count of the number of characters returned. .PP |
︙ | ︙ |
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 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | '\" '\" 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.17.2.1 2005/07/12 20:36:15 kennykb 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 .SH SYNOPSIS \fBglob \fR?\fIswitches\fR? \fIpattern \fR?\fIpattern ...\fR? .BE .SH DESCRIPTION .PP This command performs file name ``globbing'' in a fashion similar to the csh shell. It returns a list of the files whose names match any of the \fIpattern\fR arguments. No particular order is guaranteed in the list, so if a sorted list is required the caller should use \fBlsort\fR. .LP If the initial arguments to \fBglob\fR start with \fB\-\fR then they are treated as switches. The following switches are currently supported: .TP \fB\-directory\fR \fIdirectory\fR Search for files which match the given patterns starting in the given |
︙ | ︙ | |||
153 154 155 156 157 158 159 | start with a tilde ``~'' (for example through \fBglob *\fR or \fBglob -tails\fR, the returned list will not quote the tilde with ``./''. This means care must be taken if those names are later to be used with \fBfile join\fR, to avoid them being interpreted as absolute paths pointing to a given user's home directory. .SH "PORTABILITY ISSUES" .PP | < < < < < | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | start with a tilde ``~'' (for example through \fBglob *\fR or \fBglob -tails\fR, the returned list will not quote the tilde with ``./''. This means care must be taken if those names are later to be used with \fBfile join\fR, to avoid them being interpreted as absolute paths pointing to a given user's home directory. .SH "PORTABILITY ISSUES" .PP \fBWindows\fR . For Windows UNC names, the servername and sharename components of the path may not contain ?, *, or [] constructs. On Windows NT, if \fIpattern\fR is of the form ``\fB~\fIusername\fB@\fIdomain\fR'' it refers to the home directory of the user whose account information resides on the specified NT domain server. Otherwise, user account information is obtained from |
︙ | ︙ |
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.14.2.2 2005/07/12 20:36:15 kennykb 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 |
︙ | ︙ | |||
36 37 38 39 40 41 42 | .TP \fBinfo cmdcount\fR Returns a count of the total number of commands that have been invoked in this interpreter. .TP \fBinfo commands \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, | > > | > | > > > > | 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 | .TP \fBinfo cmdcount\fR Returns a count of the total number of commands that have been invoked in this interpreter. .TP \fBinfo commands \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, '\" Do not move this .VS above the .TP .VS 8.5 returns a list of names of all the Tcl commands visible (i.e. executable without using a qualified name) to the current namespace, including both the built-in commands written in C and the command procedures defined using the \fBproc\fR command. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. \fIpattern\fR can be a qualified name like \fBFoo::print*\fR. That is, it may specify a particular namespace using a sequence of namespace names separated by double colons (\fB::\fR), and may have pattern matching special characters at the end to specify a set of commands in that namespace. If \fIpattern\fR is a qualified name, the resulting list of command names has each one qualified with the name of the specified namespace, and only the commands defined in the named namespace are returned. '\" Technically, most of this hasn't changed; that's mostly just the '\" way it always worked. Hardly anyone knew that though. .VE 8.5 .TP \fBinfo complete \fIcommand\fR Returns 1 if \fIcommand\fR is a complete Tcl command in the sense of having no unclosed quotes, braces, brackets or array element names. If the command doesn't appear to be complete then 0 is returned. This command is typically used in line-oriented input environments to allow users to type in commands that span multiple lines; if the |
︙ | ︙ | |||
71 72 73 74 75 76 77 | Otherwise it returns \fB1\fR and places the default value of \fIarg\fR into variable \fIvarname\fR. .TP \fBinfo exists \fIvarName\fR Returns \fB1\fR if the variable named \fIvarName\fR exists in the current context (either as a global or local variable) and has been defined by being given a value, returns \fB0\fR otherwise. | < < < < | 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 | Otherwise it returns \fB1\fR and places the default value of \fIarg\fR into variable \fIvarname\fR. .TP \fBinfo exists \fIvarName\fR Returns \fB1\fR if the variable named \fIvarName\fR exists in the current context (either as a global or local variable) and has been defined by being given a value, returns \fB0\fR otherwise. .TP \fBinfo functions \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of all the math functions currently defined. If \fIpattern\fR is specified, only those functions whose name matches \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. .TP \fBinfo globals \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of all the names of currently-defined global variables. Global variables are variables in the global namespace. 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 hostname\fR Returns the name of the computer on which this invocation is being executed. Note that this name is not guaranteed to be the fully qualified domain name of the host. Where machines have several different names (as is common on systems with both TCP/IP (DNS) and NetBIOS-based networking installed,) it is the name that is suitable for TCP/IP networking that is returned. .TP \fBinfo level\fR ?\fInumber\fR? If \fInumber\fR is not specified, this command returns a number giving the stack level of the invoking procedure, or 0 if the command is invoked at top-level. If \fInumber\fR is specified, then the result is a list consisting of the name and arguments for the procedure call at level \fInumber\fR on the stack. If \fInumber\fR |
︙ | ︙ |
Changes to doc/interp.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" Copyright (c) 2004 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" Copyright (c) 2004 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: interp.n,v 1.22.2.1 2005/04/10 23:14:43 kennykb 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 |
︙ | ︙ | |||
34 35 36 37 38 39 40 | a command in a slave interpreter which, when invoked, causes a command to be invoked in its master interpreter or in another slave interpreter. The only other connections between interpreters are through environment variables (the \fBenv\fR variable), which are normally shared among all interpreters in the application, .VS 8.5 and by resource limit exceeded callbacks. | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | a command in a slave interpreter which, when invoked, causes a command to be invoked in its master interpreter or in another slave interpreter. The only other connections between interpreters are through environment variables (the \fBenv\fR variable), which are normally shared among all interpreters in the application, .VS 8.5 and by resource limit exceeded callbacks. .VE 8.5 Note that the name space for files (such as the names returned by the \fBopen\fR command) is no longer shared between interpreters. Explicit commands are provided to share files and to transfer references to open files from one interpreter to another. .PP The \fBinterp\fR command also provides support for \fIsafe\fR |
︙ | ︙ |
Changes to doc/lappend.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lappend.n,v 1.9.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH lappend n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lappend \- Append list elements onto a variable |
︙ | ︙ | |||
39 40 41 42 43 44 45 | % \fBlappend\fR var 2 1 2 % \fBlappend\fR var 3 4 5 1 2 3 4 5 .CE .SH "SEE ALSO" | | < < < | 39 40 41 42 43 44 45 46 47 48 49 50 | % \fBlappend\fR var 2 1 2 % \fBlappend\fR var 3 4 5 1 2 3 4 5 .CE .SH "SEE ALSO" list(n), lindex(n), linsert(n), llength(n), lset(n), lsort(n), lrange(n) .SH KEYWORDS append, element, list, variable |
Changes to doc/lindex.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < < > | | < > > < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 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 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lindex.n,v 1.8.2.2 2005/05/05 17:55:24 kennykb Exp $ '\" .so man.macros .TH lindex n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lindex \- Retrieve an element from a list .SH SYNOPSIS \fBlindex \fIlist ?index...?\fR .BE .SH DESCRIPTION .PP The \fBlindex\fP command accepts a parameter, \fIlist\fP, which it treats as 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. .PP If no indices are presented, the command takes the form: .CS lindex list .CE or .CS lindex list {} .CE In this case, the return value of \fBlindex\fR is simply the value of the \fIlist\fR parameter. .PP When presented with a single index, the \fBlindex\fR command treats \fIlist\fR as a Tcl list and returns the \fIindex\fR'th element from it (0 refers to the first element of the list). In extracting the element, \fBlindex\fR observes the same rules concerning braces and quotes and backslashes as the Tcl command interpreter; however, variable substitution and command substitution do not occur. If \fIindex\fR is negative or greater than or equal to the number of elements in \fIvalue\fR, then an empty string is returned. .VS 8.5 The interpretation of each simple \fIindex\fR value is the same as for the command \fBstring index\fR, supporting simple index arithmetic and indices relative to the end of the list. .VE 8.5 .PP If additional \fIindex\fR arguments are supplied, then each argument is used in turn to select an element from the previous indexing operation, allowing the script to select elements from sublists. The command, .CS lindex $a 1 2 3 .CE or |
︙ | ︙ | |||
76 77 78 79 80 81 82 | \fBlindex\fR {a b c} end \fI=> c\fR \fBlindex\fR {a b c} end-1 \fI=> b\fR \fBlindex\fR {{a b c} {d e f} {g h i}} 2 1 \fI=> h\fR \fBlindex\fR {{a b c} {d e f} {g h i}} {2 1} \fI=> h\fR \fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} 1 1 0 \fI=> g\fR \fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} {1 1 0} \fI=> g\fR .CE | < > | | < < | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | \fBlindex\fR {a b c} end \fI=> c\fR \fBlindex\fR {a b c} end-1 \fI=> b\fR \fBlindex\fR {{a b c} {d e f} {g h i}} 2 1 \fI=> h\fR \fBlindex\fR {{a b c} {d e f} {g h i}} {2 1} \fI=> h\fR \fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} 1 1 0 \fI=> g\fR \fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} {1 1 0} \fI=> g\fR .CE .SH "SEE ALSO" list(n), lappend(n), linsert(n), llength(n), lsearch(n), lset(n), lsort(n), lrange(n), lreplace(n), .VS 8.5 string(n) .VE .SH KEYWORDS element, index, list |
Changes to doc/linsert.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | > | < | | > < | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: linsert.n,v 1.10.2.2 2005/05/05 17:55:24 kennykb Exp $ '\" .so man.macros .TH linsert n 8.2 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME linsert \- Insert elements into a list .SH SYNOPSIS \fBlinsert \fIlist index element \fR?\fIelement element ...\fR? .BE .SH DESCRIPTION .PP This command produces a new list from \fIlist\fR by inserting all of the \fIelement\fR arguments just before the \fIindex\fR'th element of \fIlist\fR. Each \fIelement\fR argument will become a separate element of the new list. If \fIindex\fR is less than or equal to zero, then the new elements are inserted at the beginning of the list. .VS 8.5 The interpretation of the \fIindex\fR value is the same as for the command \fBstring index\fR, supporting simple index arithmetic and indices relative to the end of the list. .VE .SH EXAMPLE Putting some values into a list, first indexing from the start and then indexing from the end, and then chaining them together: .CS set oldList {the fox jumps over the dog} set midList [\fBlinsert\fR $oldList 1 quick] set newList [\fBlinsert\fR $midList end-1 lazy] # The old lists still exist though... set newerList [\fBlinsert\fR [\fBlinsert\fR $oldList end-1 quick] 1 lazy] .CE .SH "SEE ALSO" list(n), lappend(n), lindex(n), llength(n), lsearch(n), lset(n), lsort(n), lrange(n), lreplace(n), .VS 8.5 string(n) .VE .SH KEYWORDS element, insert, list |
Changes to doc/llength.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: llength.n,v 1.8.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH llength n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME llength \- Count the number of elements in a list |
︙ | ︙ | |||
46 47 48 49 50 51 52 | An empty list is not necessarily an empty string: .CS % set var { }; puts "[string length $var],[\fBllength\fR $var]" 1,0 .CE .SH "SEE ALSO" | < < | 46 47 48 49 50 51 52 53 54 55 56 57 | An empty list is not necessarily an empty string: .CS % set var { }; puts "[string length $var],[\fBllength\fR $var]" 1,0 .CE .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), lsearch(n), lset(n), lsort(n), lrange(n), lreplace(n) .SH KEYWORDS element, list, length |
Changes to doc/load.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: load.n,v 1.12.2.2 2005/05/21 15:10:25 kennykb 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 |
︙ | ︙ | |||
88 89 90 91 92 93 94 | .PP If \fIpackageName\fR is omitted or specified as an empty string, Tcl tries to guess the name of the package. This may be done differently on different platforms. The default guess, which is used on most UNIX platforms, is to take the last element of \fIfileName\fR, strip off the first three characters if they are \fBlib\fR, and use any following | < < < < | 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 | .PP If \fIpackageName\fR is omitted or specified as an empty string, Tcl tries to guess the name of the package. This may be done differently on different platforms. The default guess, which is used on most UNIX platforms, is to take the last element of \fIfileName\fR, strip off the first three characters if they are \fBlib\fR, and use any following alphabetic and underline characters as the module name. For example, the command \fBload libxyz4.2.so\fR uses the module name \fBxyz\fR and the command \fBload bin/last.so {}\fR uses the module name \fBlast\fR. .PP If \fIfileName\fR is an empty string, then \fIpackageName\fR must be specified. The \fBload\fR command first searches for a statically loaded package (one that has been registered by calling the \fBTcl_StaticPackage\fR procedure) by that name; if one is found, it is used. Otherwise, the \fBload\fR command searches for a dynamically loaded package by that name, and uses it if it is found. If several different files have been \fBload\fRed with different versions of the package, Tcl picks the file that was loaded first. .SH "PORTABILITY ISSUES" .TP \fBWindows\fR\0\0\0\0\0 . When a load fails with "library not found" error, it is also possible that a dependent library was not found. To see the dependent libraries, type ``dumpbin -imports <dllname>'' in a DOS console to see what the |
︙ | ︙ | |||
133 134 135 136 137 138 139 | .SH EXAMPLE The following is a minimal extension: .PP .CS #include <tcl.h> #include <stdio.h> static int fooCmd(ClientData clientData, | | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 | .SH EXAMPLE The following is a minimal extension: .PP .CS #include <tcl.h> #include <stdio.h> static int fooCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { printf("called with %d arguments\\n", objc); return TCL_OK; } int Foo_Init(Tcl_Interp *interp) { if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { return TCL_ERROR; } |
︙ | ︙ | |||
155 156 157 158 159 160 161 | (e.g. \fBfoo.dll\fR on Windows, \fBlibfoo.so\fR on Solaris and Linux) it can then be loaded into Tcl with the following: .PP .CS # Load the extension switch $tcl_platform(platform) { windows { | | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | (e.g. \fBfoo.dll\fR on Windows, \fBlibfoo.so\fR on Solaris and Linux) it can then be loaded into Tcl with the following: .PP .CS # Load the extension switch $tcl_platform(platform) { windows { \fBload\fR [file join [pwd] foo.dll] } unix { \fBload\fR ./libfoo[info sharedlibextension] } } # Now execute the command defined by the extension |
︙ | ︙ |
Changes to doc/lrange.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | > | < > > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lrange.n,v 1.9.2.2 2005/05/05 17:55:25 kennykb Exp $ '\" .so man.macros .TH lrange n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lrange \- Return one or more adjacent elements from a list .SH SYNOPSIS \fBlrange \fIlist first last\fR .BE .SH DESCRIPTION .PP \fIList\fR must be a valid Tcl list. This command will return a new list consisting of elements \fIfirst\fR through \fIlast\fR, inclusive. .VS 8.5 The index values \fIfirst\fR and \fIlast\fR are interpreted the same as index values for the command \fBstring index\fR, supporting simple index arithmetic and indices relative to the end of the list. .VE If \fIfirst\fR is less than zero, it is treated as if it were zero. If \fIlast\fR is greater than or equal to the number of elements in the list, then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty string is returned. Note: ``\fBlrange \fIlist first first\fR'' does not always produce the same result as ``\fBlindex \fIlist first\fR'' (although it often does |
︙ | ︙ | |||
62 63 64 65 66 67 68 | % lindex $var 1 elements to % \fBlrange\fR $var 1 1 {elements to} .CE .SH "SEE ALSO" | < | > > | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | % lindex $var 1 elements to % \fBlrange\fR $var 1 1 {elements to} .CE .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), lset(n), lreplace(n), lsort(n), .VS 8.5 string(n) .VE .SH KEYWORDS element, list, range, sublist |
Changes to doc/lreplace.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | > > > | > > > | < | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lreplace.n,v 1.10.2.2 2005/05/05 17:55:25 kennykb Exp $ '\" .so man.macros .TH lreplace n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lreplace \- Replace elements in a list with new elements .SH SYNOPSIS \fBlreplace \fIlist first last \fR?\fIelement element ...\fR? .BE .SH DESCRIPTION .PP \fBlreplace\fR returns a new list formed by replacing one or more elements of \fIlist\fR with the \fIelement\fR arguments. .VS 8.5 \fIfirst\fR and \fIlast\fR are index values specifying the first and last elements of the range to replace. The index values \fIfirst\fR and \fIlast\fR are interpreted the same as index values for the command \fBstring index\fR, supporting simple index arithmetic and indices relative to the end of the list. 0 refers to the first element of the list, and \fBend\fR refers to the last element of the list. If \fIlist\fR is empty, then \fIfirst\fR and \fIlast\fR are ignored. .VE If \fIfirst\fR is less than zero, it is considered to refer to the first element of the list. For non-empty lists, the element indicated by \fIfirst\fR must exist. If \fIlast\fR is less than zero but greater than \fIfirst\fR, then any specified elements will be prepended to the list. If \fIlast\fR is |
︙ | ︙ | |||
61 62 63 64 65 66 67 | % set var {a b c d e} a b c d e % set var [\fBlreplace\fR $var end end] a b c d .CE .SH "SEE ALSO" | < | > > > | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 | % set var {a b c d e} a b c d e % set var [\fBlreplace\fR $var end end] a b c d .CE .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), lset(n), lrange(n), lsort(n), .VS 8.5 string(n) .VE .SH KEYWORDS element, list, replace |
Changes to doc/lsearch.n.
|
| < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | '\" '\" 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. '\" Copyright (c) 2003-2004 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lsearch.n,v 1.21.2.3 2005/07/12 20:36:15 kennykb Exp $ '\" .so man.macros .TH lsearch n 8.5 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 |
︙ | ︙ | |||
31 32 33 34 35 36 37 | \fIpattern\fR and must have one of the values below: .SS "MATCHING STYLE OPTIONS" If all matching style options are omitted, the default matching style is \fB\-glob\fR. If more than one matching style is specified, the last matching style given takes precedence. .TP \fB\-exact\fR | > | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | \fIpattern\fR and must have one of the values below: .SS "MATCHING STYLE OPTIONS" If all matching style options are omitted, the default matching style is \fB\-glob\fR. If more than one matching style is specified, the last matching style given takes precedence. .TP \fB\-exact\fR \fIPattern\fR is a literal string that is compared for exact equality against each list element. .TP \fB\-glob\fR \fIPattern\fR is a glob-style pattern which is matched against each list element using the same rules as the \fBstring match\fR command. .TP \fB\-regexp\fR \fIPattern\fR is treated as a regular expression and matched against |
︙ | ︙ | |||
67 68 69 70 71 72 73 | the result of the command is the list of all values that matched. .TP \fB\-not\fR This negates the sense of the match, returning the index of the first non-matching value in the list. .TP \fB\-start\fR\0\fIindex\fR | | > | | | > > > > > > > > | 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 | the result of the command is the list of all values that matched. .TP \fB\-not\fR This negates the sense of the match, returning the index of the first non-matching value in the list. .TP \fB\-start\fR\0\fIindex\fR The list is searched starting at position \fIindex\fR. .VS 8.5 The interpretation of the \fIindex\fR value is the same as for the command \fBstring index\fR, supporting simple index arithmetic and indices relative to the end of the list. .VE 8.5 .SS "CONTENTS DESCRIPTION OPTIONS" These options describe how to interpret the items in the list being searched. They are only meaningful when used with the \fB\-exact\fR and \fB\-sorted\fR options. If more than one is specified, the last one takes precedence. The default is \fB\-ascii\fR. .TP \fB\-ascii\fR The list elements are to be examined as Unicode strings (the name is for backward-compatibility reasons.) .TP \fB\-dictionary\fR The list elements are to be compared using dictionary-style comparisons (see \fBlsort\fR for a fuller description). Note that this only makes a meaningful difference from the \fB\-ascii\fR option when the \fB\-sorted\fR option is given, because values are only dictionary-equal when exactly equal. .TP \fB\-integer\fR The list elements are to be compared as integers. .VS 8.5 .TP \fB\-nocase\fR Causes comparisons to be handled in a case-insensitive manner. Has no effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or \fB\-real\fR options. .VE 8.5 .TP \fB\-real\fR The list elements are to be compared as floating-point values. .SS "SORTED LIST OPTIONS" These options (only meaningful with the \fB\-sorted\fR option) specify how the list is sorted. If more than one is given, the last one takes precedence. The default option is \fB\-increasing\fR. |
︙ | ︙ | |||
163 164 165 166 167 168 169 | .CS \fBlsearch\fR -index 1 -all -inline {{a abc} {b bcd} {c cde}} *bc* => {a abc} {b bcd} .CE .SH "SEE ALSO" foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), | | > > > > > > > > | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 | .CS \fBlsearch\fR -index 1 -all -inline {{a abc} {b bcd} {c cde}} *bc* => {a abc} {b bcd} .CE .SH "SEE ALSO" foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), lset(n), lsort(n), lrange(n), lreplace(n), .VS 8.5 string(n) .VE .SH KEYWORDS list, match, pattern, regular expression, search, string '\" Local Variables: '\" mode: nroff '\" End: |
Changes to doc/lset.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lset.n,v 1.7.2.1 2005/05/05 17:55:26 kennykb 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 |
︙ | ︙ | |||
48 49 50 51 52 53 54 | replaced with \fInewValue\fR. This new list is stored in the variable \fIvarName\fR, and is also the return value from the \fBlset\fR command. .PP If \fIindex\fR is negative or greater than or equal to the number of elements in \fI$varName\fR, then an error occurs. .PP | > | | < > > | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | replaced with \fInewValue\fR. This new list is stored in the variable \fIvarName\fR, and is also the return value from the \fBlset\fR command. .PP If \fIindex\fR is negative or greater than or equal to the number of elements in \fI$varName\fR, then an error occurs. .PP .VS 8.5 The interpretation of each simple \fIindex\fR value is the same as for the command \fBstring index\fR, supporting simple index arithmetic and indices relative to the end of the list. .VE 8.5 .PP If additional \fIindex\fR arguments are supplied, then each argument is used in turn to address an element within a sublist designated by the previous indexing operation, allowing the script to alter elements in sublists. The command, .CS lset a 1 2 newValue |
︙ | ︙ | |||
103 104 105 106 107 108 109 | The indicated return value also becomes the new value of \fIx\fR. .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), | | > > > > | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | The indicated return value also becomes the new value of \fIx\fR. .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), .VS 8.5 string(n) .VE .SH KEYWORDS element, index, list, replace, set |
Changes to doc/lsort.n.
1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lsort.n,v 1.18.2.2 2005/07/12 20:36:16 kennykb Exp $ '\" .so man.macros .TH lsort n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lsort \- Sort the elements of a list .SH SYNOPSIS \fBlsort \fR?\fIoptions\fR? \fIlist\fR .BE |
︙ | ︙ | |||
74 75 76 77 78 79 80 | \fB\-index\0\fIindexList\fR If this option is specified, each of the elements of \fIlist\fR must itself be a proper Tcl sublist. Instead of sorting based on whole sublists, \fBlsort\fR will extract the \fIindexList\fR'th element from each sublist .VS 8.5 (as if the overall element and the \fIindexList\fR were passed to | | < < < | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | \fB\-index\0\fIindexList\fR If this option is specified, each of the elements of \fIlist\fR must itself be a proper Tcl sublist. Instead of sorting based on whole sublists, \fBlsort\fR will extract the \fIindexList\fR'th element from each sublist .VS 8.5 (as if the overall element and the \fIindexList\fR were passed to \fBlindex\fR) and sort based on the given element. .VE 8.5 For example, .RS .CS lsort -integer -index 1 {{First 24} {Second 18} {Third 30}} .CE returns \fB{Second 18} {First 24} {Third 30}\fR, and |
︙ | ︙ | |||
103 104 105 106 107 108 109 110 111 112 113 114 115 116 | .CE returns \fB{{d e m o} 34512} {{b i g} 12345} {{c o d e} 54321}\fR (because \fBe\fR sorts before \fBi\fR which sorts before \fBo\fR.) .VE 8.5 This option is much more efficient than using \fB\-command\fR to achieve the same effect. .RE .TP 20 \fB\-unique\fR If this option is specified, then only the last set of duplicate elements found in the list will be retained. Note that duplicates are determined relative to the comparison used in the sort. Thus if \fI-index 0\fR is used, \fB{1 a}\fR and \fB{1 b}\fR would be considered duplicates and only the second element, \fB{1 b}\fR, would | > > > > > > > | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 | .CE returns \fB{{d e m o} 34512} {{b i g} 12345} {{c o d e} 54321}\fR (because \fBe\fR sorts before \fBi\fR which sorts before \fBo\fR.) .VE 8.5 This option is much more efficient than using \fB\-command\fR to achieve the same effect. .RE .VS 8.5 .TP 20 \fB\-nocase\fR Causes comparisons to be handled in a case-insensitive manner. Has no effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or \fB\-real\fR options. .VE 8.5 .TP 20 \fB\-unique\fR If this option is specified, then only the last set of duplicate elements found in the list will be retained. Note that duplicates are determined relative to the comparison used in the sort. Thus if \fI-index 0\fR is used, \fB{1 a}\fR and \fB{1 b}\fR would be considered duplicates and only the second element, \fB{1 b}\fR, would |
︙ | ︙ |
Added doc/mathfunc.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. '\" Copyright (c) 2005 by Kevin B. Kenny <[email protected]>. 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: mathfunc.n,v 1.1.2.4 2005/10/08 13:44:37 dgp Exp $ '\" .so man.macros .TH mathfunc n 8.5 Tcl "Tcl Mathematical Functions" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME mathfunc \- Mathematical functions for Tcl expressions .SH SYNOPSIS package require \fBTcl 8.5\fR .sp \fB::tcl::mathfunc::abs\fR \fIarg\fR .br \fB::tcl::mathfunc::acos\fR \fIarg\fR .br \fB::tcl::mathfunc::asin\fR \fIarg\fR .br \fB::tcl::mathfunc::atan\fR \fIarg\fR .br \fB::tcl::mathfunc::atan2\fR \fIy\fR \fIx\fR .br \fB::tcl::mathfunc::bool\fR \fIarg\fR .br \fB::tcl::mathfunc::ceil\fR \fIarg\fR .br \fB::tcl::mathfunc::cos\fR \fIarg\fR .br \fB::tcl::mathfunc::cosh\fR \fIarg\fR .br \fB::tcl::mathfunc::double\fR \fIarg\fR .br \fB::tcl::mathfunc::exp\fR \fIarg\fR .br \fB::tcl::mathfunc::floor\fR \fIarg\fR .br \fB::tcl::mathfunc::fmod\fR \fIx\fR \fIy\fR .br \fB::tcl::mathfunc::hypot\fR \fIx\fR \fIy\fR .br \fB::tcl::mathfunc::int\fR \fIarg\fR .br \fB::tcl::mathfunc::log\fR \fIarg\fR .br \fB::tcl::mathfunc::log10\fR \fIarg\fR .br \fB::tcl::mathfunc::max\fR \fIarg\fR ?\fIarg\fR ...? .br \fB::tcl::mathfunc::min\fR \fIarg\fR ?\fIarg\fR ...? .br \fB::tcl::mathfunc::pow\fR \fIx\fR \fIy\fR .br \fB::tcl::mathfunc::rand\fR .br \fB::tcl::mathfunc::round\fR \fIarg\fR .br \fB::tcl::mathfunc::sin\fR \fIarg\fR .br \fB::tcl::mathfunc::sinh\fR \fIarg\fR .br \fB::tcl::mathfunc::sqrt\fR \fIarg\fR .br \fB::tcl::mathfunc::srand\fR \fIarg\fR .br \fB::tcl::mathfunc::tan\fR \fIarg\fR .br \fB::tcl::mathfunc::tanh\fR \fIarg\fR .br \fB::tcl::mathfunc::wide\fR \fIarg\fR .sp .BE .SH "DESCRIPTION" .PP The \fBexpr\fR command handles mathematical functions of the form \fBsin($x)\fR or \fBatan2($y,$x)\fR by converting them to calls of the form \fB[tcl::math::sin [expr {$x}]]\fR or \fB[tcl::math::atan2 [expr {$y}] [expr {$x}]]\fR. A number of math functions are available by default within the namespace \fB::tcl::mathfunc\fR; these functions are also available for code apart from \fBexpr\fR, by invoking the given commands directly. .PP Tcl supports the following mathematical functions in expressions, all of which work solely with floating-point numbers unless otherwise noted: .DS .ta 3c 6c 9c \fBabs\fR \fBacos\fR \fBasin\fR \fBatan\fR \fBatan2\fR \fBbool\fR \fBceil\fR \fBcos\fR \fBcosh\fR \fBdouble\fR \fBexp\fR \fBfloor\fR \fBfmod\fR \fBhypot\fR \fBint\fR \fBlog\fR \fBlog10\fR \fBmax\fR \fBmin\fR \fBpow\fR \fBrand\fR \fBround\fR \fBsin\fR \fBsinh\fR \fBsqrt\fR \fBsrand\fR \fBtan\fR \fBtanh\fR \fBwide\fR .DE .PP .TP \fBabs(\fIarg\fB)\fR Returns the absolute value of \fIarg\fR. \fIArg\fR may be either integer or floating-point, and the result is returned in the same form. .TP \fBacos(\fIarg\fB)\fR Returns the arc cosine of \fIarg\fR, in the range [\fI0\fR,\fIpi\fR] radians. \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR]. .TP \fBasin(\fIarg\fB)\fR Returns the arc sine of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR] radians. \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR]. .TP \fBatan(\fIarg\fB)\fR Returns the arc tangent of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR] radians. .TP \fBatan2(\fIy, x\fB)\fR Returns the arc tangent of \fIy\fR/\fIx\fR, in the range [\fI-pi\fR,\fIpi\fR] radians. \fIx\fR and \fIy\fR cannot both be 0. If \fIx\fR is greater than \fI0\fR, this is equivalent to \fBatan(\fIy/x\fB)\fR. .TP \fBbool(\fIarg\fB)\fR Accepts any numerical value, or any string acceptable to \fBstring is boolean\fR, and returns the corresponding boolean value \fB0\fR or \fB1\fR. Non-zero numbers are true. Other numbers are false. Non-numeric strings produce boolean value in agreement with \fBstring is true\fR and \fBstring is false\fR. .TP \fBceil(\fIarg\fB)\fR Returns the smallest integral floating-point value (i.e. with a zero fractional part) not less than \fIarg\fR. .TP \fBcos(\fIarg\fB)\fR Returns the cosine of \fIarg\fR, measured in radians. .TP \fBcosh(\fIarg\fB)\fR Returns the hyperbolic cosine of \fIarg\fR. If the result would cause an overflow, an error is returned. .TP \fBdouble(\fIarg\fB)\fR If \fIarg\fR is a floating-point value, returns \fIarg\fR, otherwise converts \fIarg\fR to floating-point and returns the converted value. .TP \fBexp(\fIarg\fB)\fR Returns the exponential of \fIarg\fR, defined as \fIe\fR**\fIarg\fR. If the result would cause an overflow, an error is returned. .TP \fBfloor(\fIarg\fB)\fR Returns the largest integral floating-point value (i.e. with a zero fractional part) not greater than \fIarg\fR. .TP \fBfmod(\fIx, y\fB)\fR Returns the floating-point remainder of the division of \fIx\fR by \fIy\fR. If \fIy\fR is 0, an error is returned. .TP \fBhypot(\fIx, y\fB)\fR Computes the length of the hypotenuse of a right-angled triangle \fBsqrt(\fIx\fR*\fIx\fR+\fIy\fR*\fIy\fB)\fR. .TP \fBint(\fIarg\fB)\fR If \fIarg\fR is an integer value of the same width as the machine word, returns \fIarg\fR, otherwise converts \fIarg\fR to an integer (of the same size as a machine word, i.e. 32-bits on 32-bit systems, and 64-bits on 64-bit systems) by truncation and returns the converted value. .TP \fBlog(\fIarg\fB)\fR Returns the natural logarithm of \fIarg\fR. \fIArg\fR must be a positive value. .TP \fBlog10(\fIarg\fB)\fR Returns the base 10 logarithm of \fIarg\fR. \fIArg\fR must be a positive value. .TP \fBmax(\fIarg\fB, \fI...\fB)\fR Returns the maximum value of all given numeric arguments. .TP \fBmin(\fIarg\fB, \fI...\fB)\fR Returns the minimum value of all given numeric arguments. .TP \fBpow(\fIx, y\fB)\fR Computes the value of \fIx\fR raised to the power \fIy\fR. If \fIx\fR is negative, \fIy\fR must be an integer value. .TP \fBrand()\fR Returns a pseudo-random floating-point value in the range (\fI0\fR,\fI1\fR). The generator algorithm is a simple linear congruential generator that is not cryptographically secure. Each result from \fBrand\fR completely determines all future results from subsequent calls to \fBrand\fR, so \fBrand\fR should not be used to generate a sequence of secrets, such as one-time passwords. The seed of the generator is initialized from the internal clock of the machine or may be set with the \fBsrand\fR function. .TP \fBround(\fIarg\fB)\fR If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts \fIarg\fR to integer by rounding and returns the converted value. .TP \fBsin(\fIarg\fB)\fR Returns the sine of \fIarg\fR, measured in radians. .TP \fBsinh(\fIarg\fB)\fR Returns the hyperbolic sine of \fIarg\fR. If the result would cause an overflow, an error is returned. .TP \fBsqrt(\fIarg\fB)\fR Returns the square root of \fIarg\fR. \fIArg\fR must be non-negative. .TP \fBsrand(\fIarg\fB)\fR The \fIarg\fR, which must be an integer, is used to reset the seed for the random number generator of \fBrand\fR. Returns the first random number (see \fBrand()\fR) from that seed. Each interpreter has its own seed. .TP \fBtan(\fIarg\fB)\fR Returns the tangent of \fIarg\fR, measured in radians. .TP \fBtanh(\fIarg\fB)\fR Returns the hyperbolic tangent of \fIarg\fR. .TP \fBwide(\fIarg\fB)\fR Converts \fIarg\fR to an integer value at least 64-bits wide (by sign-extension if \fIarg\fR is a 32-bit number) if it is not one already. .PP In addition to these predefined functions, applications may define additional functions by using \fBproc\fR (or any other method, such as \fBinterp alias\fR or \fBTcl_CreateObjCommand\fR) to define new commands in the \fBtcl::mathfunc\fR namespace. In addition, an obsolete interface named \fBTcl_CreateMathFunc\fR() is available to extensions that are written in C. The latter interface is not recommended for new implementations.. .SH "SEE ALSO" expr(n), namespace(n) .SH "COPYRIGHT" Copyright (c) 1993 The Regents of the University of California. .br Copyright (c) 1994-2000 Sun Microsystems Incorporated. .br Copyright (c) 2005 by Kevin B. Kenny <[email protected]>. All rights reserved. |
Changes to doc/msgcat.n.
︙ | ︙ | |||
91 92 93 94 95 96 97 | The list is ordered from most specific to least preference. The list is derived from the current locale set in msgcat by \fB::msgcat::mclocale\fR, and cannot be set independently. For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR .VS 1.4 returns \fB{en_US_funky en_US en {}}\fR. | | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | The list is ordered from most specific to least preference. The list is derived from the current locale set in msgcat by \fB::msgcat::mclocale\fR, and cannot be set independently. For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR .VS 1.4 returns \fB{en_US_funky en_US en {}}\fR. .VE 1.4 .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 |
︙ | ︙ | |||
166 167 168 169 170 171 172 | 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 .VS 1.4 en_GB_Funky, the locales ``en_GB_Funky'', ``en_GB'', ``en'' and ``'' (the empty string) | | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | 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 .VS 1.4 en_GB_Funky, the locales ``en_GB_Funky'', ``en_GB'', ``en'' and ``'' (the empty string) .VE 1.4 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 to the namespace from which they were added. This allows |
︙ | ︙ | |||
236 237 238 239 240 241 242 | .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 | | | | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | .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 .VS 1.4 \fIException:\fR The message file for the root locale ``'' is called \fBROOT.msg\fR. This exception is made so as not to cause peculiar behavior, such as marking the message file as ``hidden'' on Unix file systems. .VE 1.4 .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 |
︙ | ︙ |
Changes to doc/namespace.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | '\" '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" Copyright (c) 2004-2005 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: namespace.n,v 1.16.2.2 2005/07/12 20:36:16 kennykb Exp $ '\" .so man.macros .TH namespace n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME namespace \- create and manipulate contexts for commands and variables |
︙ | ︙ | |||
211 212 213 214 215 216 217 218 219 220 221 222 223 224 | the command's own fully-qualified name is returned. .TP \fBnamespace parent\fR ?\fInamespace\fR? Returns the fully-qualified name of the parent namespace for namespace \fInamespace\fR. If \fInamespace\fR is not specified, the fully-qualified name of the current namespace's parent is returned. .TP \fBnamespace qualifiers\fR \fIstring\fR Returns any leading namespace qualifiers for \fIstring\fR. Qualifiers are namespace names separated by double colons (\fB::\fR). For the \fIstring\fR \fB::foo::bar::x\fR, this command returns \fB::foo::bar\fR, and for \fB::\fR it returns an empty string. | > > > > > > > > > > > | 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 | the command's own fully-qualified name is returned. .TP \fBnamespace parent\fR ?\fInamespace\fR? Returns the fully-qualified name of the parent namespace for namespace \fInamespace\fR. If \fInamespace\fR is not specified, the fully-qualified name of the current namespace's parent is returned. .TP \fBnamespace path\fR ?\fInamespaceList\fR? '\" Should really have the .TP inside the .VS, but that triggers a groff bug .VS 8.5 Returns the command resolution path of the current namespace. If \fInamespaceList\fR is specified as a list of named namespaces, the current namespace's command resolution path is set to those namespaces and returns the empty list. The default command resolution path is always empty. See the section \fBNAME RESOLUTION\fR below for an explanation of the rules regarding name resolution. .VE 8.5 .TP \fBnamespace qualifiers\fR \fIstring\fR Returns any leading namespace qualifiers for \fIstring\fR. Qualifiers are namespace names separated by double colons (\fB::\fR). For the \fIstring\fR \fB::foo::bar::x\fR, this command returns \fB::foo::bar\fR, and for \fB::\fR it returns an empty string. |
︙ | ︙ | |||
383 384 385 386 387 388 389 | This means you can give qualified names to such commands as \fBset\fR, \fBproc\fR, \fBrename\fR, and \fBinterp alias\fR. If you provide a fully-qualified name that starts with a \fB::\fR, there is no question about what command, variable, or namespace you mean. However, if the name does not start with a \fB::\fR (i.e., is \fIrelative\fR), | | | > > > > > > > > | 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 | This means you can give qualified names to such commands as \fBset\fR, \fBproc\fR, \fBrename\fR, and \fBinterp alias\fR. If you provide a fully-qualified name that starts with a \fB::\fR, there is no question about what command, variable, or namespace you mean. However, if the name does not start with a \fB::\fR (i.e., is \fIrelative\fR), Tcl follows basic rules for looking it up: Variable names are always resolved by looking first in the current namespace, and then in the global namespace. .VS 8.5 Command names are also always resolved by looking in the current namespace first. If not found there, they are searched for in every namespace on the current namespace's command path (which is empty by default). If not found there, command names are looked up in the global namespace (or, failing that, are processed by the \fBunknown\fR command.) .VE 8.5 Namespace names, on the other hand, are always resolved by looking in only the current namespace. .PP In the following example, .CS set traceLevel 0 \fBnamespace eval\fR Debug { |
︙ | ︙ | |||
760 761 762 763 764 765 766 | \fBnamespace export\fR grill } .CE .PP Call the command defined in the previous example in various ways. .CS # Direct call | | > > > > > > | | | 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 | \fBnamespace export\fR grill } .CE .PP Call the command defined in the previous example in various ways. .CS # Direct call ::foo::grill # Use the command resolution path to find the name \fBnamespace eval\fR boo { \fBnamespace path\fR ::foo grill } # Import into current namespace, then call local alias \fBnamespace import\fR foo::grill grill # Create two ensembles, one with the default name and one with a # specified name. Then call through the ensembles. \fBnamespace eval\fR foo { \fBnamespace ensemble\fR create \fBnamespace ensemble\fR create -command ::foobar } foo grill foobar grill .CE .PP Look up where the command imported in the previous example came from: .CS puts "grill came from [\fBnamespace origin\fR grill]" .CE .SH "SEE ALSO" interp(n), variable(n) .SH KEYWORDS command, ensemble, exported, internal, variable |
Changes to doc/open.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: open.n,v 1.22.2.2 2005/05/05 17:55:27 kennykb 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 |
︙ | ︙ | |||
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 | create a new empty file. Set the initial access position to the end of the file. .TP 15 \fBa+\fR Open the file for reading and writing. If the file doesn't exist, create a new empty file. Set the initial access position to the end of the file. .PP In the second form, \fIaccess\fR consists of a list of any of the following flags, all of which have the standard POSIX meanings. One of the flags must be either \fBRDONLY\fR, \fBWRONLY\fR or \fBRDWR\fR. .TP 15 \fBRDONLY\fR Open the file for reading only. .TP 15 \fBWRONLY\fR Open the file for writing only. .TP 15 \fBRDWR\fR Open the file for both reading and writing. .TP 15 \fBAPPEND\fR Set the file pointer to the end of the file prior to each write. .TP 15 \fBCREAT\fR Create the file if it doesn't already exist (without this flag it is an error for the file not to exist). .TP 15 \fBEXCL\fR If \fBCREAT\fR is also specified, an error is returned if the | > > > > > > > > > > > > > | 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 | create a new empty file. Set the initial access position to the end of the file. .TP 15 \fBa+\fR Open the file for reading and writing. If the file doesn't exist, create a new empty file. Set the initial access position to the end of the file. .VS 8.5 .PP All of the legal \fIaccess\fR values above may have the character \fBb\fR added as the second or third character in the value to indicate that the opened channel should be configured with the \fB-translation binary\fR option, making the channel suitable for reading or writing of binary data. .VE 8.5 .PP In the second form, \fIaccess\fR consists of a list of any of the following flags, all of which have the standard POSIX meanings. One of the flags must be either \fBRDONLY\fR, \fBWRONLY\fR or \fBRDWR\fR. .TP 15 \fBRDONLY\fR Open the file for reading only. .TP 15 \fBWRONLY\fR Open the file for writing only. .TP 15 \fBRDWR\fR Open the file for both reading and writing. .TP 15 \fBAPPEND\fR Set the file pointer to the end of the file prior to each write. .TP 15 .VS 8.5 \fBBINARY\fR Configure the opened channed with the \fB-translation binary\fR option. .VE 8.5 .TP 15 \fBCREAT\fR Create the file if it doesn't already exist (without this flag it is an error for the file not to exist). .TP 15 \fBEXCL\fR If \fBCREAT\fR is also specified, an error is returned if the |
︙ | ︙ | |||
102 103 104 105 106 107 108 | \fBTRUNC\fR If the file exists it is truncated to zero length. .PP If a new file is created as part of opening it, \fIpermissions\fR (an integer) is used to set the permissions for the new file in conjunction with the process's file mode creation mask. \fIPermissions\fR defaults to 0666. | < < < < < < < < | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | \fBTRUNC\fR If the file exists it is truncated to zero length. .PP If a new file is created as part of opening it, \fIpermissions\fR (an integer) is used to set the permissions for the new file in conjunction with the process's file mode creation mask. \fIPermissions\fR defaults to 0666. .SH "COMMAND PIPELINES" .PP If the first character of \fIfileName\fR is ``|'' then the remaining characters of \fIfileName\fR are treated as a list of arguments that describe a command pipeline to invoke, in the same style as the arguments for \fBexec\fR. |
︙ | ︙ | |||
138 139 140 141 142 143 144 | a Tcl error is generated when \fBclose\fR is called on the channel unless the pipeline is in non-blocking mode then no exit status is returned (a silent \fBclose\fR with -blocking 0). .PP It is often useful to use the \fBfileevent\fR command with pipelines so other processing may happen at the same time as running the command in the background. | < | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 | a Tcl error is generated when \fBclose\fR is called on the channel unless the pipeline is in non-blocking mode then no exit status is returned (a silent \fBclose\fR with -blocking 0). .PP It is often useful to use the \fBfileevent\fR command with pipelines so other processing may happen at the same time as running the command in the background. .SH "SERIAL COMMUNICATIONS" .PP If \fIfileName\fR refers to a serial port, then the specified serial port is opened and initialized in a platform-dependent manner. Acceptable values for the \fIfileName\fR to use to open a serial port are described in the PORTABILITY ISSUES section. .PP |
︙ | ︙ | |||
318 319 320 321 322 323 324 | \fBFRAME\fR A stop-bit error has been detected by your UART. Wrong mode settings with \fBfconfigure -mode\fR or a noisy data line (RXD) may cause this error. .TP 10 \fBBREAK\fR A BREAK condition has been detected by your UART (see above). | < | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 | \fBFRAME\fR A stop-bit error has been detected by your UART. Wrong mode settings with \fBfconfigure -mode\fR or a noisy data line (RXD) may cause this error. .TP 10 \fBBREAK\fR A BREAK condition has been detected by your UART (see above). .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 |
︙ | ︙ | |||
380 381 382 383 384 385 386 | until the pipe is actually closed. This problem occurs because 16-bit DOS applications are run synchronously, as described above. .TP \fBUnix\fR\0\0\0\0\0\0\0 Valid values for \fIfileName\fR to open a serial port are generally of the form \fB/dev/tty\fIX\fR, where \fIX\fR is \fBa\fR or \fBb\fR, but the name of any pseudo-file that maps to a serial port may be used. | < < | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 | until the pipe is actually closed. This problem occurs because 16-bit DOS applications are run synchronously, as described above. .TP \fBUnix\fR\0\0\0\0\0\0\0 Valid values for \fIfileName\fR to open a serial port are generally of the form \fB/dev/tty\fIX\fR, where \fIX\fR is \fBa\fR or \fBb\fR, but the name of any pseudo-file that maps to a serial port may be used. Advanced configuration options are only supported for serial ports when Tcl is built to use the POSIX serial interface. .sp When running Tcl interactively, there may be some strange interactions between the console, if one is present, and a command pipeline that uses standard input. If a command pipeline is opened for reading, some of the lines entered at the console will be sent to the command pipeline and some will be sent to the Tcl evaluator. This problem only occurs because both Tcl and the child application are competing for the console at the |
︙ | ︙ |
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 15 16 17 18 19 20 21 22 23 24 | '\" '\" 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.14.6.2 2005/04/10 23:14:43 kennykb 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 .SH SYNOPSIS .nf \fBpkg_mkIndex ?\fI\-direct\fR? ?\fI\-lazy\fR? ?\fI\-load pkgPat\fR? ?\fI\-verbose\fR? \fIdir\fR ?\fIpattern pattern ...\fR? .fi .BE .SH DESCRIPTION .PP \fBPkg_mkIndex\fR is a utility procedure that is part of the standard Tcl library. |
︙ | ︙ | |||
37 38 39 40 41 42 43 | the package and version number, and each binary file must contain a call to \fBTcl_PkgProvide\fR. .IP [2] Create the index by invoking \fBpkg_mkIndex\fR. The \fIdir\fR argument gives the name of a directory and each \fIpattern\fR argument is a \fBglob\fR-style pattern that selects script or binary files in \fIdir\fR. | < < | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | the package and version number, and each binary file must contain a call to \fBTcl_PkgProvide\fR. .IP [2] Create the index by invoking \fBpkg_mkIndex\fR. The \fIdir\fR argument gives the name of a directory and each \fIpattern\fR argument is a \fBglob\fR-style pattern that selects script or binary files in \fIdir\fR. The default pattern is \fB*.tcl\fR and \fB*.[info sharedlibextension]\fR. .br \fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR with package information about all the files given by the \fIpattern\fR arguments. It does this by loading each file into a slave interpreter and seeing what packages and new commands appear (this is why it is essential to have |
︙ | ︙ | |||
105 106 107 108 109 110 111 | \fB\-direct\fR The generated index will implement direct loading of the package upon \fBpackage require\fR. This is the default. .TP 15 \fB\-lazy\fR The generated index will manage to delay loading the package until the use of one of the commands provided by the package, instead of loading | | > | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | \fB\-direct\fR The generated index will implement direct loading of the package upon \fBpackage require\fR. This is the default. .TP 15 \fB\-lazy\fR The generated index will manage to delay loading the package until the use of one of the commands provided by the package, instead of loading it immediately upon \fBpackage require\fR. This is not compatible with the use of \fIauto_reset\fR, and therefore its use is discouraged. .TP 15 \fB\-load \fIpkgPat\fR The index process will pre-load any packages that exist in the current interpreter and match \fIpkgPat\fP into the slave interpreter used to generate the index. The pattern match uses string match rules, but without making case distinctions. See COMPLEX CASES below. |
︙ | ︙ | |||
155 156 157 158 159 160 161 | evaluates all of the \fBpkgIndex.tcl\fR files in the \fBauto_path\fR. The \fBpkgIndex.tcl\fR files contain \fBpackage ifneeded\fR commands for each version of each available package; these commands invoke \fBpackage provide\fR commands to announce the availability of the package, and they setup auto-loader information to load the files of the package. | < < < < | 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 | evaluates all of the \fBpkgIndex.tcl\fR files in the \fBauto_path\fR. The \fBpkgIndex.tcl\fR files contain \fBpackage ifneeded\fR commands for each version of each available package; these commands invoke \fBpackage provide\fR commands to announce the availability of the package, and they setup auto-loader information to load the files of the package. If the \fI\-lazy\fR flag was provided when the \fBpkgIndex.tcl\fR was generated, a given file of a given version of a given package isn't actually loaded until the first time one of its commands is invoked. Thus, after invoking \fBpackage require\fR you may not see the package's commands in the interpreter, but you will be able to invoke the commands and they will be auto-loaded. .SH "DIRECT LOADING" .PP Some packages, for instance packages which use namespaces and export commands or those which require special initialization, might select that their package files be loaded immediately upon \fBpackage require\fR instead of delaying the actual loading to the first use of one of the package's command. This is the default mode when generating the package index. It can be overridden by specifying the \fI\-lazy\fR argument. .SH "COMPLEX CASES" Most complex cases of dependencies among scripts and binary files, and packages being split among scripts and binary files are handled OK. However, you may have to adjust the order in which files are processed by \fBpkg_mkIndex\fR. These issues are described in detail below. |
︙ | ︙ |
Changes to doc/puts.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: puts.n,v 1.8.2.1 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH puts n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME puts \- Write to a channel .SH SYNOPSIS \fBputs \fR?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR .BE .SH DESCRIPTION .PP Writes the characters given by \fIstring\fR to the channel given by \fIchannelId\fR. .PP \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. The channel must have been opened for output. .PP If no \fIchannelId\fR is specified then it defaults to \fBstdout\fR. \fBPuts\fR normally outputs a newline character after \fIstring\fR, but this feature may be suppressed by specifying the \fB\-nonewline\fR switch. .PP Newline characters in the output are translated by \fBputs\fR to |
︙ | ︙ |
Changes to doc/re_syntax.n.
|
| < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: re_syntax.n,v 1.5.2.2 2005/04/10 23:14:43 kennykb Exp $ '\" .so man.macros .TH re_syntax n "8.1" Tcl "Tcl Built-In Commands" .BS .SH NAME re_syntax \- Syntax of Tcl regular expressions .BE |
︙ | ︙ | |||
45 46 47 48 49 50 51 | A branch is zero or more \fIconstraints\fR or \fIquantified atoms\fR, concatenated. It matches a match for the first, followed by a match for the second, etc; an empty branch matches the empty string. .PP A quantified atom is an \fIatom\fR possibly followed by a single \fIquantifier\fR. | | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | A branch is zero or more \fIconstraints\fR or \fIquantified atoms\fR, concatenated. It matches a match for the first, followed by a match for the second, etc; an empty branch matches the empty string. .PP A quantified atom is an \fIatom\fR possibly followed by a single \fIquantifier\fR. Without a quantifier, it matches a single match for the atom. The quantifiers, and what a so-quantified atom matches, are: .RS 2 .TP 6 \fB*\fR a sequence of 0 or more matches of the atom .TP |
︙ | ︙ | |||
82 83 84 85 86 87 88 | .PP The forms using \fB{\fR and \fB}\fR are known as \fIbound\fRs. The numbers \fIm\fR and \fIn\fR are unsigned decimal integers with permissible values from 0 to 255 inclusive. .PP An atom is one of: .RS 2 | < | | | < | < | < | < | < | < | | | < | < | < | | 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 | .PP The forms using \fB{\fR and \fB}\fR are known as \fIbound\fRs. The numbers \fIm\fR and \fIn\fR are unsigned decimal integers with permissible values from 0 to 255 inclusive. .PP An atom is one of: .RS 2 .IP \fB(\fIre\fB)\fR 6 matches a match for \fIre\fR (\fIre\fR is any regular expression) with the match noted for possible reporting .IP \fB(?:\fIre\fB)\fR as previous, but does no reporting (a ``non-capturing'' set of parentheses) .IP \fB()\fR matches an empty string, noted for possible reporting .IP \fB(?:)\fR matches an empty string, without reporting .IP \fB[\fIchars\fB]\fR a \fIbracket expression\fR, matching any one of the \fIchars\fR (see \fBBRACKET EXPRESSIONS\fR for more detail) .IP \fB.\fR matches any single character .IP \fB\e\fIk\fR matches the non-alphanumeric character \fIk\fR taken as an ordinary character, e.g. \fB\e\e\fR matches a backslash character .IP \fB\e\fIc\fR where \fIc\fR is alphanumeric (possibly followed by other characters), an \fIescape\fR (AREs only), see \fBESCAPES\fR below .IP \fB{\fR when followed by a character other than a digit, matches the left-brace character `\fB{\fR'; when followed by a digit, it is the beginning of a \fIbound\fR (see above) .IP \fIx\fR where \fIx\fR is a single character with no other significance, matches that character. .RE .PP A \fIconstraint\fR matches an empty string when specific conditions are met. A constraint may not be followed by a quantifier. The simple constraints are as follows; some more constraints are described |
︙ | ︙ | |||
650 651 652 653 654 655 656 | respectively; no other escapes are available. .SH "SEE ALSO" RegExp(3), regexp(n), regsub(n), lsearch(n), switch(n), text(n) .SH KEYWORDS match, regular expression, string | > > > > | 639 640 641 642 643 644 645 646 647 648 649 | respectively; no other escapes are available. .SH "SEE ALSO" RegExp(3), regexp(n), regsub(n), lsearch(n), switch(n), text(n) .SH KEYWORDS match, regular expression, string '\" Local Variables: '\" mode: nroff '\" End: |
Changes to doc/read.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: read.n,v 1.9.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH read n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME read \- Read from a channel |
︙ | ︙ | |||
28 29 30 31 32 33 34 | how many characters to read. Exactly that many characters will be read and returned, unless there are fewer than \fInumChars\fR left in the file; in this case all the remaining characters are returned. If the channel is configured to use a multi-byte encoding, then the number of characters read may not be the same as the number of bytes read. .PP | < < | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | how many characters to read. Exactly that many characters will be read and returned, unless there are fewer than \fInumChars\fR left in the file; in this case all the remaining characters are returned. If the channel is configured to use a multi-byte encoding, then the number of characters read may not be the same as the number of bytes read. .PP \fIChannelId\fR must be an identifier for an open channel such as the Tcl standard input channel (\fBstdin\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. The channel must have been opened for input. .PP If \fIchannelId\fR is in nonblocking mode, the command may not read as many characters as requested: once all available input has been read, the command will return the data that is available rather than blocking for more input. If the channel is configured to use a multi-byte encoding, then there may actually be some bytes remaining in the internal buffers that do not form a complete character. These |
︙ | ︙ |
Changes to doc/regexp.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: regexp.n,v 1.16.2.2 2005/05/05 17:55:27 kennykb Exp $ '\" .so man.macros .TH regexp n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME regexp \- Match a regular expression against a string |
︙ | ︙ | |||
79 80 81 82 83 84 85 | beginning and end of a line respectively. This is the same as specifying the \fB(?w)\fR embedded option (see the \fBre_syntax\fR manual page). .TP 15 \fB\-nocase\fR Causes upper-case characters in \fIstring\fR to be treated as lower case during the matching process. | < | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | beginning and end of a line respectively. This is the same as specifying the \fB(?w)\fR embedded option (see the \fBre_syntax\fR manual page). .TP 15 \fB\-nocase\fR Causes upper-case characters in \fIstring\fR to be treated as lower case during the matching process. .TP 15 \fB\-all\fR Causes the regular expression to be matched as many times as possible in the string, returning the total number of matches found. If this is specified with match variables, they will contain information for the last match only. .TP 15 |
︙ | ︙ | |||
104 105 106 107 108 109 110 | => {in n} regexp -all -inline -- {\\w(\\w)} " inlined " => {in n li i ne e} .CE .TP 15 \fB\-start\fR \fIindex\fR Specifies a character index offset into the string to start | | > > > > > < | 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 | => {in n} regexp -all -inline -- {\\w(\\w)} " inlined " => {in n li i ne e} .CE .TP 15 \fB\-start\fR \fIindex\fR Specifies a character index offset into the string to start matching the regular expression at. .VS 8.5 The \fIindex\fR value is interpreted in the same manner as the \fIindex\fR argument to \fBstring index\fR. .VE 8.5 When using this switch, `^' will not match the beginning of the line, and \\A will still match the start of the string at \fIindex\fR. If \fB\-indices\fR is specified, the indices will be indexed starting from the absolute beginning of the input string. \fIindex\fR will be constrained to the bounds of the input string. .TP 15 \fB\-\|\-\fR Marks the end of switches. The argument following this one will be treated as \fIexp\fR even if it starts with a \fB\-\fR. .PP If there are more \fIsubMatchVar\fR's than parenthesized subexpressions within \fIexp\fR, or if a particular subexpression |
︙ | ︙ | |||
151 152 153 154 155 156 157 | List all words (consisting of all sequences of non-whitespace characters) in a string: .CS \fBregexp\fR \-all \-inline {\\S+} $string .CE .SH "SEE ALSO" | | > > > > | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | List all words (consisting of all sequences of non-whitespace characters) in a string: .CS \fBregexp\fR \-all \-inline {\\S+} $string .CE .SH "SEE ALSO" re_syntax(n), regsub(n), .VS 8.5 string(n) .VE .SH KEYWORDS match, regular expression, string |
Changes to doc/registry.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2002 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2002 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: registry.n,v 1.12.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH registry n 1.1 registry "Tcl Bundled Packages" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME registry \- Manipulate the Windows registry |
︙ | ︙ | |||
36 37 38 39 40 41 42 | \fIrootname\fB\e\fIkeypath\fR .IP \fIrootname\fR .PP \fIHostname\fR specifies the name of any valid Windows host that exports its registry. The \fIrootname\fR component must be one of \fBHKEY_LOCAL_MACHINE\fR, \fBHKEY_USERS\fR, | < < < < | 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 | \fIrootname\fB\e\fIkeypath\fR .IP \fIrootname\fR .PP \fIHostname\fR specifies the name of any valid Windows host that exports its registry. The \fIrootname\fR component must be one of \fBHKEY_LOCAL_MACHINE\fR, \fBHKEY_USERS\fR, \fBHKEY_CLASSES_ROOT\fR, \fBHKEY_CURRENT_USER\fR, \fBHKEY_CURRENT_CONFIG\fR, \fBHKEY_PERFORMANCE_DATA\fR, or \fBHKEY_DYN_DATA\fR. The \fIkeypath\fR can be one or more registry key names separated by backslash (\fB\e\fR) characters. .PP \fIOption\fR indicates what to do with the registry key name. Any unique abbreviation for \fIoption\fR is acceptable. The valid options are: .TP \fBregistry broadcast \fIkeyName\fR ?\fI-timeout milliseconds\fR? . Sends a broadcast message to the system and running programs to notify them of certain updates. This is necessary to propagate changes to key registry keys like Environment. The timeout specifies the amount of time, in milliseconds, to wait for applications to respond to the broadcast message. It defaults to 3000. The following example demonstrates how to add a path to the global Environment and notify applications of the change without requiring a logoff/logon step (assumes admin privileges): .CS set regPath {HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment} set curPath [registry get $regPath "Path"] registry set $regPath "Path" "$curPath;$addPath" registry broadcast "Environment" .CE .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 |
︙ | ︙ |
Changes to doc/regsub.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: regsub.n,v 1.12.2.2 2005/05/05 17:55:28 kennykb Exp $ '\" .so man.macros .TH regsub n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME regsub \- Perform substitutions based on regular expression pattern matching .SH SYNOPSIS \fBregsub \fR?\fIswitches\fR? \fIexp string subSpec \fR?\fIvarName\fR? .BE .SH DESCRIPTION .PP This command matches the regular expression \fIexp\fR against \fIstring\fR, and either copies \fIstring\fR to the variable whose name is given by \fIvarName\fR or returns \fIstring\fR if \fIvarName\fR is not present. (Regular expression matching is described in the \fBre_syntax\fR reference page.) If there is a match, then while copying \fIstring\fR to \fIvarName\fR (or to the result of this command if \fIvarName\fR is not present) the portion of \fIstring\fR that matched \fIexp\fR is replaced with \fIsubSpec\fR. If \fIsubSpec\fR contains a ``&'' or ``\e0'', then it is replaced in the substitution with the portion of \fIstring\fR that matched \fIexp\fR. If \fIsubSpec\fR contains a ``\e\fIn\fR'', where \fIn\fR is a digit between 1 and 9, then it is replaced in the substitution with |
︙ | ︙ | |||
94 95 96 97 98 99 100 | \fB\-nocase\fR Upper-case characters in \fIstring\fR will be converted to lower-case before matching against \fIexp\fR; however, substitutions specified by \fIsubSpec\fR use the original unconverted form of \fIstring\fR. .TP 10 \fB\-start\fR \fIindex\fR Specifies a character index offset into the string to start | | > > > > > < < | 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 | \fB\-nocase\fR Upper-case characters in \fIstring\fR will be converted to lower-case before matching against \fIexp\fR; however, substitutions specified by \fIsubSpec\fR use the original unconverted form of \fIstring\fR. .TP 10 \fB\-start\fR \fIindex\fR Specifies a character index offset into the string to start matching the regular expression at. .VS 8.5 The \fIindex\fR value is interpreted in the same manner as the \fIindex\fR argument to \fBstring index\fR. .VE 8.5 When using this switch, `^' will not match the beginning of the line, and \\A will still match the start of the string at \fIindex\fR. \fIindex\fR will be constrained to the bounds of the input string. .TP 10 \fB\-\|\-\fR Marks the end of switches. The argument following this one will be treated as \fIexp\fR even if it starts with a \fB\-\fR. .PP If \fIvarName\fR is supplied, the command returns a count of the number of matching ranges that were found and replaced, otherwise the string after replacement is returned. See the manual entry for \fBregexp\fR for details on the interpretation of regular expressions. .SH EXAMPLES Replace (in the string in variable \fIstring\fR) every instance of \fBfoo\fR which is a word by itself with \fBbar\fR: .CS \fBregsub\fR -all {\e<foo\e>} $string bar string |
︙ | ︙ | |||
138 139 140 141 142 143 144 | # Now we apply the substitution to get a subst-string that # will perform the computational parts of the conversion. set quoted [subst [\fBregsub\fR -all $RE $string $substitution]] .CE .SH "SEE ALSO" | | > > > > | 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 | # Now we apply the substitution to get a subst-string that # will perform the computational parts of the conversion. set quoted [subst [\fBregsub\fR -all $RE $string $substitution]] .CE .SH "SEE ALSO" regexp(n), re_syntax(n), subst(n), .VS 8.5 string(n) .VE .SH KEYWORDS match, pattern, regular expression, substitute |
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.12.2.2 2005/10/08 13:44:37 dgp 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 |
︙ | ︙ | |||
39 40 41 42 43 44 45 | If the next character in \fIformat\fR is a blank or tab then it matches any number of white space characters in \fIstring\fR (including zero). Otherwise, if it isn't a \fB%\fR character then it must match the next character of \fIstring\fR. When a \fB%\fR is encountered in \fIformat\fR, it indicates the start of a conversion specifier. | < < | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | If the next character in \fIformat\fR is a blank or tab then it matches any number of white space characters in \fIstring\fR (including zero). Otherwise, if it isn't a \fB%\fR character then it must match the next character of \fIstring\fR. When a \fB%\fR is encountered in \fIformat\fR, it indicates the start of a conversion specifier. A conversion specifier contains up to four fields after the \fB%\fR: a \fB*\fR, which indicates that the converted value is to be discarded instead of assigned to a variable; a XPG3 position specifier; a number indicating a maximum field width; a field size modifier; and a conversion character. All of these fields are optional except for the conversion character. The fields that are present must appear in the order given above. .PP When \fBscan\fR finds a conversion specifier in \fIformat\fR, it first skips any white-space characters in \fIstring\fR (unless the specifier is \fB[\fR or \fBc\fR). Then it converts the next input characters according to the |
︙ | ︙ | |||
71 72 73 74 75 76 77 | at most once and the empty positions will be filled in with empty strings. .PP The following conversion characters are supported: .TP 10 \fBd\fR The input field must be a decimal integer. It is read in and the value is stored in the variable as a decimal string. | < < < < < < < < < < | 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 | at most once and the empty positions will be filled in with empty strings. .PP The following conversion characters are supported: .TP 10 \fBd\fR The input field must be a decimal integer. It is read in and the value is stored in the variable as a decimal string. If the \fBl\fR or \fBL\fR field size modifier is given, the scanned value will have an internal representation that is at least 64-bits in size. .TP 10 \fBo\fR The input field must be an octal integer. It is read in and the value is stored in the variable as a decimal string. If the \fBl\fR or \fBL\fR field size modifier is given, the scanned value will have an internal representation that is at least 64-bits in size. If the value exceeds MAX_INT (017777777777 on platforms using 32-bit integers when the \fBl\fR and \fBL\fR modifiers are not given), it will be truncated to a signed integer. Hence, 037777777777 will appear as -1 on a 32-bit machine by default. .TP 10 \fBx\fR The input field must be a hexadecimal integer. It is read in and the value is stored in the variable as a decimal string. If the \fBl\fR or \fBL\fR field size modifier is given, the scanned value will have an internal representation that is at least 64-bits in size. If the value exceeds MAX_INT (0x7FFFFFFF on platforms using 32-bit integers when the \fBl\fR and \fBL\fR modifiers are not given), it will be truncated to a signed integer. Hence, 0xFFFFFFFF will appear as -1 on a 32-bit machine. .TP 10 \fBu\fR The input field must be a decimal integer. The value is stored in the variable as an unsigned decimal integer string. If the \fBl\fR or \fBL\fR field size modifier is given, the scanned value will have an internal representation that is at least 64-bits in size. .TP 10 \fBi\fR The input field must be an integer. The base (i.e. decimal, octal, or hexadecimal) is determined in the same fashion as described in \fBexpr\fR. The value is stored in the variable as a decimal string. If the \fBl\fR or \fBL\fR field size modifier is given, the scanned value will have an internal representation that is at least 64-bits in size. .TP 10 \fBc\fR A single character is read in and its binary value is stored in the variable as a decimal string. Initial white space is not skipped in this case, so the input field may be a white-space character. This conversion is different from the ANSI standard in that the |
︙ | ︙ | |||
144 145 146 147 148 149 150 | of an optional sign, a string of decimal digits possibly containing a decimal point, and an optional exponent consisting of an \fBe\fR or \fBE\fR followed by an optional sign and a string of decimal digits. It is read in and stored in the variable as a floating-point string. .TP 10 \fB[\fIchars\fB]\fR | | < | < | 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 | of an optional sign, a string of decimal digits possibly containing a decimal point, and an optional exponent consisting of an \fBe\fR or \fBE\fR followed by an optional sign and a string of decimal digits. It is read in and stored in the variable as a floating-point string. .TP 10 \fB[\fIchars\fB]\fR The input field consists of one or more characters in \fIchars\fR. The matching string is stored in the variable. If the first character between the brackets is a \fB]\fR then it is treated as part of \fIchars\fR rather than the closing bracket for the set. If \fIchars\fR contains a sequence of the form \fIa\fB\-\fIb\fR then any character between \fIa\fR and \fIb\fR (inclusive) will match. 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 \fB[^\fIchars\fB]\fR The input field consists of one or more characters not in \fIchars\fR. The matching string is stored in the variable. If the character immediately following the \fB^\fR is a \fB]\fR then it is treated as part of the set rather than the closing bracket for the set. If \fIchars\fR contains a sequence of the form \fIa\fB\-\fIb\fR then any character between \fIa\fR and \fIb\fR (inclusive) will be excluded |
︙ | ︙ | |||
195 196 197 198 199 200 201 | \fB%p\fR conversion specifier is not currently supported. .IP [2] For \fB%c\fR conversions a single character value is converted to a decimal string, which is then assigned to the corresponding \fIvarName\fR; no field width may be specified for this conversion. .IP [3] | < < | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | \fB%p\fR conversion specifier is not currently supported. .IP [2] For \fB%c\fR conversions a single character value is converted to a decimal string, which is then assigned to the corresponding \fIvarName\fR; no field width may be specified for this conversion. .IP [3] The \fBh\fR modifier is always ignored and the \fBl\fR and \fBL\fR modifiers are ignored when converting real values (i.e. type \fBdouble\fR is used for the internal representation). .IP [4] If the end of the input string is reached before any conversions have been performed and no variables are given, an empty string is returned. .SH EXAMPLES Parse a simple color specification of the form \fI#RRGGBB\fR using hexadecimal conversions with field sizes: .CS |
︙ | ︙ |
Changes to doc/seek.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 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. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: seek.n,v 1.7.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH seek n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME seek \- Change the access position for an open channel .SH SYNOPSIS \fBseek \fIchannelId offset \fR?\fIorigin\fR? .BE .SH DESCRIPTION .PP Changes the current access position for \fIchannelId\fR. .PP \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. .PP The \fIoffset\fR and \fIorigin\fR arguments specify the position at which the next read or write will occur for \fIchannelId\fR. \fIOffset\fR must be an integer (which may be negative) and \fIorigin\fR must be one of the following: .TP 10 \fBstart\fR |
︙ | ︙ | |||
53 54 55 56 57 58 59 | The command flushes all buffered output for the channel before the command returns, even if the channel is in nonblocking mode. It also discards any buffered and unread input. This command returns an empty string. An error occurs if this command is applied to channels whose underlying file or device does not support seeking. .PP | < < | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | The command flushes all buffered output for the channel before the command returns, even if the channel is in nonblocking mode. It also discards any buffered and unread input. This command returns an empty string. An error occurs if this command is applied to channels whose underlying file or device does not support seeking. .PP Note that \fIoffset\fR values are byte offsets, not character offsets. Both \fBseek\fR and \fBtell\fR operate in terms of bytes, not characters, unlike \fBread\fR. .SH EXAMPLES Read a file twice: .CS set f [open file.txt] set data1 [read $f] \fBseek\fR $f 0 set data2 [read $f] |
︙ | ︙ |
Changes to doc/string.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: string.n,v 1.24.2.4 2005/07/12 20:36:16 kennykb 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 |
︙ | ︙ | |||
68 69 70 71 72 73 74 75 76 | 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 | > > | > | > | | > > > > > > > | > > > > > > > > | > | | 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 | 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: .VS 8.5 .RS .IP \fIinteger\fR 10 For any index value that passes \fBstring is integer -strict\fR, the char specified at this integral index (e.g. \fB2\fR would refer to the "c" in "abcd"). .IP \fBend\fR 10 The last char of the string (e.g. \fBend\fR would refer to the "d" in "abcd"). .IP \fBend\fR\-\fIN\fR 10 The last char of the string minus the specified integer offset \fIN\fR (e.g. \fBend\fR\-1 would refer to the "c" in "abcd"). .IP \fBend\fR+\fIN\fR 10 The last char of the string plus the specified integer offset \fIN\fR (e.g. \fBend\fR+\-1 would refer to the "c" in "abcd"). .IP \fIM\fR+\fIN\fR 10 The char specified at the integral index that is the sum of integer values \fIM\fR and \fIN\fR (e.g. \fB1+1\fR would refer to the "c" in "abcd"). .IP \fIM\fR\-\fIN\fR 10 The char specified at the integral index that is the difference of integer values \fIM\fR and \fIN\fR (e.g. \fB2\-1\fR would refer to the "b" in "abcd"). .PP In the specifications above, the integer value \fIM\fR contains no trailing whitespace and the integer value \fIN\fR contains no leading whitespace. .PP If \fIcharIndex\fR is less than 0 or greater than or equal to the length of the string then this command returns an empty string. .RE .VE .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 an empty string will return 1 on any class. If \fB\-failindex\fR is specified, then if the function returns 0, the index in the string where the class was no longer valid will be stored in the variable named \fIvarname\fR. The \fIvarname\fR will not be set if the function returns 1. The following character classes are recognized (the class name can be abbreviated): .RS .IP \fBalnum\fR 12 |
︙ | ︙ | |||
282 283 284 285 286 287 288 | 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 | | | | | 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 | 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 present in the string 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 present in the string 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 present in the string 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 |
︙ | ︙ | |||
330 331 332 333 334 335 336 | .CE .SH "SEE ALSO" expr(n), list(n) .SH KEYWORDS case conversion, compare, index, match, pattern, string, word, equal, ctype | > > > > | 350 351 352 353 354 355 356 357 358 359 360 | .CE .SH "SEE ALSO" expr(n), list(n) .SH KEYWORDS case conversion, compare, index, match, pattern, string, word, equal, ctype '\" Local Variables: '\" mode: nroff '\" End: |
Changes to doc/subst.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: subst.n,v 1.6.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH subst n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME subst \- Perform backslash, command, and variable substitutions |
︙ | ︙ | |||
32 33 34 35 36 37 38 | If any of the \fB\-nobackslashes\fR, \fB\-nocommands\fR, or \fB\-novariables\fR are specified, then the corresponding substitutions are not performed. For example, if \fB\-nocommands\fR is specified, command substitution is not performed: open and close brackets are treated as ordinary characters with no special interpretation. .PP | < | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | If any of the \fB\-nobackslashes\fR, \fB\-nocommands\fR, or \fB\-novariables\fR are specified, then the corresponding substitutions are not performed. For example, if \fB\-nocommands\fR is specified, command substitution is not performed: open and close brackets are treated as ordinary characters with no special interpretation. .PP Note that the substitution of one kind can include substitution of other kinds. For example, even when the \fB-novariables\fR option is specified, command substitution is performed without restriction. This means that any variable substitution necessary to complete the command substitution will still take place. Likewise, any command substitution necessary to complete a variable substitution will take place, even when \fB-nocommands\fR is specified. See the |
︙ | ︙ | |||
55 56 57 58 59 60 61 | will be substituted for that entire command or variable substitution (as long as it is well-formed Tcl.) If a return exception occurs, or any other return code is returned during command or variable substitution, then the returned value is substituted for that substitution. See the EXAMPLES below. In this way, all exceptional return codes are ``caught'' by \fBsubst\fR. The \fBsubst\fR command itself will either return an error, or will complete successfully. | < < | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | will be substituted for that entire command or variable substitution (as long as it is well-formed Tcl.) If a return exception occurs, or any other return code is returned during command or variable substitution, then the returned value is substituted for that substitution. See the EXAMPLES below. In this way, all exceptional return codes are ``caught'' by \fBsubst\fR. The \fBsubst\fR command itself will either return an error, or will complete successfully. .SH EXAMPLES .PP When it performs its substitutions, \fIsubst\fR does not give any special treatment to double quotes or curly braces (except within command substitutions) so the script .CS set a 44 \fBsubst\fR {xyz {$a}} .CE returns ``\fBxyz {44}\fR'', not ``\fBxyz {$a}\fR'' and the script .CS set a "p\\} q \\{r" \fBsubst\fR {xyz {$a}} .CE return ``\fBxyz {p} q {r}\fR'', not ``\fBxyz {p\\} q \\{r}\fR''. .PP |
︙ | ︙ | |||
112 113 114 115 116 117 118 | \fBsubst\fR {abc,[return foo;expr 1+2],def} .CE returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR'' and .CS \fBsubst\fR {abc,[return -code 10 foo;expr 1+2],def} .CE also returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR''. | < | 109 110 111 112 113 114 115 116 117 118 119 120 121 | \fBsubst\fR {abc,[return foo;expr 1+2],def} .CE returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR'' and .CS \fBsubst\fR {abc,[return -code 10 foo;expr 1+2],def} .CE also returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR''. .SH "SEE ALSO" Tcl(n), eval(n), break(n), continue(n) .SH KEYWORDS backslash substitution, command substitution, variable substitution |
Changes to doc/switch.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: switch.n,v 1.8.2.1 2005/07/12 20:36:16 kennykb Exp $ '\" .so man.macros .TH switch n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME switch \- Evaluate one of several scripts, depending on a given value .SH SYNOPSIS \fBswitch \fR?\fIoptions\fR?\fI string pattern body \fR?\fIpattern body \fR...? .sp |
︙ | ︙ | |||
47 48 49 50 51 52 53 54 55 56 57 58 59 60 | \fB\-regexp\fR When matching \fIstring\fR to the patterns, use regular expression matching (as described in the \fBre_syntax\fR reference page). '\" Options defined by TIP#75 .VS 8.5 .TP 10 \fB\-matchvar\fR \fIvarName\fR This option (only legal when \fB\-regexp\fR is also specified) specifies the name of a variable into which the list of matches found by the regular expression engine will be written. The first element of the list written will be the overall substring of the input string (i.e. the \fIstring\fR argument to \fBswitch\fR) matched, the second element of the list will be the substring matched by the first | > > > | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | \fB\-regexp\fR When matching \fIstring\fR to the patterns, use regular expression matching (as described in the \fBre_syntax\fR reference page). '\" Options defined by TIP#75 .VS 8.5 .TP 10 \fB\-nocase\fR Causes comparisons to be handled in a case-insensitive manner. .TP 10 \fB\-matchvar\fR \fIvarName\fR This option (only legal when \fB\-regexp\fR is also specified) specifies the name of a variable into which the list of matches found by the regular expression engine will be written. The first element of the list written will be the overall substring of the input string (i.e. the \fIstring\fR argument to \fBswitch\fR) matched, the second element of the list will be the substring matched by the first |
︙ | ︙ |
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.20.2.3 2005/10/08 13:44:37 dgp Exp $ '\" .so man.macros .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tclvars \- Variables used by Tcl |
︙ | ︙ | |||
33 34 35 36 37 38 39 | environment variable. Changes to the \fBenv\fR array will affect the environment passed to children by commands like \fBexec\fR. If the entire \fBenv\fR array is unset then Tcl will stop monitoring \fBenv\fR accesses and will not update environment variables. .RS | < < | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | environment variable. Changes to the \fBenv\fR array will affect the environment passed to children by commands like \fBexec\fR. If the entire \fBenv\fR array is unset then Tcl will stop monitoring \fBenv\fR accesses and will not update environment variables. .RS Under Windows, the environment variables PATH and COMSPEC in any 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. .RE .TP \fBerrorCode\fR This variable holds the value of the \fB-errorcode\fR return option set by the most recent error that occurred in this interpreter. This list value represents additional information about the error in a form that is easy to process with programs. |
︙ | ︙ | |||
159 160 161 162 163 164 165 | \fBtcl_patchLevel\fR When an interpreter is created Tcl initializes this variable to hold a string giving the current patch level for Tcl, such as \fB7.3p2\fR for Tcl 7.3 with the first two official patches, or \fB7.4b4\fR for the fourth beta release of Tcl 7.4. The value of this variable is returned by the \fBinfo patchlevel\fR command. | < | < < < | 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 | \fBtcl_patchLevel\fR When an interpreter is created Tcl initializes this variable to hold a string giving the current patch level for Tcl, such as \fB7.3p2\fR for Tcl 7.3 with the first two official patches, or \fB7.4b4\fR for the fourth beta release of Tcl 7.4. The value of this variable is returned by the \fBinfo patchlevel\fR command. .TP \fBtcl_pkgPath\fR This variable holds a list of directories indicating where packages are normally installed. It is not used on Windows. It typically contains either one or two entries; if it contains two entries, the first is normally a directory for platform-dependent packages (e.g., shared library binaries) and the second is normally a directory for platform-independent packages (e.g., script files). Typically a package is installed as a subdirectory of one of the entries in \fB$tcl_pkgPath\fR. The directories in \fB$tcl_pkgPath\fR are included by default in the \fBauto_path\fR variable, so they and their immediate subdirectories are automatically searched for packages during \fBpackage require\fR commands. Note: \fBtcl_pkgPath\fR is not intended to be modified by the application. Its value is added to \fBauto_path\fR at startup; changes to \fBtcl_pkgPath\fR are not reflected in \fBauto_path\fR. If you want Tcl to search additional directories for packages you should add the names of those directories to \fBauto_path\fR, not \fBtcl_pkgPath\fR. .TP \fBtcl_platform\fR This is an associative array whose elements contain information about the platform on which the application is running, such as the name of the operating system, its current release number, and the machine's instruction set. The elements listed below will always be defined, but they may have empty strings as values if Tcl couldn't retrieve any relevant information. In addition, extensions and applications may add additional values to the array. The predefined elements are: .RS .TP \fBbyteOrder\fR The native byte order of this machine: either \fBlittleEndian\fR or \fBbigEndian\fR. .TP \fBdebug\fR If this variable exists, then the interpreter was compiled with and linked to a debug-enabled C run-time. This variable will only exist on Windows, so extension writers can specify which package to load depending on the C run-time library that is in use. This is not an indication that this core contains symbols. |
︙ | ︙ | |||
237 238 239 240 241 242 243 | \fBuser\fR This identifies the current user based on the login information available on the platform. This comes from the USER or LOGNAME environment variable on Unix, and the value from GetUserName on Windows. .TP \fBwordSize\fR | < < < > > > | > > > > > > > > > > < | 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 | \fBuser\fR This identifies the current user based on the login information available on the platform. This comes from the USER or LOGNAME environment variable on Unix, and the value from GetUserName on Windows. .TP \fBwordSize\fR This gives the size of the native-machine word in bytes (strictly, it is same as the result of evaluating \fIsizeof(long)\fR in C.) .RE .TP \fBtcl_precision\fR This variable controls the number of digits to generate when converting floating-point values to strings. It defaults .VS 8.5 to 0. \fIApplications should not change this value;\fR it is provided for compatibility with legacy code. .PP The default value of 0 is special, meaning that Tcl should convert numbers using as few digits as possible while still distinguishing any floating point number from its nearest neighbours. It differs from using an arbitrarily high value for \fItcl_precision\fR in that an inexact number like \fI1.4\fR will convert as \fI1.4\fR rather than \fI1.3999999999999999\fR even though the latter is nearer to the exact value of the binary number. .VE 8.5 .PP 17 digits is ``perfect'' for IEEE floating-point in that it allows double-precision values to be converted to strings and back to binary with no loss of information. However, using 17 digits prevents any rounding, which produces longer, less intuitive results. For example, \fBexpr 1.4\fR returns 1.3999999999999999 with \fBtcl_precision\fR set to 17, vs. 1.4 if \fBtcl_precision\fR is 12. .RS All interpreters in a process share a single \fBtcl_precision\fR value: changing it in one interpreter will affect all other interpreters as well. However, safe interpreters are not allowed to modify the variable. .RE .TP \fBtcl_rcFileName\fR This variable is used during initialization to indicate the name of a user-specific startup file. If it is set by application-specific initialization, then the Tcl startup code will check for the existence of this file and \fBsource\fR it if it exists. For example, for \fBwish\fR the variable is set to \fB~/.wishrc\fR for Unix and \fB~/wishrc.tcl\fR |
︙ | ︙ |
Changes to doc/tell.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: tell.n,v 1.7.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH tell n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tell \- Return current access position for an open channel .SH SYNOPSIS \fBtell \fIchannelId\fR .BE .SH DESCRIPTION .PP Returns an integer string giving the current access position in \fIchannelId\fR. This value returned is a byte offset that can be passed to \fBseek\fR in order to set the channel to a particular position. Note that this value is in terms of bytes, not characters like \fBread\fR. The value returned is -1 for channels that do not support seeking. .PP \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. .SH EXAMPLE Read a line from a file channel only if it starts with \fBfoobar\fR: .CS # Save the offset in case we need to undo the read... set offset [\fBtell\fR $chan] if {[read $chan 6] eq "foobar"} { gets $chan line |
︙ | ︙ |
Changes to doc/unload.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2003 George Petasis, [email protected]. '\" '\" See the file "license.terms" for information on usage and redistribution '\" 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) 2003 George Petasis, [email protected]. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: unload.n,v 1.6.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH unload n 8.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME unload \- Unload machine code |
︙ | ︙ | |||
112 113 114 115 116 117 118 | .PP If \fIpackageName\fR is omitted or specified as an empty string, Tcl tries to guess the name of the package. This may be done differently on different platforms. The default guess, which is used on most UNIX platforms, is to take the last element of \fIfileName\fR, strip off the first three characters if they are \fBlib\fR, and use any following | < < | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | .PP If \fIpackageName\fR is omitted or specified as an empty string, Tcl tries to guess the name of the package. This may be done differently on different platforms. The default guess, which is used on most UNIX platforms, is to take the last element of \fIfileName\fR, strip off the first three characters if they are \fBlib\fR, and use any following alphabetic and underline characters as the module name. For example, the command \fBunload libxyz4.2.so\fR uses the module name \fBxyz\fR and the command \fBunload bin/last.so {}\fR uses the module name \fBlast\fR. .SH "PORTABILITY ISSUES" .TP \fBUnix\fR\0\0\0\0\0 . |
︙ | ︙ |
Changes to doc/unset.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: unset.n,v 1.8.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH unset n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME unset \- Delete variables |
︙ | ︙ | |||
24 25 26 27 28 29 30 | Each \fIname\fR is a variable name, specified in any of the ways acceptable to the \fBset\fR command. If a \fIname\fR refers to an element of an array then that element is removed without affecting the rest of the array. If a \fIname\fR consists of an array name with no parenthesized index, then the entire array is deleted. The \fBunset\fR command returns an empty string as result. | < < | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | Each \fIname\fR is a variable name, specified in any of the ways acceptable to the \fBset\fR command. If a \fIname\fR refers to an element of an array then that element is removed without affecting the rest of the array. If a \fIname\fR consists of an array name with no parenthesized index, then the entire array is deleted. The \fBunset\fR command returns an empty string as result. If \fI\-nocomplain\fR is specified as the first argument, any possible errors are suppressed. The option may not be abbreviated, in order to disambiguate it from possible variable names. The option \fI\-\-\fR indicates the end of the options, and should be used if you wish to remove a variable with the same name as any of the options. If an error occurs, any variables after the named one causing the error not deleted. An error can occur when the named variable doesn't exist, or the name refers to an array element but the variable is a scalar, or the name refers to a variable in a non-existent namespace. .SH EXAMPLE Create an array containing a mapping from some numbers to their squares and remove the array elements for non-prime numbers: |
︙ | ︙ |
Changes to doc/upvar.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: upvar.n,v 1.10.2.1 2005/04/10 23:14:44 kennykb Exp $ '\" .so man.macros .TH upvar n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME upvar \- Create link to variable in a different stack frame |
︙ | ︙ | |||
64 65 66 67 68 69 70 | counts as another call level for \fBuplevel\fR and \fBupvar\fR commands. For example, \fBinfo level 1\fR will return a list describing a command that is either the outermost procedure call or the outermost \fBnamespace eval\fR command. Also, \fBuplevel #0\fR evaluates a script at top-level in the outermost namespace (the global namespace). .PP | < | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | counts as another call level for \fBuplevel\fR and \fBupvar\fR commands. For example, \fBinfo level 1\fR will return a list describing a command that is either the outermost procedure call or the outermost \fBnamespace eval\fR command. Also, \fBuplevel #0\fR evaluates a script at top-level in the outermost namespace (the global namespace). .PP If an upvar variable is unset (e.g. \fBx\fR in \fBadd2\fR above), the \fBunset\fR operation affects the variable it is linked to, not the upvar variable. There is no way to unset an upvar variable except by exiting the procedure in which it is defined. However, it is possible to retarget an upvar variable by executing another \fBupvar\fR command. .SH "TRACES AND UPVAR" |
︙ | ︙ | |||
97 98 99 100 101 102 103 | .CE .PP If \fIotherVar\fR refers to an element of an array, then variable traces set for the entire array will not be invoked when \fImyVar\fR is accessed (but traces on the particular element will still be invoked). In particular, if the array is \fBenv\fR, then changes made to \fImyVar\fR will not be passed to subprocesses correctly. | < | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | .CE .PP If \fIotherVar\fR refers to an element of an array, then variable traces set for the entire array will not be invoked when \fImyVar\fR is accessed (but traces on the particular element will still be invoked). In particular, if the array is \fBenv\fR, then changes made to \fImyVar\fR will not be passed to subprocesses correctly. .SH EXAMPLE A \fBdecr\fR command that works like \fBincr\fR except it subtracts the value from the variable instead of adding it: .CS proc decr {varName {decrement 1}} { \fBupvar\fR 1 $varName var incr var [expr {-$decrement}] |
︙ | ︙ |
Changes to doc/variable.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: variable.n,v 1.6.2.1 2005/03/02 21:25:20 kennykb Exp $ '\" .so man.macros .TH variable n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME variable \- create and initialize a namespace variable |
︙ | ︙ | |||
39 40 41 42 43 44 45 | the variable is created in the specified namespace. If the variable is not defined, it will be visible to the \fBnamespace which\fR command, but not to the \fBinfo exists\fR command. .PP If the \fBvariable\fR command is executed inside a Tcl procedure, it creates local variables linked to the corresponding namespace variables (and therefore these | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | the variable is created in the specified namespace. If the variable is not defined, it will be visible to the \fBnamespace which\fR command, but not to the \fBinfo exists\fR command. .PP If the \fBvariable\fR command is executed inside a Tcl procedure, it creates local variables linked to the corresponding namespace variables (and therefore these variables are listed by \fBinfo vars\fR.) In this way the \fBvariable\fR command resembles the \fBglobal\fR command, although the \fBglobal\fR command only links to variables in the global namespace. If any \fIvalue\fRs are given, they are used to modify the values of the associated namespace variables. If a namespace variable does not exist, it is created and optionally initialized. |
︙ | ︙ |
Changes to generic/tcl.decls.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # tcl.decls -- # # This file contains the declarations for all supported public # functions that are exported by the Tcl library via the stubs table. # This file is used to generate the tclDecls.h, tclPlatDecls.h, # tclStub.c, and tclPlatStub.c files. # # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # tcl.decls -- # # This file contains the declarations for all supported public # functions that are exported by the Tcl library via the stubs table. # This file is used to generate the tclDecls.h, tclPlatDecls.h, # tclStub.c, and tclPlatStub.c files. # # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: tcl.decls,v 1.105.2.9 2005/09/20 14:11:51 dgp Exp $ library tcl # Define the tcl interface with several sub interfaces: # tclPlat - platform specific public # tclInt - generic private # tclPlatInt - platform specific private |
︙ | ︙ | |||
132 133 134 135 136 137 138 | declare 29 generic { Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr) } declare 30 generic { void TclFreeObj(Tcl_Obj *objPtr) } declare 31 generic { | | | | | 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 29 generic { Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr) } declare 30 generic { void TclFreeObj(Tcl_Obj *objPtr) } declare 31 generic { int Tcl_GetBoolean(Tcl_Interp *interp, CONST char *src, int *boolPtr) } declare 32 generic { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr) } declare 33 generic { unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr) } declare 34 generic { int Tcl_GetDouble(Tcl_Interp *interp, CONST char *src, double *doublePtr) } declare 35 generic { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } declare 36 generic { int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char **tablePtr, CONST char *msg, int flags, int *indexPtr) } declare 37 generic { int Tcl_GetInt(Tcl_Interp *interp, CONST char *src, int *intPtr) } declare 38 generic { int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr) } declare 39 generic { int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr) } |
︙ | ︙ | |||
257 258 259 260 261 262 263 | void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message, int length) } declare 68 generic { void Tcl_AllowExceptions(Tcl_Interp *interp) } declare 69 generic { | | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 | void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message, int length) } declare 68 generic { void Tcl_AllowExceptions(Tcl_Interp *interp) } declare 69 generic { void Tcl_AppendElement(Tcl_Interp *interp, CONST char *element) } declare 70 generic { void Tcl_AppendResult(Tcl_Interp *interp, ...) } declare 71 generic { Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc, ClientData clientData) |
︙ | ︙ | |||
427 428 429 430 431 432 433 | declare 115 generic { int Tcl_DoOneEvent(int flags) } declare 116 generic { void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData) } declare 117 generic { | | | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 | declare 115 generic { int Tcl_DoOneEvent(int flags) } declare 116 generic { void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData) } declare 117 generic { char * Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *bytes, int length) } declare 118 generic { char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, CONST char *element) } declare 119 generic { void Tcl_DStringEndSublist(Tcl_DString *dsPtr) } declare 120 generic { void Tcl_DStringFree(Tcl_DString *dsPtr) } |
︙ | ︙ | |||
463 464 465 466 467 468 469 | declare 127 generic { CONST84_RETURN char * Tcl_ErrnoId(void) } declare 128 generic { CONST84_RETURN char * Tcl_ErrnoMsg(int err) } declare 129 generic { | | | | | | | 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 | 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 *script) } # 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) } declare 132 generic { void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc) } declare 133 generic { void Tcl_Exit(int status) } declare 134 generic { int Tcl_ExposeCommand(Tcl_Interp *interp, CONST char *hiddenCmdToken, CONST char *cmdName) } declare 135 generic { int Tcl_ExprBoolean(Tcl_Interp *interp, CONST char *expr, int *ptr) } declare 136 generic { int Tcl_ExprBooleanObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr) } declare 137 generic { int Tcl_ExprDouble(Tcl_Interp *interp, CONST char *expr, double *ptr) } declare 138 generic { int Tcl_ExprDoubleObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr) } declare 139 generic { int Tcl_ExprLong(Tcl_Interp *interp, CONST char *expr, long *ptr) } declare 140 generic { int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr) } declare 141 generic { int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr) } declare 142 generic { int Tcl_ExprString(Tcl_Interp *interp, CONST char *expr) } declare 143 generic { void Tcl_Finalize(void) } declare 144 generic { void Tcl_FindExecutable(CONST char *argv0) } |
︙ | ︙ | |||
595 596 597 598 599 600 601 | Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp) } # Tcl_GetOpenFile is only available on unix, but it is a part of the old # generic interface, so we inlcude it here for compatibility reasons. declare 167 unix { | | | 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 | Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp) } # Tcl_GetOpenFile is only available on unix, but it is a part of the old # generic interface, so we inlcude it here for compatibility reasons. declare 167 unix { int Tcl_GetOpenFile(Tcl_Interp *interp, CONST char *chanID, int forWriting, int checkUsage, ClientData *filePtr) } # Obsolete. Should now use Tcl_FSGetPathType which is objectified # and therefore usually faster. declare 168 generic { Tcl_PathType Tcl_GetPathType(CONST char *path) } |
︙ | ︙ | |||
723 724 725 726 727 728 729 | declare 201 generic { void Tcl_Preserve(ClientData data) } declare 202 generic { void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst) } declare 203 generic { | | | 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 | declare 201 generic { void Tcl_Preserve(ClientData data) } declare 202 generic { void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst) } declare 203 generic { int Tcl_PutEnv(CONST char *assignment) } declare 204 generic { CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp) } declare 205 generic { void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position) } |
︙ | ︙ | |||
750 751 752 753 754 755 756 | declare 210 generic { void Tcl_RegisterChannel(Tcl_Interp *interp, Tcl_Channel chan) } declare 211 generic { void Tcl_RegisterObjType(Tcl_ObjType *typePtr) } declare 212 generic { | | | | | 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 | declare 210 generic { void Tcl_RegisterChannel(Tcl_Interp *interp, Tcl_Channel chan) } declare 211 generic { void Tcl_RegisterObjType(Tcl_ObjType *typePtr) } declare 212 generic { Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, CONST char *pattern) } declare 213 generic { int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, CONST char *text, CONST char *start) } declare 214 generic { int Tcl_RegExpMatch(Tcl_Interp *interp, CONST char *text, CONST char *pattern) } declare 215 generic { void Tcl_RegExpRange(Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr) } declare 216 generic { |
︙ | ︙ | |||
817 818 819 820 821 822 823 | declare 230 generic { void Tcl_SetPanicProc(Tcl_PanicProc *panicProc) } declare 231 generic { int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth) } declare 232 generic { | | | 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 | declare 230 generic { void Tcl_SetPanicProc(Tcl_PanicProc *panicProc) } declare 231 generic { int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth) } declare 232 generic { void Tcl_SetResult(Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc) } declare 233 generic { int Tcl_SetServiceMode(int mode) } declare 234 generic { void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr) |
︙ | ︙ | |||
952 953 954 955 956 957 958 | 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 { | | | 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 | 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 *start, 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 { |
︙ | ︙ | |||
1116 1117 1118 1119 1120 1121 1122 | void Tcl_ConditionNotify(Tcl_Condition *condPtr) } declare 311 generic { void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, Tcl_Time *timePtr) } declare 312 generic { | | | 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 | void Tcl_ConditionNotify(Tcl_Condition *condPtr) } declare 311 generic { void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, Tcl_Time *timePtr) } declare 312 generic { int Tcl_NumUtfChars(CONST char *src, int length) } declare 313 generic { int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag) } declare 314 generic { void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) |
︙ | ︙ | |||
1161 1162 1163 1164 1165 1166 1167 | 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 { | | | 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 | 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 length) } 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) } |
︙ | ︙ | |||
1243 1244 1245 1246 1247 1248 1249 | declare 350 generic { int Tcl_UniCharIsUpper(int ch) } declare 351 generic { int Tcl_UniCharIsWordChar(int ch) } declare 352 generic { | | | | | | | | | | | | | 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 | declare 350 generic { int Tcl_UniCharIsUpper(int ch) } declare 351 generic { int Tcl_UniCharIsWordChar(int ch) } declare 352 generic { int Tcl_UniCharLen(CONST Tcl_UniChar *uniStr) } declare 353 generic { int Tcl_UniCharNcmp(CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct, unsigned long numChars) } declare 354 generic { char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr) } declare 355 generic { Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *src, int length, Tcl_DString *dsPtr) } declare 356 generic { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) } declare 357 generic { Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count) } declare 358 generic { 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 *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr) } declare 361 generic { int Tcl_ParseCommand(Tcl_Interp *interp, CONST char *start, int numBytes, int nested, Tcl_Parse *parsePtr) } declare 362 generic { int Tcl_ParseExpr(Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr) } declare 363 generic { int Tcl_ParseQuotedString(Tcl_Interp *interp, CONST char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr) } declare 364 generic { int Tcl_ParseVarName(Tcl_Interp *interp, CONST char *start, 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) } |
︙ | ︙ | |||
1331 1332 1333 1334 1335 1336 1337 | int Tcl_UniCharIsPrint(int ch) } declare 375 generic { int Tcl_UniCharIsPunct(int ch) } declare 376 generic { int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, | | | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 | int Tcl_UniCharIsPrint(int ch) } declare 375 generic { int Tcl_UniCharIsPunct(int ch) } declare 376 generic { int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags) } declare 377 generic { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } declare 378 generic { Tcl_Obj * Tcl_NewUnicodeObj(CONST Tcl_UniChar *unicode, int numChars) } |
︙ | ︙ | |||
1360 1361 1362 1363 1364 1365 1366 | Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) } declare 384 generic { void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int length) } declare 385 generic { | | | 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 | Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) } declare 384 generic { void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int length) } declare 385 generic { int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj) } declare 386 generic { void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr) } declare 387 generic { Tcl_Mutex * Tcl_GetAllocMutex(void) |
︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 | void Tcl_ClearChannelHandlers(Tcl_Channel channel) } declare 418 generic { int Tcl_IsChannelExisting(CONST char* channelName) } declare 419 generic { | | | | | | 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 | void Tcl_ClearChannelHandlers(Tcl_Channel channel) } declare 418 generic { int Tcl_IsChannelExisting(CONST char* channelName) } declare 419 generic { int Tcl_UniCharNcasecmp(CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct, unsigned long numChars) } declare 420 generic { int Tcl_UniCharCaseMatch(CONST Tcl_UniChar *uniStr, CONST Tcl_UniChar *uniPattern, int nocase) } declare 421 generic { Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, CONST char *key) } declare 422 generic { |
︙ | ︙ | |||
1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 | # TIP#227 API declare 538 generic { int Tcl_SetReturnOptions(Tcl_Interp *interp, Tcl_Obj *options) } declare 539 generic { Tcl_Obj *Tcl_GetReturnOptions(Tcl_Interp *interp, int result) } ############################################################################## # Define the platform specific public Tcl interface. These functions are # only available on the designated platform. interface tclPlat | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # TIP#227 API declare 538 generic { int Tcl_SetReturnOptions(Tcl_Interp *interp, Tcl_Obj *options) } declare 539 generic { Tcl_Obj *Tcl_GetReturnOptions(Tcl_Interp *interp, int result) } # TIP#235 declare 540 generic { int Tcl_IsEnsemble(Tcl_Command token) } declare 541 generic { Tcl_Command Tcl_CreateEnsemble(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *namespacePtr, int flags) } declare 542 generic { Tcl_Command Tcl_FindEnsemble(Tcl_Interp *interp, Tcl_Obj *cmdNameObj, int flags) } declare 543 generic { int Tcl_SetEnsembleSubcommandList(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *subcmdList) } declare 544 generic { int Tcl_SetEnsembleMappingDict(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *mapDict) } declare 545 generic { int Tcl_SetEnsembleUnknownHandler(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *unknownList) } declare 546 generic { int Tcl_SetEnsembleFlags(Tcl_Interp *interp, Tcl_Command token, int flags) } declare 547 generic { int Tcl_GetEnsembleSubcommandList(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **subcmdListPtr) } declare 548 generic { int Tcl_GetEnsembleMappingDict(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **mapDictPtr) } declare 549 generic { int Tcl_GetEnsembleUnknownHandler(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **unknownListPtr) } declare 550 generic { int Tcl_GetEnsembleFlags(Tcl_Interp *interp, Tcl_Command token, int *flagsPtr) } declare 551 generic { int Tcl_GetEnsembleNamespace(Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr) } # TIP#233 (Virtualized Time) declare 552 generic { void Tcl_SetTimeProc (Tcl_GetTimeProc* getProc, Tcl_ScaleTimeProc* scaleProc, ClientData clientData) } declare 553 generic { void Tcl_QueryTimeProc (Tcl_GetTimeProc** getProc, Tcl_ScaleTimeProc** scaleProc, ClientData* clientData) } # TIP#218 (Driver Thread Actions) davygrvy/akupries ChannelType ver 4 declare 554 generic { Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc(Tcl_ChannelType *chanTypePtr) } # TIP #237: declare 555 generic { Tcl_Obj* Tcl_NewBignumObj( mp_int* value ) } declare 556 generic { Tcl_Obj* Tcl_DbNewBignumObj( mp_int* value, CONST char* file, int line ) } declare 557 generic { void Tcl_SetBignumObj( Tcl_Obj* obj, mp_int* value ) } declare 558 generic { int Tcl_GetBignumFromObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value ) } declare 559 generic { int Tcl_GetBignumAndClearObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value ) } # TIP #208: declare 560 generic { int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length) } declare 561 generic { Tcl_DriverTruncateProc *Tcl_ChannelTruncateProc( Tcl_ChannelType *chanTypePtr) } # TIP#219 (Tcl Channel Reflection API) akupries declare 562 generic { void Tcl_SetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj* msg) } declare 563 generic { void Tcl_GetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj** msg) } declare 564 generic { void Tcl_SetChannelError (Tcl_Channel chan, Tcl_Obj* msg) } declare 565 generic { void Tcl_GetChannelError (Tcl_Channel chan, Tcl_Obj** msg) } ############################################################################## # Define the platform specific public Tcl interface. These functions are # only available on the designated platform. interface tclPlat |
︙ | ︙ |
Changes to generic/tcl.h.
1 2 3 | /* * tcl.h -- * | | | | | | > > > > > > > > | | > | | | | > > | | | | | | | | | | | | | | | | > | > | < < | | < > > | | > | | | < < < < < < | | | | | | | | | | | | | > < | | > | 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 | /* * tcl.h -- * * This header file describes the externally-visible facilities of the * Tcl interpreter. * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1993-1996 Lucent Technologies. * 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.191.2.11 2005/09/27 18:42:54 dgp Exp $ */ #ifndef _TCL #define _TCL /* * For C++ compilers, use extern "C" */ #ifdef __cplusplus extern "C" { #endif /* * The following defines are used to indicate the various release levels. */ #define TCL_ALPHA_RELEASE 0 #define TCL_BETA_RELEASE 1 #define TCL_FINAL_RELEASE 2 /* * When version numbers change here, must also go into the following files and * update the version numbers: * * library/init.tcl (only if Major.minor changes, not patchlevel) 1 LOC * unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch) * win/configure.in (as above) * win/tcl.m4 (not patchlevel) * win/makefile.bc (not patchlevel) 2 LOC * README (sections 0 and 2, with and without separator) * macosx/Tcl.pbproj/project.pbxproj (not patchlevel) 2 LOC * win/README.binary (sections 0-4, with and without separator) * 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 5 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE #define TCL_RELEASE_SERIAL 4 #define TCL_VERSION "8.5" #define TCL_PATCH_LEVEL "8.5a4" /* * 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(__MINGW32__) || defined(__BORLANDC__) || (defined(__WATCOMC__) && defined(__WINDOWS_386__)) # define __WIN32__ # ifndef WIN32 # define WIN32 # endif # ifndef _WIN32 # define _WIN32 # endif # endif #endif /* * STRICT: See MSDN Article Q83456 */ #ifdef __WIN32__ # ifndef STRICT # define STRICT # endif #endif /* __WIN32__ */ /* * 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 windows RC tool. * * Resource compilers don't like all the C stuff, like typedefs and function * declarations, that occur below, so block them out. */ #ifndef RC_INVOKED /* * 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; #else #define TCL_DECLARE_MUTEX(name) #endif /* * Macros that eliminate the overhead of the thread synchronization functions * when compiling without thread support. */ #ifndef TCL_THREADS #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 */ /* * Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and * SEEK_END, all #define'd by stdio.h . * * Also, many extensions need stdio.h, and they've grown accustomed to tcl.h * providing it for them rather than #include-ing it themselves as they * should, so also for their sake, we keep the #include to be consistent with * prior Tcl releases. */ #include <stdio.h> /* * Support for functions with a variable number of arguments. * * The following TCL_VARARGS* macros are to support old extensions * written for older versions of Tcl where the macros permitted * support for the varargs.h system as well as stdarg.h . * * New code should just directly be written to use stdarg.h conventions. */ #include <stdarg.h> #ifndef TCL_NO_DEPRECATED # 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) #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. */ #ifdef STATIC_BUILD # define DLLIMPORT # define DLLEXPORT #else # if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) # define DLLIMPORT __declspec(dllimport) # define DLLEXPORT __declspec(dllexport) # else # define DLLIMPORT # define DLLEXPORT # endif #endif /* * These macros are used to control whether functions are being declared for * import or export. If a function is being declared while it is being built * to be included in a shared library, then it should have the DLLEXPORT * storage class. If is being declared for use by a module that is going to * link against the shared library, then it should have the DLLIMPORT storage * class. If the symbol is beind declared for a static build or for use from a * stub library, then the storage class should be empty. * * The convention is that a macro called BUILD_xxxx, where xxxx is the name of * a library we are building, is set on the compile line for sources that are * to be placed in the library. When this macro is set, the storage class will * be set to DLLEXPORT. At the end of the header file, the storage class will * be reset to DLLIMPORT. */ #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT #else # ifdef USE_TCL_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif /* * Definitions that allow this header file to be used either with or without * ANSI C features like function prototypes. */ #undef _ANSI_ARGS_ #undef CONST #ifndef INLINE # define INLINE #endif #ifndef NO_CONST |
︙ | ︙ | |||
236 237 238 239 240 241 242 | # 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 | | < > < | < | | | | < | | < | | > | | | | | | | | | | | | 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 | # 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. This block is skipped under Cygwin and Mingw. */ #if defined(__WIN32__) && !defined(HAVE_WINNT_IGNORE_VOID) #ifndef VOID #define VOID void typedef char CHAR; typedef short SHORT; typedef long LONG; #endif #endif /* __WIN32__ && !HAVE_WINNT_IGNORE_VOID */ /* * 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.) * * Also defines the following macros: * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on a real * 64-bit system.) * Tcl_WideAsLong - forgetful converter from wideInt to long. * Tcl_LongAsWide - sign-extending converter from long to wideInt. * Tcl_WideAsDouble - converter from wideInt to double. * Tcl_DoubleAsWide - converter from double to wideInt. * * The following invariant should hold for any long value 'longVal': * longVal == Tcl_WideAsLong(Tcl_LongAsWide(longVal)) * * Note on converting between Tcl_WideInt and strings. This implementation (in * tclObj.c) depends on the functions strtoull() and sprintf(...,"%" * TCL_LL_MODIFIER "d",...). TCL_LL_MODIFIER_SIZE is the length of the * modifier string, which is "ll" on most 32-bit Unix systems. It has to be * split up like this to allow for the more complex formats sometimes needed * (e.g. in the format(n) command.) */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) # if defined(__GNUC__) # define TCL_WIDE_INT_TYPE long long # if defined(__WIN32__) && !defined(__CYGWIN__) # define TCL_LL_MODIFIER "I64" |
︙ | ︙ | |||
352 353 354 355 356 357 358 | # else /* __BORLANDC__ */ typedef struct _stati64 Tcl_StatBuf; # define TCL_LL_MODIFIER "I64" # define TCL_LL_MODIFIER_SIZE 3 # endif /* __BORLANDC__ */ # else /* __WIN32__ */ /* | | | | 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 | # else /* __BORLANDC__ */ typedef struct _stati64 Tcl_StatBuf; # define TCL_LL_MODIFIER "I64" # define TCL_LL_MODIFIER_SIZE 3 # endif /* __BORLANDC__ */ # else /* __WIN32__ */ /* * Don't know what platform it is and configure hasn't discovered what is * going on for us. Try to guess... */ # ifdef NO_LIMITS_H # error please define either TCL_WIDE_INT_TYPE or TCL_WIDE_INT_IS_LONG # else /* !NO_LIMITS_H */ # include <limits.h> # if (INT_MAX < LONG_MAX) # define TCL_WIDE_INT_IS_LONG 1 |
︙ | ︙ | |||
387 388 389 390 391 392 393 | # define Tcl_DoubleAsWide(val) ((long)((double)(val))) # ifndef TCL_LL_MODIFIER # define TCL_LL_MODIFIER "l" # define TCL_LL_MODIFIER_SIZE 1 # endif /* !TCL_LL_MODIFIER */ #else /* 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 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 | # define Tcl_DoubleAsWide(val) ((long)((double)(val))) # ifndef TCL_LL_MODIFIER # define TCL_LL_MODIFIER "l" # define TCL_LL_MODIFIER_SIZE 1 # endif /* !TCL_LL_MODIFIER */ #else /* TCL_WIDE_INT_IS_LONG */ /* * The next short section of defines are only done when not running on Windows * or some other strange platform. */ # ifndef TCL_LL_MODIFIER # 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 # endif /* !TCL_LL_MODIFIER */ # define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) # define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) # define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) # define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) #endif /* TCL_WIDE_INT_IS_LONG */ /* * This flag controls whether binary compatability is maintained with * extensions built against a previous version of Tcl. This is true by * default. */ #ifndef TCL_PRESERVE_BINARY_COMPATABILITY # define TCL_PRESERVE_BINARY_COMPATABILITY 1 #endif /* * Data structures defined opaquely in this module. The definitions below just * provide dummy types. A few fields are made visible in Tcl_Interp * structures, namely those used for returning a string result from commands. * Direct access to the result field is discouraged in Tcl 8.0. The * interpreter result is either an object or a string, and the two values are * kept consistent unless some C code sets interp->result directly. * Programmers should use either the function Tcl_GetObjResult() or * Tcl_GetStringResult() to read the interpreter's result. See the SetResult * man page for details. * * Note: any change to the Tcl_Interp definition below must be mirrored in the * "real" definition in tclInt.h. * * Note: Tcl_ObjCmdProc functions do not directly set result and freeProc. * Instead, they set a Tcl_Obj member in the "real" structure that can be * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). */ typedef struct Tcl_Interp { char *result; /* If the last command returned a string * result, this points to it. */ void (*freeProc) _ANSI_ARGS_((char *blockPtr)); /* Zero means the string result is statically * allocated. TCL_DYNAMIC means it was * allocated with ckalloc and should be freed * with ckfree. Other values give the address * of function to invoke to free the result. * Tcl_Eval must free it before executing next * command. */ int errorLine; /* When TCL_ERROR is returned, this gives the * line number within the command where the * error occurred (1 if first line). */ } Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; typedef struct Tcl_Command_ *Tcl_Command; typedef struct Tcl_Condition_ *Tcl_Condition; |
︙ | ︙ | |||
472 473 474 475 476 477 478 | 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; /* | | | | < > < | | > | < > | | > | > > | | | > | > | | | | | < | | | | > | | | | < | | | | | | | | | | | > > < > > | | | < > < | | | | | | | | > < | | | | | | | | | | | < < | | | | | | | | | | | > > > > > > < | | | | | | | | > | 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 | 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; /* * Definition of the interface to functions implementing threads. A function * 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. */ #if defined __WIN32__ typedef unsigned (__stdcall Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); #else typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); #endif /* * Threading function return types used for abstracting away platform * differences when writing a Tcl_ThreadCreateProc. See the NewThread function * in generic/tclThreadTest.c for it's usage. */ #if defined __WIN32__ # define Tcl_ThreadCreateType unsigned __stdcall # define TCL_THREAD_CREATE_RETURN return 0 #else # define Tcl_ThreadCreateType void # define TCL_THREAD_CREATE_RETURN #endif /* * Definition of values for default stacksize and the possible flags to be * given to Tcl_CreateThread. */ #define TCL_THREAD_STACK_DEFAULT (0) /* Use default size for stack */ #define TCL_THREAD_NOFLAGS (0000) /* Standard flags, default behaviour */ #define TCL_THREAD_JOINABLE (0001) /* Mark the thread as joinable */ /* * Flag values passed to Tcl_GetRegExpFromObj. */ #define TCL_REG_BASIC 000000 /* BREs (convenience) */ #define TCL_REG_EXTENDED 000001 /* EREs */ #define TCL_REG_ADVF 000002 /* advanced features in EREs */ #define TCL_REG_ADVANCED 000003 /* AREs (which are also EREs) */ #define TCL_REG_QUOTE 000004 /* no special characters, none */ #define TCL_REG_NOCASE 000010 /* ignore case */ #define TCL_REG_NOSUB 000020 /* don't care about subexpressions */ #define TCL_REG_EXPANDED 000040 /* expanded format, white space & * comments */ #define TCL_REG_NLSTOP 000100 /* \n doesn't match . or [^ ] */ #define TCL_REG_NLANCH 000200 /* ^ matches after \n, $ before */ #define TCL_REG_NEWLINE 000300 /* newlines are line terminators */ #define TCL_REG_CANMATCH 001000 /* report details on partial/limited * matches */ /* * The following flag is experimental and only intended for use by Expect. It * will probably go away in a later release. */ #define TCL_REG_BOSONLY 002000 /* prepend \A to pattern so it only * matches at the beginning of the * string. */ /* * Flags values passed to Tcl_RegExpExecObj. */ #define TCL_REG_NOTBOL 0001 /* Beginning of string does not match ^. */ #define TCL_REG_NOTEOL 0002 /* End of string does not match $. */ /* * Structures filled in by Tcl_RegExpInfo. Note that all offset values are * relative to the start of the match string, not the beginning of the entire * string. */ typedef struct Tcl_RegExpIndices { long start; /* Character offset of first character in * match. */ long end; /* Character offset of first character after * the match. */ } Tcl_RegExpIndices; typedef struct Tcl_RegExpInfo { int nsubs; /* Number of subexpressions in the compiled * expression. */ Tcl_RegExpIndices *matches; /* Array of nsubs match offset pairs. */ long extendStart; /* The offset at which a subsequent match * might begin. */ long reserved; /* Reserved for later use. */ } Tcl_RegExpInfo; /* * Picky compilers complain if this typdef doesn't appear before the struct's * reference in tclDecls.h. */ typedef Tcl_StatBuf *Tcl_Stat_; typedef struct stat *Tcl_OldStat_; /* * When a TCL command returns, the interpreter contains a result from the * command. Programmers are strongly encouraged to use one of the functions * Tcl_GetObjResult() or Tcl_GetStringResult() to read the interpreter's * result. See the SetResult man page for details. Besides this result, the * command function returns an integer code, which is one of the following: * * TCL_OK Command completed normally; the interpreter's result * contains the command's result. * TCL_ERROR The command couldn't be completed successfully; the * interpreter's result describes what went wrong. * TCL_RETURN The command requests that the current function return; * the interpreter's result contains the function's * return value. * TCL_BREAK The command requests that the innermost loop be * exited; the interpreter's result is meaningless. * TCL_CONTINUE Go on to the next iteration of the current loop; the * interpreter's result is meaningless. */ #define TCL_OK 0 #define TCL_ERROR 1 #define TCL_RETURN 2 #define TCL_BREAK 3 #define TCL_CONTINUE 4 #define TCL_RESULT_SIZE 200 /* * Flags to control what substitutions are performed by Tcl_SubstObj(): */ #define TCL_SUBST_COMMANDS 001 #define TCL_SUBST_VARIABLES 002 #define TCL_SUBST_BACKSLASHES 004 #define TCL_SUBST_ALL 007 /* * Argument descriptors for math function callbacks in expressions: */ typedef enum { TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT } Tcl_ValueType; typedef struct Tcl_Value { Tcl_ValueType type; /* Indicates intValue or doubleValue is valid, * or both. */ long intValue; /* Integer value. */ double doubleValue; /* Double-precision floating value. */ Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */ } Tcl_Value; /* * Forward declaration of Tcl_Obj to prevent an error when the forward * reference to Tcl_Obj is encountered in the function types declared below. */ struct Tcl_Obj; /* * Function types defined by Tcl: */ 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, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); typedef void (Tcl_EncodingFreeProc)_ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData, int flags)); typedef int (Tcl_EventDeleteProc) _ANSI_ARGS_((Tcl_Event *evPtr, ClientData clientData)); typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData, int flags)); typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData)); typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask)); typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData)); typedef void (Tcl_FreeInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr)); typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr)); typedef void (Tcl_IdleProc) _ANSI_ARGS_((ClientData clientData)); typedef void (Tcl_InterpDeleteProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv)); typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); typedef int (Tcl_PackageUnloadProc) _ANSI_ARGS_((Tcl_Interp *interp, int flags)); typedef void (Tcl_PanicProc) _ANSI_ARGS_((CONST char *format, ...)); 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 functions that provide * standard operations on objects of that type. */ typedef struct Tcl_ObjType { char *name; /* Name of the type, e.g. "int". */ Tcl_FreeInternalRepProc *freeIntRepProc; /* Called to free any storage for the type's * internal rep. NULL if the internal rep does * not need freeing. */ Tcl_DupInternalRepProc *dupIntRepProc; /* Called to create a new object as a copy of * an existing object. */ Tcl_UpdateStringProc *updateStringProc; /* Called to update the string rep from the * type's internal representation. */ Tcl_SetFromAnyProc *setFromAnyProc; /* Called to convert the object's internal rep * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ } Tcl_ObjType; /* * One of the following structures exists for each object in the Tcl system. * An object stores a value as either a string, some internal representation, * or both. */ typedef struct Tcl_Obj { int refCount; /* When 0 the object will be freed. */ char *bytes; /* This points to the first byte of the * object's string representation. The array * must be followed by a null byte (i.e., at * offset length) but may also contain * embedded null characters. The array's * storage is allocated by ckalloc. NULL means * the string rep is invalid and must be * regenerated from the internal rep. Clients * should use Tcl_GetStringFromObj or * Tcl_GetString to get a pointer to the byte * array as a readonly value. */ int length; /* The number of bytes at *bytes, not * including the terminating null. */ Tcl_ObjType *typePtr; /* Denotes the object's type. Always * corresponds to the type of the object's * internal rep. NULL indicates the object has * no internal rep (has no type). */ union { /* The internal representation: */ long longValue; /* - an long integer value */ double doubleValue; /* - a double-precision floating value */ VOID *otherValuePtr; /* - another, type-specific value */ Tcl_WideInt wideValue; /* - a long long value */ struct { /* - internal rep as two pointers */ VOID *ptr1; VOID *ptr2; } twoPtrValue; struct { /* - internal rep as a wide int, tightly * packed fields */ VOID *ptr; /* Pointer to digits */ unsigned long value;/* Alloc, used, and signum packed into a * single word */ } ptrAndLongRep; } internalRep; } Tcl_Obj; /* * Macros to increment and decrement a Tcl_Obj's reference count, and to test * whether an object is shared (i.e. has reference count > 1). Note: clients * should use Tcl_DecrRefCount() when they are finished using an object, and * should never call TclFreeObj() directly. TclFreeObj() is only defined and * made public in tcl.h to support Tcl_DecrRefCount's macro definition. Note * also that Tcl_DecrRefCount() refers to the parameter "obj" twice. This * means that you should avoid calling it with an expression that is expensive * to compute or has side effects. */ void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); #ifdef TCL_MEM_DEBUG # define Tcl_IncrRefCount(objPtr) \ Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__) |
︙ | ︙ | |||
791 792 793 794 795 796 797 | # define Tcl_DecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr) # define Tcl_IsShared(objPtr) \ ((objPtr)->refCount > 1) #endif /* | | | | > > < | | | > < | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | < | | | | | | | < | | | | | | | | | | | | | | | | | | | | < | | | > | | | | | | > | | > | | | | | | | | > > | | | | > | > > > > > > > > > | < < < < < < < < | | < | | > | < > | | > > > > > > > > > | | | | > | | < | | < | | | | < | | | | | | | | | | | < | | | < | | | < > | < > | < < | | > | < < | | > | < | | | > | > | | > | > | | > | < | < | > | > | | < < | | | | | | | | | | | | | | | | | | < | | < | | | | | | | | | | | | | | | | | | | | | < | | | | | 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 | # define Tcl_DecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr) # define Tcl_IsShared(objPtr) \ ((objPtr)->refCount > 1) #endif /* * Macros and definitions that help to debug the use of Tcl objects. When * TCL_MEM_DEBUG is defined, the Tcl_New declarations are overridden to call * debugging versions of the object creation functions. */ #ifdef TCL_MEM_DEBUG # define Tcl_NewBignumObj(val) \ Tcl_DbNewBignumObj(val, __FILE__, __LINE__) # define Tcl_NewBooleanObj(val) \ Tcl_DbNewBooleanObj(val, __FILE__, __LINE__) # define Tcl_NewByteArrayObj(bytes, len) \ Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__) # define Tcl_NewDoubleObj(val) \ Tcl_DbNewDoubleObj(val, __FILE__, __LINE__) # define Tcl_NewIntObj(val) \ Tcl_DbNewLongObj(val, __FILE__, __LINE__) # define Tcl_NewListObj(objc, objv) \ Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__) # define Tcl_NewLongObj(val) \ Tcl_DbNewLongObj(val, __FILE__, __LINE__) # define Tcl_NewObj() \ Tcl_DbNewObj(__FILE__, __LINE__) # define Tcl_NewStringObj(bytes, len) \ Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__) # define Tcl_NewWideIntObj(val) \ Tcl_DbNewWideIntObj(val, __FILE__, __LINE__) #endif /* TCL_MEM_DEBUG */ /* * The following structure contains the state needed by Tcl_SaveResult. No-one * outside of Tcl should access any of these fields. This structure is * typically allocated on the stack. */ typedef struct Tcl_SavedResult { char *result; Tcl_FreeProc *freeProc; Tcl_Obj *objResultPtr; char *appendResult; int appendAvl; int appendUsed; char resultSpace[TCL_RESULT_SIZE+1]; } Tcl_SavedResult; /* * The following definitions support Tcl's namespace facility. Note: the first * five fields must match exactly the fields in a Namespace structure (see * tclInt.h). */ typedef struct Tcl_Namespace { char *name; /* The namespace's name within its parent * namespace. This contains no ::'s. The name * of the global namespace is "" although "::" * is an synonym. */ char *fullName; /* The namespace's fully qualified name. This * starts with ::. */ ClientData clientData; /* Arbitrary value associated with this * namespace. */ Tcl_NamespaceDeleteProc* deleteProc; /* Function invoked when deleting the * namespace to, e.g., free clientData. */ struct Tcl_Namespace* parentPtr; /* Points to the namespace that contains this * one. NULL if this is the global * namespace. */ } Tcl_Namespace; /* * The following structure represents a call frame, or activation record. A * call frame defines a naming context for a procedure call: its local scope * (for local variables) and its namespace scope (used for non-local * variables; often the global :: namespace). A call frame can also define the * naming context for a namespace eval or namespace inscope command: the * namespace in which the command's code should execute. The Tcl_CallFrame * structures exist only while procedures or namespace eval/inscope's are * being executed, and provide a Tcl call stack. * * A call frame is initialized and pushed using Tcl_PushCallFrame and popped * using Tcl_PopCallFrame. Storage for a Tcl_CallFrame must be provided by the * Tcl_PushCallFrame caller, and callers typically allocate them on the C call * stack for efficiency. For this reason, Tcl_CallFrame is defined as a * structure and not as an opaque token. However, most Tcl_CallFrame fields * are hidden since applications should not access them directly; others are * declared as "dummyX". * * WARNING!! The structure definition must be kept consistent with the * CallFrame structure in tclInt.h. If you change one, change the other. */ typedef struct Tcl_CallFrame { Tcl_Namespace *nsPtr; int dummy1; int dummy2; char *dummy3; char *dummy4; char *dummy5; int dummy6; char *dummy7; char *dummy8; int dummy9; char* dummy10; } Tcl_CallFrame; /* * Information about commands that is returned by Tcl_GetCommandInfo and * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based command * function while proc is a traditional Tcl argc/argv string-based function. * Tcl_CreateObjCommand and Tcl_CreateCommand ensure that both objProc and * proc are non-NULL and can be called to execute the command. However, it may * be faster to call one instead of the other. The member isNativeObjectProc * is set to 1 if an object-based function was registered by * Tcl_CreateObjCommand, and to 0 if a string-based function was registered by * Tcl_CreateCommand. The other function is typically set to a compatibility * wrapper that does string-to-object or object-to-string argument conversions * then calls the other function. */ typedef struct Tcl_CmdInfo { int isNativeObjectProc; /* 1 if objProc was registered by a call to * Tcl_CreateObjCommand; 0 otherwise. * Tcl_SetCmdInfo does not modify this * field. */ Tcl_ObjCmdProc *objProc; /* Command's object-based function. */ ClientData objClientData; /* ClientData for object proc. */ Tcl_CmdProc *proc; /* Command's string-based function. */ ClientData clientData; /* ClientData for string proc. */ Tcl_CmdDeleteProc *deleteProc; /* Function to call when command is * deleted. */ ClientData deleteData; /* Value to pass to deleteProc (usually the * same as clientData). */ Tcl_Namespace *namespacePtr;/* Points to the namespace that contains this * command. Note that Tcl_SetCmdInfo will not * change a command's namespace; use * TclRenameCommand or Tcl_Eval (of 'rename') * to do that. */ } Tcl_CmdInfo; /* * The structure defined below is used to hold dynamic strings. The only * fields that clients should use are string and length, accessible via the * macros Tcl_DStringValue and Tcl_DStringLength. */ #define TCL_DSTRING_STATIC_SIZE 200 typedef struct Tcl_DString { char *string; /* Points to beginning of string: either * staticSpace below or a malloced array. */ int length; /* Number of non-NULL characters in the * string. */ int spaceAvl; /* Total number of bytes available for the * string and its terminating NULL char. */ char staticSpace[TCL_DSTRING_STATIC_SIZE]; /* Space to use in common case where string is * small. */ } Tcl_DString; #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) #define Tcl_DStringTrunc Tcl_DStringSetLength /* * Definitions for the maximum number of digits of precision that may be * specified in the "tcl_precision" variable, and the number of bytes of * buffer space required by Tcl_PrintDouble. */ #define TCL_MAX_PREC 17 #define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10) /* * Definition for a number of bytes of buffer space sufficient to hold the * string representation of an integer in base 10 (assuming the existence of * 64-bit integers). */ #define TCL_INTEGER_SPACE 24 /* * Flag values passed to Tcl_ConvertElement. * TCL_DONT_USE_BRACES forces it not to enclose the element in braces, but to * use backslash quoting instead. * TCL_DONT_QUOTE_HASH disables the default quoting of the '#' character. It * is safe to leave the hash unquoted when the element is not the first * element of a list, and this flag can be used by the caller to indicate * that condition. * (Careful! If you change these flag values be sure to change the definitions * at the front of tclUtil.c). */ #define TCL_DONT_USE_BRACES 1 #define TCL_DONT_QUOTE_HASH 8 /* * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow * abbreviated strings. */ #define TCL_EXACT 1 /* * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv. * WARNING: these bit choices must not conflict with the bit choices for * evalFlag bits in tclInt.h! * * Meanings: * TCL_NO_EVAL: Just record this command * TCL_EVAL_GLOBAL: Execute script in global namespace * TCL_EVAL_DIRECT: Do not compile this script * TCL_EVAL_INVOKE: Magical Tcl_EvalObjv mode for aliases/ensembles * o Run in global namespace * o Cut out of error traces * o Don't reset the flags controlling ensemble * error message rewriting. */ #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) #define TCL_DYNAMIC ((Tcl_FreeProc *) 3) /* * Flag values passed to variable-related functions. */ #define TCL_GLOBAL_ONLY 1 #define TCL_NAMESPACE_ONLY 2 #define TCL_APPEND_VALUE 4 #define TCL_LIST_ELEMENT 8 #define TCL_TRACE_READS 0x10 #define TCL_TRACE_WRITES 0x20 #define TCL_TRACE_UNSETS 0x40 #define TCL_TRACE_DESTROYED 0x80 #define TCL_INTERP_DESTROYED 0x100 #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 #ifndef TCL_REMOVE_OBSOLETE_TRACES /* Required to support old variable/vdelete/vinfo traces */ #define TCL_TRACE_OLD_STYLE 0x1000 #endif /* Indicate the semantics of the result of a trace */ #define TCL_TRACE_RESULT_DYNAMIC 0x8000 #define TCL_TRACE_RESULT_OBJECT 0x10000 /* * Flag values for ensemble commands. */ #define TCL_ENSEMBLE_PREFIX 0x02/* Flag value to say whether to allow * unambiguous prefixes of commands or to * require exact matches for command names. */ /* * Flag values passed to command-related functions. */ #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) */ #ifndef TCL_NO_DEPRECATED # define TCL_PARSE_PART1 0x400 #endif /* * Types for linked variables: */ #define TCL_LINK_INT 1 #define TCL_LINK_DOUBLE 2 #define TCL_LINK_BOOLEAN 3 #define TCL_LINK_STRING 4 #define TCL_LINK_WIDE_INT 5 #define TCL_LINK_CHAR 6 #define TCL_LINK_UCHAR 7 #define TCL_LINK_SHORT 8 #define TCL_LINK_USHORT 9 #define TCL_LINK_UINT 10 #define TCL_LINK_LONG 11 #define TCL_LINK_ULONG 12 #define TCL_LINK_FLOAT 13 #define TCL_LINK_WIDE_UINT 14 #define TCL_LINK_READ_ONLY 0x80 /* * Forward declarations of Tcl_HashTable and related types. */ typedef struct Tcl_HashKeyType Tcl_HashKeyType; typedef struct Tcl_HashTable Tcl_HashTable; typedef struct Tcl_HashEntry Tcl_HashEntry; typedef unsigned int (Tcl_HashKeyProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr, VOID *keyPtr)); typedef int (Tcl_CompareHashKeysProc) _ANSI_ARGS_((VOID *keyPtr, Tcl_HashEntry *hPtr)); typedef Tcl_HashEntry *(Tcl_AllocHashEntryProc) _ANSI_ARGS_(( Tcl_HashTable *tablePtr, VOID *keyPtr)); typedef void (Tcl_FreeHashEntryProc) _ANSI_ARGS_((Tcl_HashEntry *hPtr)); /* * This flag controls whether the hash table stores the hash of a key, or * recalculates it. There should be no reason for turning this flag off as it * is completely binary and source compatible unless you directly access the * bucketPtr member of the Tcl_HashTableEntry structure. This member has been * removed and the space used to store the hash value. */ #ifndef TCL_HASH_KEY_STORE_HASH # define TCL_HASH_KEY_STORE_HASH 1 #endif /* * Structure definition for an entry in a hash table. No-one outside Tcl * should access any of these fields directly; use the macros defined below. */ struct Tcl_HashEntry { Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket, * or NULL for end of chain. */ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ #if TCL_HASH_KEY_STORE_HASH # if TCL_PRESERVE_BINARY_COMPATABILITY VOID *hash; /* Hash value, stored as pointer to ensure * that the offsets of the fields in this * structure are not changed. */ # else unsigned int hash; /* Hash value. */ # endif #else Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to first * entry in this entry's chain: used for * deleting the entry. */ #endif ClientData clientData; /* Application stores something here with * Tcl_SetHashValue. */ union { /* Key has one of these forms: */ char *oneWordValue; /* One-word value for key. */ Tcl_Obj *objPtr; /* Tcl_Obj * key value. */ int words[1]; /* Multiple integer words for key. The actual * size will be as large as necessary for this * table's keys. */ char string[4]; /* String for key. The actual size will be as * large as needed to hold the key. */ } key; /* MUST BE LAST FIELD IN RECORD!! */ }; /* * Flags used in Tcl_HashKeyType. * * TCL_HASH_KEY_RANDOMIZE_HASH - * There are some things, pointers for example * which don't hash well because they do not use * the lower bits. If this flag is set then the * hash table will attempt to rectify this by * randomising the bits and then using the upper * N bits as the index into the table. * TCL_HASH_KEY_SYSTEM_HASH - If this flag is set then all memory internally * allocated for the hash table that is not for an * entry will use the system heap. */ #define TCL_HASH_KEY_RANDOMIZE_HASH 0x1 #define TCL_HASH_KEY_SYSTEM_HASH 0x2 /* * Structure definition for the methods associated with a hash table key type. */ #define TCL_HASH_KEY_TYPE_VERSION 1 struct Tcl_HashKeyType { int version; /* Version of the table. If this structure is * extended in future then the version can be * used to distinguish between different * structures. */ int flags; /* Flags, see above for details. */ Tcl_HashKeyProc *hashKeyProc; /* Calculates a hash value for the key. If * this is NULL then the pointer itself is * used as a hash value. */ Tcl_CompareHashKeysProc *compareKeysProc; /* Compares two keys and returns zero if they * do not match, and non-zero if they do. If * this is NULL then the pointers are * compared. */ Tcl_AllocHashEntryProc *allocEntryProc; /* Called to allocate memory for a new entry, * i.e. if the key is a string then this could * allocate a single block which contains * enough space for both the entry and the * string. Only the key field of the allocated * Tcl_HashEntry structure needs to be filled * in. If something else needs to be done to * the key, i.e. incrementing a reference * count then that should be done by this * function. If this is NULL then Tcl_Alloc is * used to allocate enough space for a * Tcl_HashEntry and the key pointer is * assigned to key.oneWordValue. */ Tcl_FreeHashEntryProc *freeEntryProc; /* Called to free memory associated with an * entry. If something else needs to be done * to the key, i.e. decrementing a reference * count then that should be done by this * function. If this is NULL then Tcl_Free is * used to free the Tcl_HashEntry. */ }; /* * Structure definition for a hash table. Must be in tcl.h so clients can * allocate space for these structures, but clients should never access any * fields in this structure. */ #define TCL_SMALL_HASH_TABLE 4 struct Tcl_HashTable { Tcl_HashEntry **buckets; /* Pointer to bucket array. Each element * points to first entry in bucket's hash * chain, or NULL. */ Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables (to * avoid mallocs and frees). */ int numBuckets; /* Total number of buckets allocated at * **bucketPtr. */ int numEntries; /* Total number of entries present in * table. */ int rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ int downShift; /* Shift count used in hashing function. * Designed to use high-order bits of * randomized keys. */ int mask; /* Mask value used in hashing function. */ int keyType; /* Type of keys used in this table. It's * either TCL_CUSTOM_KEYS, TCL_STRING_KEYS, * TCL_ONE_WORD_KEYS, or an integer giving the * number of ints that is the size of the * key. */ #if TCL_PRESERVE_BINARY_COMPATABILITY Tcl_HashEntry *(*findProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key)); Tcl_HashEntry *(*createProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key, int *newPtr)); #endif Tcl_HashKeyType *typePtr; /* Type of the keys used in the * Tcl_HashTable. */ }; /* * Structure definition for information used to keep track of searches through * hash tables: */ typedef struct Tcl_HashSearch { Tcl_HashTable *tablePtr; /* Table being searched. */ int nextIndex; /* Index of next bucket to be enumerated after * present one. */ Tcl_HashEntry *nextEntryPtr;/* Next entry to be enumerated in the current * bucket. */ } Tcl_HashSearch; /* * Acceptable key types for hash tables: * * TCL_STRING_KEYS: The keys are strings, they are copied into the * entry. * TCL_ONE_WORD_KEYS: The keys are pointers, the pointer is stored * in the entry. * TCL_CUSTOM_TYPE_KEYS: The keys are arbitrary types which are copied * into the entry. * TCL_CUSTOM_PTR_KEYS: The keys are pointers to arbitrary types, the * pointer is stored in the entry. * * While maintaining binary compatability the above have to be distinct values * as they are used to differentiate between old versions of the hash table * which don't have a typePtr and new ones which do. Once binary compatability * is discarded in favour of making more wide spread changes TCL_STRING_KEYS * can be the same as TCL_CUSTOM_TYPE_KEYS, and TCL_ONE_WORD_KEYS can be the * same as TCL_CUSTOM_PTR_KEYS because they simply determine how the key is * accessed from the entry and not the behaviour. */ #define TCL_STRING_KEYS 0 #define TCL_ONE_WORD_KEYS 1 #if TCL_PRESERVE_BINARY_COMPATABILITY # define TCL_CUSTOM_TYPE_KEYS -2 # define TCL_CUSTOM_PTR_KEYS -1 #else # define TCL_CUSTOM_TYPE_KEYS TCL_STRING_KEYS # define TCL_CUSTOM_PTR_KEYS TCL_ONE_WORD_KEYS #endif /* * Macros for clients to use to access fields of hash entries: */ #define Tcl_GetHashValue(h) ((h)->clientData) |
︙ | ︙ | |||
1314 1315 1316 1317 1318 1319 1320 | # define Tcl_GetHashKey(tablePtr, h) \ ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) \ ? (h)->key.oneWordValue \ : (h)->key.string)) #endif /* | | | | | | < | | > | | | | | | < > | > > < | | | > > > > > > > | | > | | | > | > | | > | > > > > > > > > > > | | < | > > > > > > > > > | | | > > | | | < > | | | | | > | | | | > | | | | | | | | | > | | | | > | | | | > | < | | | | > | | > | | | < | | | > > > > > > > > > > > > > | | | > > < | | | > | < | < | < | < | > | > | | > | | < | | | | | | | | | | | | | < | | | < | | | | < | | | | | | | | | | | | > | | | | | | | | < | | | | < | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | < < | | < | < | | | < | < | | | | < | | | | | | | < < | | | | | < | | | | | | | | | | | | | | | | | | | | | | | < | | | | < | | < | | | | < | | | | | | < | | < < < < < < < | | | > > > > > | | | | | < | | | | < | | | | < | | < < | | | | | | | | | | | | | | < | | | | | | | > | | | | > < | > | | | | | | | | | | | | | | | | < | | | < | | | | | | | | > < | < | | | > | | | | | | | | | < | | | < | | | | | | | < | | | | | > > > < < < < | | < | | | | | < | | | | | | | | | | | | < | | | | | | | | | | | < | | | | > | | < > | | > | | < | | | | > | | | | | | | | | | | | | < | | | | | | | | | | | | | | | < | < | | | | < | | | < | | | > | | | | < | | | < | | | > | | > | | | > | | < | > | > < | | | > > > > > > > > < | | | | | | | | | | < | | | | | < | 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 | # define Tcl_GetHashKey(tablePtr, h) \ ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) \ ? (h)->key.oneWordValue \ : (h)->key.string)) #endif /* * Macros to use for clients to use to invoke find and create functions for * hash tables: */ #if TCL_PRESERVE_BINARY_COMPATABILITY # define Tcl_FindHashEntry(tablePtr, key) \ (*((tablePtr)->findProc))(tablePtr, key) # define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, key, newPtr) #else /* !TCL_PRESERVE_BINARY_COMPATABILITY */ /* * Macro to use new extended version of Tcl_InitHashTable. */ # define Tcl_InitHashTable(tablePtr, keyType) \ Tcl_InitHashTableEx(tablePtr, keyType, NULL) #endif /* TCL_PRESERVE_BINARY_COMPATABILITY */ /* * Structure definition for information used to keep track of searches through * dictionaries. These fields should not be accessed by code outside * tclDictObj.c */ typedef struct { Tcl_HashSearch search; /* Search struct for underlying hash table. */ int epoch; /* Epoch marker for dictionary being searched, * or -1 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; /* * Flag values to pass to Tcl_DoOneEvent to disable searches for some kinds of * events: */ #define TCL_DONT_WAIT (1<<1) #define TCL_WINDOW_EVENTS (1<<2) #define TCL_FILE_EVENTS (1<<3) #define TCL_TIMER_EVENTS (1<<4) #define TCL_IDLE_EVENTS (1<<5) /* WAS 0x10 ???? */ #define TCL_ALL_EVENTS (~TCL_DONT_WAIT) /* * The following structure defines a generic event for the Tcl event system. * These are the things that are queued in calls to Tcl_QueueEvent and * serviced later by Tcl_DoOneEvent. There can be many different kinds of * events with different fields, corresponding to window events, timer events, * etc. The structure for a particular event consists of a Tcl_Event header * followed by additional information specific to that event. */ struct Tcl_Event { Tcl_EventProc *proc; /* Function to call to service this event. */ struct Tcl_Event *nextPtr; /* Next in list of pending events, or NULL. */ }; /* * Positions to pass to Tcl_QueueEvent: */ typedef enum { TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK } Tcl_QueuePosition; /* * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier * event routines. */ #define TCL_SERVICE_NONE 0 #define TCL_SERVICE_ALL 1 /* * The following structure keeps is used to hold a time value, either as an * absolute time (the number of seconds from the epoch) or as an elapsed time. * On Unix systems the epoch is Midnight Jan 1, 1970 GMT. */ typedef struct Tcl_Time { long sec; /* Seconds. */ long usec; /* Microseconds. */ } Tcl_Time; typedef void (Tcl_SetTimerProc) _ANSI_ARGS_((Tcl_Time *timePtr)); typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr)); /* * TIP #233 (Virtualized Time) */ typedef void (Tcl_GetTimeProc) _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData)); typedef void (Tcl_ScaleTimeProc) _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData)); /* * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler to * indicate what sorts of events are of interest: */ #define TCL_READABLE (1<<1) #define TCL_WRITABLE (1<<2) #define TCL_EXCEPTION (1<<3) /* * Flag values to pass to Tcl_OpenCommandChannel to indicate the disposition * of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR, are also used in * Tcl_GetStdChannel. */ #define TCL_STDIN (1<<1) #define TCL_STDOUT (1<<2) #define TCL_STDERR (1<<3) #define TCL_ENFORCE_MODE (1<<4) /* * Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel * should be closed. */ #define TCL_CLOSE_READ (1<<1) #define TCL_CLOSE_WRITE (1<<2) /* * Value to use as the closeProc for a channel that supports the close2Proc * interface. */ #define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)1) /* * Channel version tag. This was introduced in 8.3.2/8.4. */ #define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1) #define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2) #define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3) #define TCL_CHANNEL_VERSION_4 ((Tcl_ChannelTypeVersion) 0x4) /* * TIP #218: Channel Actions, Ids for Tcl_DriverThreadActionProc */ #define TCL_CHANNEL_THREAD_INSERT (0) #define TCL_CHANNEL_THREAD_REMOVE (1) /* * Typedefs for the various operations in a channel type: */ typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_(( ClientData instanceData, int mode)); typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp)); typedef int (Tcl_DriverClose2Proc) _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp, int flags)); typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData, char *buf, int toRead, int *errorCodePtr)); typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData, CONST84 char *buf, int toWrite, int *errorCodePtr)); typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData, long offset, int mode, int *errorCodePtr)); typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_(( ClientData instanceData, Tcl_Interp *interp, CONST char *optionName, CONST char *value)); typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_(( ClientData instanceData, Tcl_Interp *interp, CONST84 char *optionName, Tcl_DString *dsPtr)); typedef void (Tcl_DriverWatchProc) _ANSI_ARGS_(( ClientData instanceData, int mask)); typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_(( ClientData instanceData, int direction, ClientData *handlePtr)); typedef int (Tcl_DriverFlushProc) _ANSI_ARGS_((ClientData instanceData)); typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_(( ClientData instanceData, int interestMask)); typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_(( ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCodePtr)); /* * TIP #218, Channel Thread Actions */ typedef void (Tcl_DriverThreadActionProc) _ANSI_ARGS_ (( ClientData instanceData, int action)); /* * TIP #208, File Truncation (etc.) */ typedef int (Tcl_DriverTruncateProc) _ANSI_ARGS_(( ClientData instanceData, Tcl_WideInt length)); /* * The following declarations either map ckalloc and ckfree to malloc and * free, or they map them to functions with all sorts of debugging hooks * defined in tclCkalloc.c. */ #ifdef TCL_MEM_DEBUG # define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) # define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__) # define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) # define attemptckalloc(x) Tcl_AttemptDbCkalloc(x, __FILE__, __LINE__) # define attemptckrealloc(x,y) Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__) #else /* !TCL_MEM_DEBUG */ /* * If we are not using the debugging allocator, we should call the Tcl_Alloc, * et al. routines in order to guarantee that every module is using the same * memory allocator both inside and outside of the Tcl library. */ # define ckalloc(x) Tcl_Alloc(x) # define ckfree(x) Tcl_Free(x) # define ckrealloc(x,y) Tcl_Realloc(x,y) # define attemptckalloc(x) Tcl_AttemptAlloc(x) # define attemptckrealloc(x,y) Tcl_AttemptRealloc(x,y) # define Tcl_InitMemory(x) # define Tcl_DumpActiveMemory(x) # define Tcl_ValidateAllMemory(x,y) #endif /* !TCL_MEM_DEBUG */ /* * struct Tcl_ChannelType: * * One such structure exists for each type (kind) of channel. It collects * together in one place all the functions that are part of the specific * channel type. * * It is recommend that the Tcl_Channel* functions are used to access elements * of this structure, instead of direct accessing. */ typedef struct Tcl_ChannelType { char *typeName; /* The name of the channel type in Tcl * commands. This storage is owned by channel * type. */ Tcl_ChannelTypeVersion version; /* Version of the channel type. */ Tcl_DriverCloseProc *closeProc; /* Function to call to close the channel, or * TCL_CLOSE2PROC if the close2Proc should be * used instead. */ Tcl_DriverInputProc *inputProc; /* Function to call for input on channel. */ Tcl_DriverOutputProc *outputProc; /* Function to call for output on channel. */ Tcl_DriverSeekProc *seekProc; /* Function to call to seek on the channel. * May be NULL. */ Tcl_DriverSetOptionProc *setOptionProc; /* Set an option on a channel. */ Tcl_DriverGetOptionProc *getOptionProc; /* Get an option from a channel. */ Tcl_DriverWatchProc *watchProc; /* Set up the notifier to watch for events on * this channel. */ Tcl_DriverGetHandleProc *getHandleProc; /* Get an OS handle from the channel or NULL * if not supported. */ Tcl_DriverClose2Proc *close2Proc; /* Function to call to close the channel if * the device supports closing the read & * write sides independently. */ Tcl_DriverBlockModeProc *blockModeProc; /* Set blocking mode for the raw channel. May * be NULL. */ /* * Only valid in TCL_CHANNEL_VERSION_2 channels or later */ Tcl_DriverFlushProc *flushProc; /* Function to call to flush a channel. May be * NULL. */ Tcl_DriverHandlerProc *handlerProc; /* Function to call to handle a channel event. * This will be passed up the stacked channel * chain. */ /* * Only valid in TCL_CHANNEL_VERSION_3 channels or later */ Tcl_DriverWideSeekProc *wideSeekProc; /* Function to call to seek on the channel * which can handle 64-bit offsets. May be * NULL, and must be NULL if seekProc is * NULL. */ /* * Only valid in TCL_CHANNEL_VERSION_4 channels or later * TIP #218, Channel Thread Actions * TIP #208 (part relating to truncation) */ Tcl_DriverThreadActionProc *threadActionProc; /* Function to call to notify the driver of * thread specific activity for a channel. May * be NULL. */ Tcl_DriverTruncateProc *truncateProc; /* Function to call to truncate the underlying * file to a particular length. May be NULL if * the channel does not support truncation. */ } Tcl_ChannelType; /* * The following flags determine whether the blockModeProc above should set * the channel into blocking or nonblocking mode. They are passed as arguments * to the blockModeProc function in the above structure. */ #define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */ #define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking * mode. */ /* * Enum for different types of file paths. */ typedef enum Tcl_PathType { TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, TCL_PATH_VOLUME_RELATIVE } Tcl_PathType; /* * The following structure is used to pass glob type data amongst the various * glob routines and Tcl_FSMatchInDirectory. */ typedef struct Tcl_GlobTypeData { int type; /* Corresponds to bcdpfls as in 'find -t' */ int perm; /* Corresponds to file permissions */ Tcl_Obj *macType; /* Acceptable mac type */ Tcl_Obj *macCreator; /* Acceptable mac creator */ } Tcl_GlobTypeData; /* * Type and permission definitions for glob command */ #define TCL_GLOB_TYPE_BLOCK (1<<0) #define TCL_GLOB_TYPE_CHAR (1<<1) #define TCL_GLOB_TYPE_DIR (1<<2) #define TCL_GLOB_TYPE_PIPE (1<<3) #define TCL_GLOB_TYPE_FILE (1<<4) #define TCL_GLOB_TYPE_LINK (1<<5) #define TCL_GLOB_TYPE_SOCK (1<<6) #define TCL_GLOB_TYPE_MOUNT (1<<7) #define TCL_GLOB_PERM_RONLY (1<<0) #define TCL_GLOB_PERM_HIDDEN (1<<1) #define TCL_GLOB_PERM_R (1<<2) #define TCL_GLOB_PERM_W (1<<3) #define TCL_GLOB_PERM_X (1<<4) /* * Flags for the unload callback function */ #define TCL_UNLOAD_DETACH_FROM_INTERPRETER (1<<0) #define TCL_UNLOAD_DETACH_FROM_PROCESS (1<<1) /* * 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)); typedef void (Tcl_FSFreeInternalRepProc) _ANSI_ARGS_((ClientData clientData)); typedef ClientData (Tcl_FSDupInternalRepProc) _ANSI_ARGS_(( ClientData clientData)); typedef Tcl_Obj* (Tcl_FSInternalToNormalizedProc) _ANSI_ARGS_(( ClientData clientData)); typedef ClientData (Tcl_FSCreateInternalRepProc) _ANSI_ARGS_(( Tcl_Obj *pathPtr)); typedef struct Tcl_FSVersion_ *Tcl_FSVersion; /* *---------------------------------------------------------------- * Data structures related to hooking into the filesystem *---------------------------------------------------------------- */ /* * Filesystem version tag. This was introduced in 8.4. */ #define TCL_FILESYSTEM_VERSION_1 ((Tcl_FSVersion) 0x1) /* * struct Tcl_Filesystem: * * One such structure exists for each type (kind) of filesystem. It collects * together in one place all the functions that are part of the specific * filesystem. Tcl always accesses the filesystem through one of these * structures. * * Not all entries need be non-NULL; any which are NULL are simply ignored. * However, a complete filesystem should provide all of these functions. The * explanations in the structure show the importance of each function. */ typedef struct Tcl_Filesystem { CONST char *typeName; /* The name of the filesystem. */ int structureLength; /* Length of this structure, so future binary * compatibility can be assured. */ Tcl_FSVersion version; /* Version of the filesystem type. */ Tcl_FSPathInFilesystemProc *pathInFilesystemProc; /* Function to check whether a path is in this * filesystem. This is the most important * filesystem function. */ Tcl_FSDupInternalRepProc *dupInternalRepProc; /* Function to duplicate internal fs rep. May * be NULL (but then fs is less efficient). */ Tcl_FSFreeInternalRepProc *freeInternalRepProc; /* Function to free internal fs rep. Must be * implemented if internal representations * need freeing, otherwise it can be NULL. */ Tcl_FSInternalToNormalizedProc *internalToNormalizedProc; /* Function to convert internal representation * to a normalized path. Only required if the * fs creates pure path objects with no * string/path representation. */ Tcl_FSCreateInternalRepProc *createInternalRepProc; /* Function to create a filesystem-specific * internal representation. May be NULL if * paths have no internal representation, or * if the Tcl_FSPathInFilesystemProc for this * filesystem always immediately creates an * internal representation for paths it * accepts. */ Tcl_FSNormalizePathProc *normalizePathProc; /* Function to normalize a path. Should be * implemented for all filesystems which can * have multiple string representations for * the same path object. */ Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc; /* Function to determine the type of a path in * this filesystem. May be NULL. */ Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc; /* Function to return the separator * character(s) for this filesystem. Must be * implemented. */ Tcl_FSStatProc *statProc; /* Function to process a 'Tcl_FSStat()' call. * Must be implemented for any reasonable * filesystem. */ Tcl_FSAccessProc *accessProc; /* Function to process a 'Tcl_FSAccess()' * call. Must be implemented for any * reasonable filesystem. */ Tcl_FSOpenFileChannelProc *openFileChannelProc; /* Function to process a * 'Tcl_FSOpenFileChannel()' call. Must be * implemented for any reasonable * filesystem. */ Tcl_FSMatchInDirectoryProc *matchInDirectoryProc; /* Function to process a * 'Tcl_FSMatchInDirectory()'. If not * implemented, then glob and recursive copy * functionality will be lacking in the * filesystem. */ Tcl_FSUtimeProc *utimeProc; /* Function to process a 'Tcl_FSUtime()' 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'. */ Tcl_FSLinkProc *linkProc; /* Function to process a 'Tcl_FSLink()' call. * Should be implemented only if the * filesystem supports links (reading or * creating). */ Tcl_FSListVolumesProc *listVolumesProc; /* 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. */ Tcl_FSFileAttrStringsProc *fileAttrStringsProc; /* Function to list all attributes strings * which are valid for this filesystem. If not * implemented the filesystem will not support * the 'file attributes' command. This allows * arbitrary additional information to be * attached to files in the filesystem. */ Tcl_FSFileAttrsGetProc *fileAttrsGetProc; /* Function to process a * 'Tcl_FSFileAttrsGet()' call, used by 'file * attributes'. */ Tcl_FSFileAttrsSetProc *fileAttrsSetProc; /* Function to process a * 'Tcl_FSFileAttrsSet()' call, used by 'file * attributes'. */ Tcl_FSCreateDirectoryProc *createDirectoryProc; /* Function to process a * 'Tcl_FSCreateDirectory()' call. Should be * implemented unless the FS is read-only. */ Tcl_FSRemoveDirectoryProc *removeDirectoryProc; /* Function to process a * 'Tcl_FSRemoveDirectory()' call. Should be * implemented unless the FS is read-only. */ Tcl_FSDeleteFileProc *deleteFileProc; /* Function to process a 'Tcl_FSDeleteFile()' * call. Should be implemented unless the FS * is read-only. */ Tcl_FSCopyFileProc *copyFileProc; /* Function to process a 'Tcl_FSCopyFile()' * call. If not implemented Tcl will fall back * on open-r, open-w and fcopy as a copying * mechanism, for copying actions initiated in * Tcl (not C). */ Tcl_FSRenameFileProc *renameFileProc; /* Function to process a 'Tcl_FSRenameFile()' * call. If not implemented, Tcl will fall * back on a copy and delete mechanism, for * rename actions initiated in Tcl (not C). */ Tcl_FSCopyDirectoryProc *copyDirectoryProc; /* Function to process a * 'Tcl_FSCopyDirectory()' call. If not * implemented, Tcl will fall back on a * recursive create-dir, file copy mechanism, * for copying actions initiated in Tcl (not * C). */ Tcl_FSLstatProc *lstatProc; /* Function to process a 'Tcl_FSLstat()' call. * If not implemented, Tcl will attempt to use * the 'statProc' defined above instead. */ Tcl_FSLoadFileProc *loadFileProc; /* Function to process a 'Tcl_FSLoadFile()' * call. If not implemented, Tcl will fall * back on a copy to native-temp followed by a * Tcl_FSLoadFile on that temporary copy. */ Tcl_FSGetCwdProc *getCwdProc; /* Function to process a 'Tcl_FSGetCwd()' * call. Most filesystems need not implement * this. It will usually only be called once, * if 'getcwd' is called before 'chdir'. May * be NULL. */ Tcl_FSChdirProc *chdirProc; /* Function to process a 'Tcl_FSChdir()' call. * If filesystems do not implement this, it * will be emulated by a series of directory * access checks. Otherwise, virtual * filesystems which do implement it need only * respond with a positive return result if * the dirName is a valid directory in their * filesystem. They need not remember the * result, since that will be automatically * remembered for use by GetCwd. Real * filesystems should 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; Tcl_WaitForEventProc *waitForEventProc; Tcl_CreateFileHandlerProc *createFileHandlerProc; Tcl_DeleteFileHandlerProc *deleteFileHandlerProc; Tcl_InitNotifierProc *initNotifierProc; Tcl_FinalizeNotifierProc *finalizeNotifierProc; Tcl_AlertNotifierProc *alertNotifierProc; Tcl_ServiceModeHookProc *serviceModeHookProc; } Tcl_NotifierProcs; /* * The following structure represents a user-defined encoding. It collects * together all the functions that are used by the specific encoding. */ typedef struct Tcl_EncodingType { CONST char *encodingName; /* The name of the encoding, e.g. "euc-jp". * This name is the unique key for this * encoding type. */ Tcl_EncodingConvertProc *toUtfProc; /* Function to convert from external encoding * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; /* Function to convert from UTF-8 into * external encoding. */ Tcl_EncodingFreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ ClientData clientData; /* Arbitrary value associated with encoding * type. Passed to conversion functions. */ int nullSize; /* Number of zero bytes that signify * end-of-string in this encoding. This number * is used to determine the source string * length when the srcLen argument is * negative. Must be 1 or 2. */ } Tcl_EncodingType; /* * The following definitions are used as values for the conversion control * flags argument when converting text from one character set to another: * * TCL_ENCODING_START - Signifies that the source buffer is the first * block in a (potentially multi-block) input * stream. Tells the conversion function to reset * to an initial state and perform any * initialization that needs to occur before the * first byte is converted. If the source buffer * contains the entire input stream to be * converted, this flag should be set. * TCL_ENCODING_END - Signifies that the source buffer is the last * block in a (potentially multi-block) input * stream. Tells the conversion routine to * perform any finalization that needs to occur * after the last byte is converted and then to * reset to an initial state. If the source * buffer contains the entire input stream to be * converted, this flag should be set. * TCL_ENCODING_STOPONERROR - If set, then the converter will return * immediately upon encountering an invalid byte * sequence or a source character that has no * mapping in the target encoding. If clear, then * the converter will skip the problem, * substituting one or more "close" characters in * the destination buffer and then continue to * convert the source. */ #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 #define TCL_ENCODING_STOPONERROR 0x04 /* * The following data structures and declarations are for the new Tcl parser. */ /* * 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; /* * Type values defined for Tcl_Token structures. These values are defined as * mask bits so that it's easy to check for collections of types. * * TCL_TOKEN_WORD - The token describes one word of a command, * from the first non-blank character of the word * (which may be " or {) up to but not including * the space, semicolon, or bracket that * terminates the word. NumComponents counts the * total number of sub-tokens that make up the * word. This includes, for example, sub-tokens * of TCL_TOKEN_VARIABLE tokens. * TCL_TOKEN_SIMPLE_WORD - This token is just like TCL_TOKEN_WORD except * that the word is guaranteed to consist of a * single TCL_TOKEN_TEXT sub-token. * TCL_TOKEN_TEXT - The token describes a range of literal text * that is part of a word. NumComponents is * always 0. * TCL_TOKEN_BS - The token describes a backslash sequence that * must be collapsed. NumComponents is always 0. * TCL_TOKEN_COMMAND - The token describes a command whose result * must be substituted into the word. The token * includes the enclosing brackets. NumComponents * is always 0. * TCL_TOKEN_VARIABLE - The token describes a variable substitution, * including the dollar sign, variable name, and * array index (if there is one) up through the * right parentheses. NumComponents tells how * many additional tokens follow to represent the * variable name. The first token will be a * TCL_TOKEN_TEXT token that describes the * variable name. If the variable is an array * reference then there will be one or more * additional tokens, of type TCL_TOKEN_TEXT, * TCL_TOKEN_BS, TCL_TOKEN_COMMAND, and * TCL_TOKEN_VARIABLE, that describe the array * index; numComponents counts the total number * of nested tokens that make up the variable * reference, including sub-tokens of * TCL_TOKEN_VARIABLE tokens. * TCL_TOKEN_SUB_EXPR - The token describes one subexpression of an * expression, from the first non-blank character * of the subexpression up to but not including * the space, brace, or bracket that terminates * the subexpression. NumComponents counts the * total number of following subtokens that make * up the subexpression; this includes all * subtokens for any nested TCL_TOKEN_SUB_EXPR * tokens. For example, a numeric value used as a * primitive operand is described by a * TCL_TOKEN_SUB_EXPR token followed by a * TCL_TOKEN_TEXT token. A binary subexpression * is described by a TCL_TOKEN_SUB_EXPR token * followed by the TCL_TOKEN_OPERATOR token for * the operator, then TCL_TOKEN_SUB_EXPR tokens * for the left then the right operands. * TCL_TOKEN_OPERATOR - The token describes one expression operator. * An operator might be the name of a math * function such as "abs". A TCL_TOKEN_OPERATOR * token is always preceeded by one * TCL_TOKEN_SUB_EXPR token for the operator's * subexpression, and is followed by zero or more * TCL_TOKEN_SUB_EXPR tokens for the operator's * operands. NumComponents is always 0. * TCL_TOKEN_EXPAND_WORD - This token is just like TCL_TOKEN_WORD except * that it marks a word that began with the * literal character prefix "{expand}". This word * is marked to be expanded - that is, broken * into words after substitution is complete. */ #define TCL_TOKEN_WORD 1 #define TCL_TOKEN_SIMPLE_WORD 2 #define TCL_TOKEN_TEXT 4 #define TCL_TOKEN_BS 8 #define TCL_TOKEN_COMMAND 16 #define TCL_TOKEN_VARIABLE 32 #define TCL_TOKEN_SUB_EXPR 64 #define TCL_TOKEN_OPERATOR 128 #define TCL_TOKEN_EXPAND_WORD 256 /* * Parsing error types. On any parsing error, one of these values will be * stored in the error field of the Tcl_Parse structure defined below. */ #define TCL_PARSE_SUCCESS 0 #define TCL_PARSE_QUOTE_EXTRA 1 #define TCL_PARSE_BRACE_EXTRA 2 #define TCL_PARSE_MISSING_BRACE 3 #define TCL_PARSE_MISSING_BRACKET 4 #define TCL_PARSE_MISSING_PAREN 5 #define TCL_PARSE_MISSING_QUOTE 6 #define TCL_PARSE_MISSING_VAR_BRACE 7 #define TCL_PARSE_SYNTAX 8 #define TCL_PARSE_BAD_NUMBER 9 /* * 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 the * words of the command. Initially points to * staticTokens, but may change to point to * malloc-ed space if command exceeds space in * staticTokens. */ int numTokens; /* Total number of tokens in command. */ int tokensAvailable; /* Total number of tokens available at * *tokenPtr. */ int errorType; /* One of the parsing error types defined * above. */ /* * The fields below are intended only for the private use of the parser. * They should not be used by functions 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. * This information is used by * Tcl_CommandComplete. */ Tcl_Token staticTokens[NUM_STATIC_TOKENS]; /* Initial space for tokens for command. This * space should be large enough to accommodate * most commands; dynamic space is allocated * for very large commands that don't fit * here. */ } Tcl_Parse; /* * The following definitions are the error codes returned by the conversion * routines: * * TCL_OK - All characters were converted. * TCL_CONVERT_NOSPACE - The output buffer would not have been large * enough for all of the converted data; as many * characters as could fit were converted though. * TCL_CONVERT_MULTIBYTE - The last few bytes in the source string were * the beginning of a multibyte sequence, but * more bytes were needed to complete this * sequence. A subsequent call to the conversion * routine should pass the beginning of this * unconverted sequence plus additional bytes * from the source stream to properly convert the * formerly split-up multibyte sequence. * TCL_CONVERT_SYNTAX - The source stream contained an invalid * character sequence. This may occur if the * input stream has been damaged or if the input * encoding method was misidentified. This error * is reported only if TCL_ENCODING_STOPONERROR * was specified. * TCL_CONVERT_UNKNOWN - The source string contained a character that * could not be represented in the target * encoding. This error is reported only if * TCL_ENCODING_STOPONERROR was specified. */ #define TCL_CONVERT_MULTIBYTE -1 #define TCL_CONVERT_SYNTAX -2 #define TCL_CONVERT_UNKNOWN -3 #define TCL_CONVERT_NOSPACE -4 /* * The maximum number of bytes that are necessary to represent a single * Unicode character in UTF-8. The valid values should be 3 or 6 (or perhaps 1 * if we want to support a non-unicode enabled core). If 3, then Tcl_UniChar * must be 2-bytes in size (UCS-2) (the default). If 6, then Tcl_UniChar must * be 4-bytes in size (UCS-4). At this time UCS-2 mode is the default and * recommended mode. UCS-4 is experimental and not recommended. It works for * the core, but most extensions expect UCS-2. */ #ifndef TCL_UTF_MAX #define TCL_UTF_MAX 3 #endif /* * This represents a Unicode character. Any changes to this should also be * reflected in regcustom.h. */ #if TCL_UTF_MAX > 3 /* * unsigned int isn't 100% accurate as it should be a strict 4-byte value * (perhaps wchar_t). 64-bit systems may have troubles. The size of this * value must be reflected correctly in regcustom.h. */ typedef unsigned int Tcl_UniChar; #else typedef unsigned short Tcl_UniChar; #endif /* * TIP #59: The following structure is used in calls 'Tcl_RegisterConfig' to * provide the system with the embedded configuration data. */ typedef struct Tcl_Config { CONST char *key; /* Configuration key to register. ASCII * encoded, thus UTF-8 */ CONST char *value; /* The value associated with the key. System * encoding */ } Tcl_Config; /* * Flags for TIP#143 limits, detailing which limits are active in an * interpreter. Used for Tcl_{Add,Remove}LimitHandler type argument. */ #define TCL_LIMIT_COMMANDS 0x01 #define TCL_LIMIT_TIME 0x02 /* * Structure containing information about a limit handler to be called when a * command- or time-limit is exceeded by an interpreter. */ typedef void (Tcl_LimitHandlerProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); typedef void (Tcl_LimitHandlerDeleteProc) _ANSI_ARGS_((ClientData clientData)); #ifndef MP_INT_DECLARED typedef struct mp_int mp_int; #define MP_INT_DECLARED #endif #ifndef MP_DIGIT_DECLARED typedef unsigned long mp_digit; #define MP_DIGIT_DECLARED #endif #ifndef TCL_NO_DEPRECATED /* * Deprecated Tcl functions: */ # define Tcl_EvalObj(interp,objPtr) \ Tcl_EvalObjEx((interp),(objPtr),0) # define Tcl_GlobalEvalObj(interp,objPtr) \ Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) /* * These function have been renamed. The old names are deprecated, but we * define these macros for backwards compatibilty. */ # define Tcl_Ckalloc Tcl_Alloc # define Tcl_Ckfree Tcl_Free # define Tcl_Ckrealloc Tcl_Realloc # define Tcl_Return Tcl_SetResult # define Tcl_TildeSubst Tcl_TranslateFileName # define panic Tcl_Panic # define panicVA Tcl_PanicVA #endif /* * The following constant is used to test for older versions of Tcl in the * stubs tables. * * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different * value since the stubs tables don't match. */ #define TCL_STUB_MAGIC ((int)0xFCA3BACF) /* * The following function is required to be defined in all stubs aware * extensions. The function is actually implemented in the stub library, not * the main Tcl library, although there is a trivial implementation in the * main library in case an extension is statically linked into an application. */ EXTERN CONST char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, CONST char *version, int exact)); #ifndef USE_TCL_STUBS |
︙ | ︙ | |||
2320 2321 2322 2323 2324 2325 2326 | /* * Public functions that are not accessible via the stubs table. */ EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, Tcl_AppInitProc *appInitProc)); | < | | | | | | | > > > > > > > > > > > > > > > > > > | 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 | /* * Public functions that are not accessible via the stubs table. */ EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, Tcl_AppInitProc *appInitProc)); /* * Include the public function declarations that are accessible via the stubs * table. */ #include "tclDecls.h" /* * Include platform specific public function declarations that are accessible * via the stubs table. */ #include "tclPlatDecls.h" /* * Convenience declaration of Tcl_AppInit for backwards compatibility. This * function is not *implemented* by the tcl library, so the storage class is * neither DLLEXPORT nor DLLIMPORT. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* RC_INVOKED */ /* * end block for C++ */ #ifdef __cplusplus } #endif #endif /* _TCL */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclAlloc.c.
|
| | | | | | | | | | | > | | > | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | < | | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | /* * tclAlloc.c -- * * This is a very fast storage allocator. It allocates blocks of a small * number of different sizes, and keeps free lists of each size. Blocks * that don't exactly fit are passed up to the next larger size. Blocks * over a certain size are directly allocated from the system. * * Copyright (c) 1983 Regents of the University of California. * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclAlloc.c,v 1.21.2.1 2005/08/02 18:15:09 dgp Exp $ */ /* * Windows and Unix use an alternative allocator when building with threads * that has significantly reduced lock contention. */ #include "tclInt.h" #if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC) #if USE_TCLALLOC #ifdef TCL_DEBUG # define DEBUG /* #define MSTATS */ # define RCHECK #endif /* * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait * until Tcl uses config.h properly. */ #if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__) typedef unsigned long caddr_t; #endif /* * The overhead on a block is at least 8 bytes. When free, this space contains * a pointer to the next free block, and the bottom two bits must be zero. * When in use, the first byte is set to MAGIC, and the second byte is the * size index. The remaining bytes are for alignment. If range checking is * enabled then a second word holds the size of the requested block, less 1, * rounded up to a multiple of sizeof(RMAGIC). The order of elements is * critical: ov.magic must overlay the low order bits of ov.next, and ov.magic * can not be a valid ov.next bit pattern. */ union overhead { union overhead *next; /* when free */ unsigned char padding[8]; /* Ensure the structure is 8-byte aligned. */ struct { unsigned char magic0; /* magic number */ unsigned char index; /* bucket # */ unsigned char unused; /* unused */ unsigned char magic1; /* other magic number */ #ifdef RCHECK unsigned short rmagic; /* range magic number */ unsigned long size; /* actual block size */ unsigned short unused2; /* padding to 8-byte align */ #endif } ovu; #define overMagic0 ovu.magic0 #define overMagic1 ovu.magic1 #define bucketIndex ovu.index #define rangeCheckMagic ovu.rmagic #define realBlockSize ovu.size }; #define MAGIC 0xef /* magic # on accounting info */ #define RMAGIC 0x5555 /* magic # on range info */ #ifdef RCHECK #define RSLOP sizeof (unsigned short) #else #define RSLOP 0 #endif #define OVERHEAD (sizeof(union overhead) + RSLOP) /* * Macro to make it easier to refer to the end-of-block guard magic. */ #define BLOCK_END(overPtr) \ (*(unsigned short *)((caddr_t)((overPtr) + 1) + (overPtr)->realBlockSize)) /* * nextf[i] is the pointer to the next free block of size 2^(i+3). The * smallest allocatable block is 8 bytes. The overhead information precedes * the data area returned to the user. */ #define NBUCKETS 13 #define MAXMALLOC (1<<(NBUCKETS+2)) static union overhead *nextf[NBUCKETS]; /* * The following structure is used to keep track of all system memory * currently owned by Tcl. When finalizing, all this memory will be returned * to the system. */ struct block { struct block *nextPtr; /* Linked list. */ struct block *prevPtr; /* Linked list for big blocks, ensures 8-byte * alignment for suballocated blocks. */ }; static struct block *blockList; /* Tracks the suballocated blocks. */ static struct block bigBlocks={ /* Big blocks aren't suballocated. */ &bigBlocks, &bigBlocks }; /* * The allocator is protected by a special mutex that must be explicitly * initialized. Futhermore, because Tcl_Alloc may be used before anything else * in Tcl, we make this module self-initializing after all with the allocInit * variable. */ #ifdef TCL_THREADS static Tcl_Mutex *allocMutexPtr; #endif static int allocInit = 0; #ifdef MSTATS /* * numMallocs[i] is the difference between the number of mallocs and frees for * a given block size. */ static unsigned int numMallocs[NBUCKETS+1]; #include <stdio.h> #endif #if defined(DEBUG) || defined(RCHECK) #define ASSERT(p) if (!(p)) Tcl_Panic(# p) #define RANGE_ASSERT(p) if (!(p)) Tcl_Panic(# p) #else #define ASSERT(p) #define RANGE_ASSERT(p) #endif /* * Prototypes for functions used only in this file. */ static void MoreCore _ANSI_ARGS_((int bucket)); /* *------------------------------------------------------------------------- * * TclInitAlloc -- * * Initialize the memory system. |
︙ | ︙ | |||
187 188 189 190 191 192 193 | } /* *------------------------------------------------------------------------- * * TclFinalizeAllocSubsystem -- * | | | | | | | | | | < | 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 | } /* *------------------------------------------------------------------------- * * TclFinalizeAllocSubsystem -- * * Release all resources being used by this subsystem, including * aggressively freeing all memory allocated by TclpAlloc() that has not * yet been released with TclpFree(). * * After this function is called, all memory allocated with TclpAlloc() * should be considered unusable. * * Results: * None. * * Side effects: * This subsystem is self-initializing, since memory can be allocated * before Tcl is formally initialized. After this call, this subsystem * has been reset to its initial state and is usable again. * *------------------------------------------------------------------------- */ void TclFinalizeAllocSubsystem() { |
︙ | ︙ | |||
227 228 229 230 231 232 233 | nextPtr = blockPtr->nextPtr; TclpSysFree(blockPtr); blockPtr = nextPtr; } bigBlocks.nextPtr = &bigBlocks; bigBlocks.prevPtr = &bigBlocks; | | | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 | nextPtr = blockPtr->nextPtr; TclpSysFree(blockPtr); blockPtr = nextPtr; } bigBlocks.nextPtr = &bigBlocks; bigBlocks.prevPtr = &bigBlocks; for (i=0 ; i<NBUCKETS ; i++) { nextf[i] = NULL; #ifdef MSTATS numMallocs[i] = 0; #endif } #ifdef MSTATS numMallocs[i] = 0; |
︙ | ︙ | |||
266 267 268 269 270 271 272 | register union overhead *overPtr; register long bucket; register unsigned amount; struct block *bigBlockPtr; if (!allocInit) { /* | | | < > > | > | > | < > > > | | | > > | | | > | > > > > | < > > | 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 | register union overhead *overPtr; register long bucket; register unsigned amount; struct block *bigBlockPtr; if (!allocInit) { /* * We have to make the "self initializing" because Tcl_Alloc may be * used before any other part of Tcl. E.g., see main() for tclsh! */ TclInitAlloc(); } Tcl_MutexLock(allocMutexPtr); /* * First the simple case: we simple allocate big blocks directly. */ if (numBytes + OVERHEAD >= MAXMALLOC) { bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) (sizeof(struct block) + OVERHEAD + numBytes), 0); if (bigBlockPtr == NULL) { Tcl_MutexUnlock(allocMutexPtr); return NULL; } bigBlockPtr->nextPtr = bigBlocks.nextPtr; bigBlocks.nextPtr = bigBlockPtr; bigBlockPtr->prevPtr = &bigBlocks; bigBlockPtr->nextPtr->prevPtr = bigBlockPtr; overPtr = (union overhead *) (bigBlockPtr + 1); overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; overPtr->bucketIndex = 0xff; #ifdef MSTATS numMallocs[NBUCKETS]++; #endif #ifdef RCHECK /* * Record allocated size of block and bound space with magic numbers. */ overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); overPtr->rangeCheckMagic = RMAGIC; BLOCK_END(overPtr) = RMAGIC; #endif Tcl_MutexUnlock(allocMutexPtr); return (void *)(overPtr+1); } /* * Convert amount of memory requested into closest block size stored in * hash buckets which satisfies request. Account for space used per block * for accounting. */ #ifndef RCHECK amount = 8; /* size of first bucket */ bucket = 0; #else amount = 16; /* size of first bucket */ bucket = 1; #endif while (numBytes + OVERHEAD > amount) { amount <<= 1; if (amount == 0) { Tcl_MutexUnlock(allocMutexPtr); return NULL; } bucket++; } ASSERT(bucket < NBUCKETS); /* * If nothing in hash bucket right now, request more memory from the * system. */ if ((overPtr = nextf[bucket]) == NULL) { MoreCore(bucket); if ((overPtr = nextf[bucket]) == NULL) { Tcl_MutexUnlock(allocMutexPtr); return NULL; } } /* * Remove from linked list */ nextf[bucket] = overPtr->next; overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; overPtr->bucketIndex = (unsigned char) bucket; #ifdef MSTATS numMallocs[bucket]++; #endif #ifdef RCHECK /* * Record allocated size of block and bound space with magic numbers. */ overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); overPtr->rangeCheckMagic = RMAGIC; BLOCK_END(overPtr) = RMAGIC; #endif Tcl_MutexUnlock(allocMutexPtr); return ((char *)(overPtr + 1)); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
390 391 392 393 394 395 396 | register union overhead *overPtr; register long size; /* size of desired block */ long amount; /* amount to allocate */ int numBlocks; /* how many blocks we get */ struct block *blockPtr; /* | | | > | | | < > | 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 | register union overhead *overPtr; register long size; /* size of desired block */ long amount; /* amount to allocate */ int numBlocks; /* how many blocks we get */ struct block *blockPtr; /* * sbrk_size <= 0 only for big, FLUFFY, requests (about 2^30 bytes on a * VAX, I think) or for a negative arg. */ size = 1 << (bucket + 3); ASSERT(size > 0); amount = MAXMALLOC; numBlocks = amount / size; ASSERT(numBlocks*size == amount); blockPtr = (struct block *) TclpSysAlloc((unsigned) (sizeof(struct block) + amount), 1); /* no more room! */ if (blockPtr == NULL) { return; } blockPtr->nextPtr = blockList; blockList = blockPtr; overPtr = (union overhead *) (blockPtr + 1); /* * Add new memory allocated to that on free list for this hash bucket. */ nextf[bucket] = overPtr; while (--numBlocks > 0) { overPtr->next = (union overhead *)((caddr_t)overPtr + size); overPtr = (union overhead *)((caddr_t)overPtr + size); } overPtr->next = (union overhead *)NULL; } |
︙ | ︙ | |||
442 443 444 445 446 447 448 | * *---------------------------------------------------------------------- */ void TclpFree(oldPtr) char *oldPtr; /* Pointer to memory to free. */ | | | 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 | * *---------------------------------------------------------------------- */ void TclpFree(oldPtr) char *oldPtr; /* Pointer to memory to free. */ { register long size; register union overhead *overPtr; struct block *bigBlockPtr; if (oldPtr == NULL) { return; } |
︙ | ︙ | |||
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 | RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC); RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC); size = overPtr->bucketIndex; if (size == 0xff) { #ifdef MSTATS numMallocs[NBUCKETS]--; #endif bigBlockPtr = (struct block *) overPtr - 1; bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr; bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr; TclpSysFree(bigBlockPtr); Tcl_MutexUnlock(allocMutexPtr); return; } ASSERT(size < NBUCKETS); overPtr->next = nextf[size]; /* also clobbers overMagic */ nextf[size] = overPtr; #ifdef MSTATS numMallocs[size]--; #endif Tcl_MutexUnlock(allocMutexPtr); } /* *---------------------------------------------------------------------- * * TclpRealloc -- | > > > > | 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 | RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC); RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC); size = overPtr->bucketIndex; if (size == 0xff) { #ifdef MSTATS numMallocs[NBUCKETS]--; #endif bigBlockPtr = (struct block *) overPtr - 1; bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr; bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr; TclpSysFree(bigBlockPtr); Tcl_MutexUnlock(allocMutexPtr); return; } ASSERT(size < NBUCKETS); overPtr->next = nextf[size]; /* also clobbers overMagic */ nextf[size] = overPtr; #ifdef MSTATS numMallocs[size]--; #endif Tcl_MutexUnlock(allocMutexPtr); } /* *---------------------------------------------------------------------- * * TclpRealloc -- |
︙ | ︙ | |||
504 505 506 507 508 509 510 | *---------------------------------------------------------------------- */ char * TclpRealloc(oldPtr, numBytes) char *oldPtr; /* Pointer to alloced block. */ unsigned int numBytes; /* New size of memory. */ | | | | 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 | *---------------------------------------------------------------------- */ char * TclpRealloc(oldPtr, numBytes) char *oldPtr; /* Pointer to alloced block. */ unsigned int numBytes; /* New size of memory. */ { int i; union overhead *overPtr; struct block *bigBlockPtr; int expensive; unsigned long maxSize; if (oldPtr == NULL) { return TclpAlloc(numBytes); } Tcl_MutexLock(allocMutexPtr); overPtr = (union overhead *)((caddr_t)oldPtr - sizeof (union overhead)); ASSERT(overPtr->overMagic0 == MAGIC); /* make sure it was in use */ |
︙ | ︙ | |||
539 540 541 542 543 544 545 | */ if (i == 0xff) { struct block *prevPtr, *nextPtr; bigBlockPtr = (struct block *) overPtr - 1; prevPtr = bigBlockPtr->prevPtr; nextPtr = bigBlockPtr->nextPtr; | | | | > > > | 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 | */ if (i == 0xff) { struct block *prevPtr, *nextPtr; bigBlockPtr = (struct block *) overPtr - 1; prevPtr = bigBlockPtr->prevPtr; nextPtr = bigBlockPtr->nextPtr; bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr, sizeof(struct block) + OVERHEAD + numBytes); if (bigBlockPtr == NULL) { Tcl_MutexUnlock(allocMutexPtr); return NULL; } if (prevPtr->nextPtr != bigBlockPtr) { /* * If the block has moved, splice the new block into the list * where the old block used to be. */ prevPtr->nextPtr = bigBlockPtr; nextPtr->prevPtr = bigBlockPtr; } overPtr = (union overhead *) (bigBlockPtr + 1); #ifdef MSTATS numMallocs[NBUCKETS]++; #endif #ifdef RCHECK /* * Record allocated size of block and update magic number bounds. */ overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif Tcl_MutexUnlock(allocMutexPtr); return (char *)(overPtr+1); } maxSize = 1 << (i+3); expensive = 0; if (numBytes+OVERHEAD > maxSize) { expensive = 1; |
︙ | ︙ | |||
596 597 598 599 600 601 602 | if (maxSize < numBytes) { numBytes = maxSize; } memcpy((VOID *) newPtr, (VOID *) oldPtr, (size_t) numBytes); TclpFree(oldPtr); return newPtr; } | | > > | | | | > > > | > | 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 | if (maxSize < numBytes) { numBytes = maxSize; } memcpy((VOID *) newPtr, (VOID *) oldPtr, (size_t) numBytes); TclpFree(oldPtr); return newPtr; } /* * Ok, we don't have to copy, it fits as-is */ #ifdef RCHECK overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif Tcl_MutexUnlock(allocMutexPtr); return(oldPtr); } /* *---------------------------------------------------------------------- * * mstats -- * * Prints two lines of numbers, one showing the length of the free list * for each size category, the second showing the number of mallocs - * frees for each size category. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ #ifdef MSTATS void mstats(s) char *s; /* Where to write info. */ { register int i, j; register union overhead *overPtr; int totalFree = 0, totalUsed = 0; Tcl_MutexLock(allocMutexPtr); fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); for (i = 0; i < NBUCKETS; i++) { for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) { fprintf(stderr, " %d", j); } totalFree += j * (1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { fprintf(stderr, " %d", numMallocs[i]); totalUsed += numMallocs[i] * (1 << (i + 3)); } fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", totalUsed, totalFree); fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", MAXMALLOC, numMallocs[NBUCKETS]); Tcl_MutexUnlock(allocMutexPtr); } #endif #else /* !USE_TCLALLOC */ /* |
︙ | ︙ | |||
700 701 702 703 704 705 706 | * *---------------------------------------------------------------------- */ void TclpFree(oldPtr) char *oldPtr; /* Pointer to memory to free. */ | | | 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 | * *---------------------------------------------------------------------- */ void TclpFree(oldPtr) char *oldPtr; /* Pointer to memory to free. */ { free(oldPtr); return; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
725 726 727 728 729 730 731 | *---------------------------------------------------------------------- */ char * TclpRealloc(oldPtr, numBytes) char *oldPtr; /* Pointer to alloced block. */ unsigned int numBytes; /* New size of memory. */ | | > > > > > > > > | 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 | *---------------------------------------------------------------------- */ char * TclpRealloc(oldPtr, numBytes) char *oldPtr; /* Pointer to alloced block. */ unsigned int numBytes; /* New size of memory. */ { return (char*) realloc(oldPtr, numBytes); } #endif /* !USE_TCLALLOC */ #endif /* !TCL_THREADS */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclAsync.c.
|
| | | | | < | | | | < | | | | > | | | | | | | | | | < < | | | | | | < | | | > | < < < < < | | | < | < < | | < | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | /* * tclAsync.c -- * * This file provides low-level support needed to invoke signal handlers * in a safe way. The code here doesn't actually handle signals, though. * This code is based on proposals made by Mark Diekhans and Don Libes. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclAsync.c,v 1.7.2.1 2005/08/02 18:15:10 dgp Exp $ */ #include "tclInt.h" /* Forward declaration */ struct ThreadSpecificData; /* * One of the following structures exists for each asynchronous handler: */ typedef struct AsyncHandler { int ready; /* Non-zero means this handler should be * invoked in the next call to * Tcl_AsyncInvoke. */ struct AsyncHandler *nextPtr; /* Next in list of all handlers for the * process. */ Tcl_AsyncProc *proc; /* Procedure to call when handler is * invoked. */ ClientData clientData; /* Value to pass to handler when it is * invoked. */ struct ThreadSpecificData *originTsd; /* Used in Tcl_AsyncMark to modify thread- * specific data from outside the thread it is * associated to. */ Tcl_ThreadId originThrdId; /* Origin thread where this token was created * and where it will be yielded. */ } AsyncHandler; typedef struct ThreadSpecificData { /* * The variables below maintain a list of all existing handlers specific * to the calling thread. */ AsyncHandler *firstHandler; /* First handler defined for process, or NULL * if none. */ AsyncHandler *lastHandler; /* Last handler or NULL. */ int asyncReady; /* This is set to 1 whenever a handler becomes * ready and it is cleared to zero whenever * Tcl_AsyncInvoke is called. It can be * checked elsewhere in the application by * calling Tcl_AsyncReady to see if * Tcl_AsyncInvoke should be invoked. */ int asyncActive; /* Indicates whether Tcl_AsyncInvoke is * currently working. If so then we won't set * asyncReady again until Tcl_AsyncInvoke * returns. */ Tcl_Mutex asyncMutex; /* Thread-specific AsyncHandler linked-list * lock */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* *---------------------------------------------------------------------- * * TclFinalizeAsync -- * * Finalizes the mutex in the thread local data structure for the async * subsystem. * * Results: * None. * * Side effects: * Forgets knowledge of the mutex should it have been created. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
106 107 108 109 110 111 112 | /* *---------------------------------------------------------------------- * * Tcl_AsyncCreate -- * * This procedure creates the data structures for an asynchronous | | | | | | | | | 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 | /* *---------------------------------------------------------------------- * * Tcl_AsyncCreate -- * * This procedure creates the data structures for an asynchronous * handler, so that no memory has to be allocated when the handler is * activated. * * Results: * The return value is a token for the handler, which can be used to * activate it later on. * * Side effects: * Information about the handler is recorded. * *---------------------------------------------------------------------- */ Tcl_AsyncHandler Tcl_AsyncCreate(proc, clientData) Tcl_AsyncProc *proc; /* Procedure to call when handler is * invoked. */ ClientData clientData; /* Argument to pass to handler. */ { AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler)); asyncPtr->ready = 0; asyncPtr->nextPtr = NULL; |
︙ | ︙ | |||
152 153 154 155 156 157 158 | } /* *---------------------------------------------------------------------- * * Tcl_AsyncMark -- * | | | | | | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | } /* *---------------------------------------------------------------------- * * Tcl_AsyncMark -- * * This procedure is called to request that an asynchronous handler be * invoked as soon as possible. It's typically called from an interrupt * handler, where it isn't safe to do anything that depends on or * modifies application state. * * Results: * None. * * Side effects: * The handler gets marked for invocation later. * |
︙ | ︙ | |||
186 187 188 189 190 191 192 | } /* *---------------------------------------------------------------------- * * Tcl_AsyncInvoke -- * | | | | | < | | | < | | | | | | < | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_AsyncInvoke -- * * This procedure is called at a "safe" time at background level to * invoke any active asynchronous handlers. * * Results: * The return value is a normal Tcl result, which is intended to replace * the code argument as the current completion code for interp. * * Side effects: * Depends on the handlers that are active. * *---------------------------------------------------------------------- */ int Tcl_AsyncInvoke(interp, code) Tcl_Interp *interp; /* If invoked from Tcl_Eval just after * completing a command, points to * interpreter. Otherwise it is NULL. */ int code; /* If interp is non-NULL, this gives * completion code from command that just * completed. */ { AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_MutexLock(&tsdPtr->asyncMutex); if (tsdPtr->asyncReady == 0) { Tcl_MutexUnlock(&tsdPtr->asyncMutex); return code; } tsdPtr->asyncReady = 0; tsdPtr->asyncActive = 1; if (interp == NULL) { code = 0; } /* * Make one or more passes over the list of handlers, invoking at most one * handler in each pass. After invoking a handler, go back to the start of * the list again so that (a) if a new higher-priority handler gets marked * while executing a lower priority handler, we execute the higher- * priority handler next, and (b) if a handler gets deleted during the * execution of a handler, then the list structure may change so it isn't * safe to continue down the list anyway. */ while (1) { for (asyncPtr = tsdPtr->firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->ready) { |
︙ | ︙ | |||
261 262 263 264 265 266 267 | } /* *---------------------------------------------------------------------- * * Tcl_AsyncDelete -- * | | | | 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | } /* *---------------------------------------------------------------------- * * Tcl_AsyncDelete -- * * Frees up all the state for an asynchronous handler. The handler should * never be used again. * * Results: * None. * * Side effects: * The state associated with the handler is deleted. * |
︙ | ︙ | |||
306 307 308 309 310 311 312 | } /* *---------------------------------------------------------------------- * * Tcl_AsyncReady -- * | | | | | | > > > > > > > > | 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 | } /* *---------------------------------------------------------------------- * * Tcl_AsyncReady -- * * This procedure can be used to tell whether Tcl_AsyncInvoke needs to be * called. This procedure is the external interface for checking the * thread-specific asyncReady variable. * * Results: * The return value is 1 whenever a handler is ready and is 0 when no * handlers are ready. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_AsyncReady() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); return tsdPtr->asyncReady; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclBasic.c.
1 2 3 4 | /* * tclBasic.c -- * * Contains the basic facilities for TCL command interpretation, | | | | | | > > > > > > > > > > > > > > > < | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | 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 | /* * tclBasic.c -- * * Contains the basic facilities for TCL command interpretation, * including interpreter creation and deletion, command creation and * deletion, and command/script execution. * * Copyright (c) 1987-1994 The Regents of the University of California. * 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.136.2.39 2005/10/04 13:49:36 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" #include <float.h> #include <math.h> #include "tommath.h" /* * The following structure defines the client data for a math function * registered with Tcl_CreateMathFunc */ typedef struct OldMathFuncData { Tcl_MathProc* proc; /* Handler procedure */ int numArgs; /* Number of args expected */ Tcl_ValueType* argTypes; /* Types of the args */ ClientData clientData; /* Client data for the handler function */ } OldMathFuncData; /* * Static procedures in this file: */ static char * CallCommandTraces (Interp *iPtr, Command *cmdPtr, CONST char *oldName, CONST char* newName, int flags); static int CheckDoubleResult (Tcl_Interp *interp, double dResult); static void DeleteInterpProc (Tcl_Interp *interp); static void ProcessUnexpectedResult (Tcl_Interp *interp, int returnCode); static int OldMathFuncProc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static void OldMathFuncDeleteProc (ClientData clientData); static int ExprAbsFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static int ExprBinaryFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static int ExprBoolFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static int ExprCeilFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static int ExprDoubleFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static int ExprEntierFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static int ExprFloorFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static int ExprIntFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static int ExprRandFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static int ExprRoundFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static int ExprSqrtFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static int ExprSrandFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static int ExprUnaryFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static int ExprWideFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); static void MathFuncWrongNumArgs (Tcl_Interp* interp, int expected, int actual, Tcl_Obj *CONST *objv); extern TclStubs tclStubs; /* * The following structure defines the commands in the Tcl core. */ typedef struct { char *name; /* Name of object-based command. */ Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */ CompileProc *compileProc; /* Procedure called to compile command. */ int isSafe; /* If non-zero, command will be present in * safe interpreter. Otherwise it will be * hidden. */ } CmdInfo; /* * The built-in commands, and the procedures that implement them: */ static CmdInfo builtInCmds[] = { /* * Commands in the generic core. */ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, 1}, {"array", Tcl_ArrayObjCmd, (CompileProc *) NULL, 1}, {"binary", Tcl_BinaryObjCmd, (CompileProc *) NULL, 1}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, 1}, {"case", Tcl_CaseObjCmd, (CompileProc *) NULL, 1}, {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, 1}, {"concat", Tcl_ConcatObjCmd, (CompileProc *) NULL, 1}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, 1}, {"dict", Tcl_DictObjCmd, TclCompileDictCmd, 1}, {"encoding", Tcl_EncodingObjCmd, (CompileProc *) NULL, 0}, {"error", Tcl_ErrorObjCmd, (CompileProc *) NULL, 1}, {"eval", Tcl_EvalObjCmd, (CompileProc *) NULL, 1}, {"exit", Tcl_ExitObjCmd, (CompileProc *) NULL, 0}, {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, 1}, {"fcopy", Tcl_FcopyObjCmd, (CompileProc *) NULL, 1}, {"fileevent", Tcl_FileEventObjCmd, (CompileProc *) NULL, 1}, |
︙ | ︙ | |||
140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 | {"vwait", Tcl_VwaitObjCmd, (CompileProc *) NULL, 1}, {"exec", Tcl_ExecObjCmd, (CompileProc *) NULL, 0}, {"source", Tcl_SourceObjCmd, (CompileProc *) NULL, 0}, #endif /* TCL_GENERIC_ONLY */ {NULL, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0} }; /* *---------------------------------------------------------------------- * * Tcl_CreateInterp -- * * Create a new TCL command interpreter. * * Results: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | < | | | < < > | | | | | | < | | 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 | {"vwait", Tcl_VwaitObjCmd, (CompileProc *) NULL, 1}, {"exec", Tcl_ExecObjCmd, (CompileProc *) NULL, 0}, {"source", Tcl_SourceObjCmd, (CompileProc *) NULL, 0}, #endif /* TCL_GENERIC_ONLY */ {NULL, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0} }; /* * Math functions */ typedef struct { CONST char* name; /* Name of the function */ Tcl_ObjCmdProc* objCmdProc; /* Procedure that evaluates the function */ ClientData clientData; /* Client data for the procedure */ } BuiltinFuncDef; static BuiltinFuncDef BuiltinFuncTable[] = { { "::tcl::mathfunc::abs", ExprAbsFunc, NULL }, { "::tcl::mathfunc::acos", ExprUnaryFunc, (ClientData) acos }, { "::tcl::mathfunc::asin", ExprUnaryFunc, (ClientData) asin }, { "::tcl::mathfunc::atan", ExprUnaryFunc, (ClientData) atan }, { "::tcl::mathfunc::atan2", ExprBinaryFunc, (ClientData) atan2 }, { "::tcl::mathfunc::bool", ExprBoolFunc, NULL }, { "::tcl::mathfunc::ceil", ExprCeilFunc, NULL }, { "::tcl::mathfunc::cos", ExprUnaryFunc, (ClientData) cos }, { "::tcl::mathfunc::cosh", ExprUnaryFunc, (ClientData) cosh }, { "::tcl::mathfunc::double",ExprDoubleFunc, NULL }, { "::tcl::mathfunc::entier",ExprEntierFunc, NULL }, { "::tcl::mathfunc::exp", ExprUnaryFunc, (ClientData) exp }, { "::tcl::mathfunc::floor", ExprFloorFunc, NULL }, { "::tcl::mathfunc::fmod", ExprBinaryFunc, (ClientData) fmod }, { "::tcl::mathfunc::hypot", ExprBinaryFunc, (ClientData) hypot }, { "::tcl::mathfunc::int", ExprIntFunc, NULL }, { "::tcl::mathfunc::log", ExprUnaryFunc, (ClientData) log }, { "::tcl::mathfunc::log10", ExprUnaryFunc, (ClientData) log10 }, { "::tcl::mathfunc::pow", ExprBinaryFunc, (ClientData) pow }, { "::tcl::mathfunc::rand", ExprRandFunc, NULL }, { "::tcl::mathfunc::round", ExprRoundFunc, NULL }, { "::tcl::mathfunc::sin", ExprUnaryFunc, (ClientData) sin }, { "::tcl::mathfunc::sinh", ExprUnaryFunc, (ClientData) sinh }, { "::tcl::mathfunc::sqrt", ExprSqrtFunc, NULL }, { "::tcl::mathfunc::srand", ExprSrandFunc, NULL }, { "::tcl::mathfunc::tan", ExprUnaryFunc, (ClientData) tan }, { "::tcl::mathfunc::tanh", ExprUnaryFunc, (ClientData) tanh }, { "::tcl::mathfunc::wide", ExprWideFunc, NULL }, { NULL, NULL, NULL } }; /* *---------------------------------------------------------------------- * * Tcl_CreateInterp -- * * Create a new TCL command interpreter. * * Results: * The return value is a token for the interpreter, which may be used in * calls to procedures like Tcl_CreateCmd, Tcl_Eval, or Tcl_DeleteInterp. * * Side effects: * The command interpreter is initialized with the built-in commands and * with the variables documented in tclvars(n). * *---------------------------------------------------------------------- */ Tcl_Interp * Tcl_CreateInterp() { Interp *iPtr; Tcl_Interp *interp; Command *cmdPtr; BuiltinFuncDef *builtinFuncPtr; const CmdInfo *cmdInfoPtr; Tcl_Namespace* mathfuncNSPtr; int i; union { char c[sizeof(short)]; short s; } order; #ifdef TCL_COMPILE_STATS ByteCodeStats *statsPtr; #endif /* TCL_COMPILE_STATS */ TclInitSubsystems(); /* * Panic if someone updated the CallFrame structure without also updating * the Tcl_CallFrame structure (or vice versa). */ if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) { /*NOTREACHED*/ Tcl_Panic("Tcl_CallFrame and CallFrame are not the same size"); } /* * Initialize support for namespaces and create the global namespace * (whose name is ""; an alias is "::"). This also initializes the Tcl * object type table and other object management code. */ iPtr = (Interp *) ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; iPtr->result = iPtr->resultSpace; iPtr->freeProc = NULL; iPtr->errorLine = 0; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); iPtr->globalNsPtr = NULL; iPtr->hiddenCmdTablePtr = NULL; iPtr->interpInfo = NULL; iPtr->numLevels = 0; iPtr->maxNestingDepth = MAX_NESTING_DEPTH; iPtr->framePtr = NULL; iPtr->varFramePtr = NULL; iPtr->activeVarTracePtr = NULL; iPtr->returnOpts = NULL; iPtr->errorInfo = NULL; iPtr->eiVar = Tcl_NewStringObj("errorInfo", -1); Tcl_IncrRefCount(iPtr->eiVar); iPtr->errorCode = NULL; iPtr->ecVar = Tcl_NewStringObj("errorCode", -1); Tcl_IncrRefCount(iPtr->ecVar); iPtr->returnLevel = 1; iPtr->returnCode = TCL_OK; iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); |
︙ | ︙ | |||
246 247 248 249 250 251 252 | iPtr->scriptFile = NULL; iPtr->flags = 0; iPtr->tracePtr = NULL; iPtr->tracesForbiddingInline = 0; iPtr->activeCmdTracePtr = NULL; iPtr->activeInterpTracePtr = NULL; iPtr->assocData = (Tcl_HashTable *) NULL; | | | | | > > > > > > | 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 | iPtr->scriptFile = NULL; iPtr->flags = 0; iPtr->tracePtr = NULL; iPtr->tracesForbiddingInline = 0; iPtr->activeCmdTracePtr = NULL; iPtr->activeInterpTracePtr = NULL; iPtr->assocData = (Tcl_HashTable *) NULL; iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ Tcl_IncrRefCount(iPtr->emptyObjPtr); iPtr->resultSpace[0] = 0; iPtr->globalNsPtr = NULL; /* force creation of global ns below */ iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); if (iPtr->globalNsPtr == NULL) { Tcl_Panic("Tcl_CreateInterp: can't create global namespace"); } /* * Initialize support for code compilation and execution. We call * TclCreateExecEnv after initializing namespaces since it tries to * reference a Tcl variable (it links to the Tcl "tcl_traceExec" * variable). */ iPtr->execEnvPtr = TclCreateExecEnv(interp); /* * TIP #219, Tcl Channel Reflection API support. */ iPtr->chanMsg = NULL; /* * Initialize the compilation and execution statistics kept for this * interpreter. */ #ifdef TCL_COMPILE_STATS statsPtr = &(iPtr->stats); |
︙ | ︙ | |||
289 290 291 292 293 294 295 | statsPtr->currentSrcBytes = 0.0; statsPtr->currentByteCodeBytes = 0.0; (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); (VOID *) memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount)); (VOID *) memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount)); | | | | < | | 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 | statsPtr->currentSrcBytes = 0.0; statsPtr->currentByteCodeBytes = 0.0; (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); (VOID *) memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount)); (VOID *) memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount)); statsPtr->currentInstBytes = 0.0; statsPtr->currentLitBytes = 0.0; statsPtr->currentExceptBytes = 0.0; statsPtr->currentAuxBytes = 0.0; statsPtr->currentCmdMapBytes = 0.0; statsPtr->numLiteralsCreated = 0; statsPtr->totalLitStringBytes = 0.0; statsPtr->currentLitStringBytes = 0.0; (VOID *) memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); #endif /* TCL_COMPILE_STATS */ /* * Initialise the stub table pointer. */ iPtr->stubTable = &tclStubs; |
︙ | ︙ | |||
325 326 327 328 329 330 331 | * TIP#143: Initialise the resource limit support. */ TclInitLimitSupport(interp); /* * Create the core commands. Do it here, rather than calling | | | | | | | | | | | | 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 | * TIP#143: Initialise the resource limit support. */ TclInitLimitSupport(interp); /* * Create the core commands. Do it here, rather than calling * Tcl_CreateCommand, because it's faster (there's no need to check for a * pre-existing command by the same name). If a command has a Tcl_CmdProc * but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to * TclInvokeStringCommand. This is an object-based wrapper procedure that * extracts strings, calls the string procedure, and creates an object for * the result. Similarly, if a command has a Tcl_ObjCmdProc but no * Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. */ for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { int new; Tcl_HashEntry *hPtr; if ((cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) { Tcl_Panic("Tcl_CreateInterp: builtin command with NULL object command proc and a NULL compile proc\n"); } hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, cmdInfoPtr->name, &new); if (new) { cmdPtr = (Command *) ckalloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = iPtr->globalNsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = cmdInfoPtr->compileProc; |
︙ | ︙ | |||
366 367 368 369 370 371 372 | cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; Tcl_SetHashValue(hPtr, cmdPtr); } } /* | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > | > > > > > > > > > > > | | > > > > > > > > > > > > | > | < < < < | < < | | | < > > > | | 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 | cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; Tcl_SetHashValue(hPtr, cmdPtr); } } /* * Register clock and chan subcommands. These *do* go through * Tcl_CreateObjCommand, since they aren't in the global namespace. */ Tcl_CreateObjCommand(interp, "::tcl::clock::clicks", TclClockClicksObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "::tcl::clock::getenv", TclClockGetenvObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "::tcl::clock::microseconds", TclClockMicrosecondsObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "::tcl::clock::milliseconds", TclClockMillisecondsObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "::tcl::clock::seconds", TclClockSecondsObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "::tcl::clock::Localtime", TclClockLocaltimeObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "::tcl::clock::Mktime", TclClockMktimeObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "::tcl::clock::Oldscan", TclClockOldscanObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); /* TIP #208 */ Tcl_CreateObjCommand(interp, "::tcl::chan::Truncate", TclChanTruncateObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); /* TIP #219 */ Tcl_CreateObjCommand(interp, "::tcl::chan::rCreate", TclChanCreateObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand(interp, "::tcl::chan::rPostevent", TclChanPostEventObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); /* * Register the built-in functions */ /* * Register the default [interp bgerror] handler. */ Tcl_CreateObjCommand(interp, "::tcl::Bgerror", TclDefaultBgErrorHandlerObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); /* * Register the unsupported encoding search path command. */ Tcl_CreateObjCommand(interp, "::tcl::unsupported::EncodingDirs", TclEncodingDirsObjCmd, NULL, NULL); /* * Register the builtin math functions. */ mathfuncNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", (ClientData) NULL, (Tcl_NamespaceDeleteProc*) NULL); if (mathfuncNSPtr == NULL) { Tcl_Panic("Can't create math function namespace"); } i = 0; for (;;) { CONST char* tail; builtinFuncPtr = &(BuiltinFuncTable[i++]); if (builtinFuncPtr->name == NULL) { break; } Tcl_CreateObjCommand(interp, builtinFuncPtr->name, builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, (Tcl_CmdDeleteProc*) NULL); tail = builtinFuncPtr->name + strlen("::tcl::mathfunc::"); Tcl_Export(interp, mathfuncNSPtr, tail, 0); } /* * Do Multiple/Safe Interps Tcl init stuff */ TclInterpInit(interp); #ifndef TCL_GENERIC_ONLY TclSetupEnv(interp); #endif /* * TIP #59: Make embedded configuration information * available. */ TclInitEmbeddedConfigurationInformation(interp); /* * Compute the byte order of this machine. */ order.s = 1; Tcl_SetVar2(interp, "tcl_platform", "byteOrder", |
︙ | ︙ | |||
464 465 466 467 468 469 470 | Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, (ClientData) NULL); TclpSetVariables(interp); #ifdef TCL_THREADS /* | | | | | | < | | < | | | | | | | < | | | | < | | > | < | < < | | < | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | 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 | Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, (ClientData) NULL); TclpSetVariables(interp); #ifdef TCL_THREADS /* * The existence of the "threaded" element of the tcl_platform array * indicates that this particular Tcl shell has been compiled with threads * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can * introspect on the interpreter level of thread safety. */ Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY); #endif /* * Register Tcl's version number. */ Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); #ifdef Tcl_InitStubs #undef Tcl_InitStubs #endif Tcl_InitStubs(interp, TCL_VERSION, 1); return interp; } /* *---------------------------------------------------------------------- * * TclHideUnsafeCommands -- * * Hides base commands that are not marked as safe from this interpreter. * * Results: * TCL_OK if it succeeds, TCL_ERROR else. * * Side effects: * Hides functionality in an interpreter. * *---------------------------------------------------------------------- */ int TclHideUnsafeCommands(interp) Tcl_Interp *interp; /* Hide commands in this interpreter. */ { register const CmdInfo *cmdInfoPtr; if (interp == (Tcl_Interp *) NULL) { return TCL_ERROR; } for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { if (!cmdInfoPtr->isSafe) { Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } return TCL_OK; } /* *-------------------------------------------------------------- * * Tcl_CallWhenDeleted -- * * Arrange for a procedure to be called before a given interpreter is * deleted. The procedure is called as soon as Tcl_DeleteInterp is * called; if Tcl_CallWhenDeleted is called on an interpreter that has * already been deleted, the procedure will be called when the last * Tcl_Release is done on the interpreter. * * Results: * None. * * Side effects: * When Tcl_DeleteInterp is invoked to delete interp, proc will be * invoked. See the manual entry for details. * *-------------------------------------------------------------- */ void Tcl_CallWhenDeleted(interp, proc, clientData) Tcl_Interp *interp; /* Interpreter to watch. */ Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter is about * to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; static Tcl_ThreadDataKey assocDataCounterKey; int *assocDataCounterPtr = Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); int new; char buffer[32 + TCL_INTEGER_SPACE]; AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr); (*assocDataCounterPtr)++; if (iPtr->assocData == (Tcl_HashTable *) NULL) { iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); dPtr->proc = proc; dPtr->clientData = clientData; Tcl_SetHashValue(hPtr, dPtr); } /* *-------------------------------------------------------------- * * Tcl_DontCallWhenDeleted -- * * Cancel the arrangement for a procedure to be called when a given * interpreter is deleted. * * Results: * None. * * Side effects: * If proc and clientData were previously registered as a callback via * Tcl_CallWhenDeleted, they are unregistered. If they weren't previously * registered then nothing happens. * *-------------------------------------------------------------- */ void Tcl_DontCallWhenDeleted(interp, proc, clientData) Tcl_Interp *interp; /* Interpreter to watch. */ Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter is about * to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTablePtr; Tcl_HashSearch hSearch; Tcl_HashEntry *hPtr; AssocData *dPtr; hTablePtr = iPtr->assocData; if (hTablePtr == (Tcl_HashTable *) NULL) { return; } for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { dPtr = (AssocData *) Tcl_GetHashValue(hPtr); if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { ckfree((char *) dPtr); Tcl_DeleteHashEntry(hPtr); return; } } } /* *---------------------------------------------------------------------- * * Tcl_SetAssocData -- * * Creates a named association between user-specified data, a delete * function and this interpreter. If the association already exists the * data is overwritten with the new data. The delete function will be * invoked when the interpreter is deleted. * * Results: * None. * * Side effects: * Sets the associated data, creates the association if needed. * *---------------------------------------------------------------------- */ void Tcl_SetAssocData(interp, name, proc, clientData) Tcl_Interp *interp; /* Interpreter to associate with. */ CONST char *name; /* Name for association. */ Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is about to * be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; int new; if (iPtr->assocData == (Tcl_HashTable *) NULL) { iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); if (new == 0) { dPtr = (AssocData *) Tcl_GetHashValue(hPtr); } else { dPtr = (AssocData *) ckalloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; Tcl_SetHashValue(hPtr, dPtr); } /* *---------------------------------------------------------------------- * * Tcl_DeleteAssocData -- * * Deletes a named association of user-specified data with the specified * interpreter. * * Results: * None. * * Side effects: * Deletes the association. * *---------------------------------------------------------------------- */ void Tcl_DeleteAssocData(interp, name) Tcl_Interp *interp; /* Interpreter to associate with. */ CONST char *name; /* Name of association. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; if (iPtr->assocData == (Tcl_HashTable *) NULL) { return; } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); if (hPtr == (Tcl_HashEntry *) NULL) { return; } dPtr = (AssocData *) Tcl_GetHashValue(hPtr); if (dPtr->proc != NULL) { (dPtr->proc) (dPtr->clientData, interp); } ckfree((char *) dPtr); Tcl_DeleteHashEntry(hPtr); } /* *---------------------------------------------------------------------- * * Tcl_GetAssocData -- * * Returns the client data associated with this name in the specified * interpreter. * * Results: * The client data in the AssocData record denoted by the named * association, or NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ ClientData Tcl_GetAssocData(interp, name, procPtr) Tcl_Interp *interp; /* Interpreter associated with. */ CONST char *name; /* Name of association. */ Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address of * current deletion callback. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; if (iPtr->assocData == (Tcl_HashTable *) NULL) { return (ClientData) NULL; } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); if (hPtr == (Tcl_HashEntry *) NULL) { return (ClientData) NULL; } dPtr = (AssocData *) Tcl_GetHashValue(hPtr); if (procPtr != (Tcl_InterpDeleteProc **) NULL) { *procPtr = dPtr->proc; } return dPtr->clientData; } /* *---------------------------------------------------------------------- * * Tcl_InterpDeleted -- * * Returns nonzero if the interpreter has been deleted with a call to * Tcl_DeleteInterp. * * Results: * Nonzero if the interpreter is deleted, zero otherwise. * * Side effects: * None. * |
︙ | ︙ | |||
787 788 789 790 791 792 793 | } /* *---------------------------------------------------------------------- * * Tcl_DeleteInterp -- * | | | | | | | | | | > > > > > > > > | < | | | | | | | | | | | | | | | < | | | | | | < < < < < < < < < < | | | | | | | | | | | | | | | | | | < | 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 | } /* *---------------------------------------------------------------------- * * Tcl_DeleteInterp -- * * Ensures that the interpreter will be deleted eventually. If there are * no Tcl_Preserve calls in effect for this interpreter, it is deleted * immediately, otherwise the interpreter is deleted when the last * Tcl_Preserve is matched by a call to Tcl_Release. In either case, the * procedure runs the currently registered deletion callbacks. * * Results: * None. * * Side effects: * The interpreter is marked as deleted. The caller may still use it * safely if there are calls to Tcl_Preserve in effect for the * interpreter, but further calls to Tcl_Eval etc in this interpreter * will fail. * *---------------------------------------------------------------------- */ void Tcl_DeleteInterp(interp) Tcl_Interp *interp; /* Token for command interpreter (returned by * a previous call to Tcl_CreateInterp). */ { Interp *iPtr = (Interp *) interp; /* * If the interpreter has already been marked deleted, just punt. */ if (iPtr->flags & DELETED) { return; } /* * Mark the interpreter as deleted. No further evals will be allowed. * Increase the compileEpoch as a signal to compiled bytecodes. */ iPtr->flags |= DELETED; iPtr->compileEpoch++; /* * TIP #219, Tcl Channel Reflection API. Discard a leftover state. */ if (iPtr->chanMsg != NULL) { Tcl_DecrRefCount (iPtr->chanMsg); iPtr->chanMsg = NULL; } /* * Ensure that the interpreter is eventually deleted. */ Tcl_EventuallyFree((ClientData) interp, (Tcl_FreeProc *) DeleteInterpProc); } /* *---------------------------------------------------------------------- * * DeleteInterpProc -- * * Helper procedure to delete an interpreter. This procedure is called * when the last call to Tcl_Preserve on this interpreter is matched by a * call to Tcl_Release. The procedure cleans up all resources used in the * interpreter and calls all currently registered interpreter deletion * callbacks. * * Results: * None. * * Side effects: * Whatever the interpreter deletion callbacks do. Frees resources used * by the interpreter. * *---------------------------------------------------------------------- */ static void DeleteInterpProc(interp) Tcl_Interp *interp; /* Interpreter to delete. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *hTablePtr; ResolverScheme *resPtr, *nextResPtr; /* * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. */ if (iPtr->numLevels > 0) { Tcl_Panic("DeleteInterpProc called with active evals"); } /* * The interpreter should already be marked deleted; otherwise how did we * get here? */ if (!(iPtr->flags & DELETED)) { Tcl_Panic("DeleteInterpProc called on interpreter not marked deleted"); } /* * Shut down all limit handler callback scripts that call back into this * interpreter. Then eliminate all limit handlers for this interpreter. */ TclRemoveScriptLimitCallbacks(interp); TclLimitRemoveAllHandlers(interp); /* * Dismantle the namespace here, before we clear the assocData. If any * background errors occur here, they will be deleted below. * * Dismantle the namespace after freeing the iPtr->handle so that each * bytecode releases its literals without caring to update the literal * table, as it will be freed later in this function without further use. */ TclCleanupLiteralTable(interp, &(iPtr->literalTable)); TclHandleFree(iPtr->handle); TclTeardownNamespace(iPtr->globalNsPtr); /* * Delete all the hidden commands. */ hTablePtr = iPtr->hiddenCmdTablePtr; if (hTablePtr != NULL) { /* * Non-pernicious deletion. The deletion callbacks will not be allowed * to create any new hidden or non-hidden commands. * Tcl_DeleteCommandFromToken() will remove the entry from the * hiddenCmdTablePtr. */ hPtr = Tcl_FirstHashEntry(hTablePtr, &search); for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_DeleteCommandFromToken(interp, (Tcl_Command) Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(hTablePtr); ckfree((char *) hTablePtr); } /* * Invoke deletion callbacks; note that a callback can create new * callbacks, so we iterate. */ while (iPtr->assocData != (Tcl_HashTable *) NULL) { AssocData *dPtr; hTablePtr = iPtr->assocData; iPtr->assocData = (Tcl_HashTable *) NULL; for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); hPtr != NULL; hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { dPtr = (AssocData *) Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (dPtr->proc != NULL) { (*dPtr->proc)(dPtr->clientData, interp); } ckfree((char *) dPtr); } Tcl_DeleteHashTable(hTablePtr); ckfree((char *) hTablePtr); } /* * Finish deleting the global namespace. */ Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); /* * Free up the result *after* deleting variables, since variable deletion * could have transferred ownership of the result string to Tcl. */ Tcl_FreeResult(interp); interp->result = NULL; Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); |
︙ | ︙ | |||
994 995 996 997 998 999 1000 | iPtr->errorInfo = NULL; } if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | < > | | | | > | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | > | | | | | | | | 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 | iPtr->errorInfo = NULL; } if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); iPtr->appendResult = NULL; } TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr); } if (iPtr->execEnvPtr != NULL) { TclDeleteExecEnv(iPtr->execEnvPtr); } Tcl_DecrRefCount(iPtr->emptyObjPtr); iPtr->emptyObjPtr = NULL; resPtr = iPtr->resolverPtr; while (resPtr) { nextResPtr = resPtr->nextPtr; ckfree(resPtr->name); ckfree((char *) resPtr); resPtr = nextResPtr; } /* * Free up literal objects created for scripts compiled by the * interpreter. */ TclDeleteLiteralTable(interp, &(iPtr->literalTable)); ckfree((char *) iPtr); } /* *--------------------------------------------------------------------------- * * Tcl_HideCommand -- * * Makes a command hidden so that it cannot be invoked from within an * interpreter, only from within an ancestor. * * Results: * A standard Tcl result; also leaves a message in the interp's result if * an error occurs. * * Side effects: * Removes a command from the command table and create an entry into the * hidden command table under the specified token name. * *--------------------------------------------------------------------------- */ int Tcl_HideCommand(interp, cmdName, hiddenCmdToken) Tcl_Interp *interp; /* Interpreter in which to hide command. */ CONST char *cmdName; /* Name of command to hide. */ CONST char *hiddenCmdToken; /* Token name of the to-be-hidden command. */ { Interp *iPtr = (Interp *) interp; Tcl_Command cmd; Command *cmdPtr; Tcl_HashTable *hiddenCmdTablePtr; Tcl_HashEntry *hPtr; int new; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Do not create any new structures, * because it is not safe to modify the interpreter. */ return TCL_ERROR; } /* * Disallow hiding of commands that are currently in a namespace or * renaming (as part of hiding) into a namespace (because the current * implementation with a single global table and the needed uniqueness of * names cause problems with namespaces). * * We don't need to check for "::" in cmdName because the real check is on * the nsPtr below. * * hiddenCmdToken is just a string which is not interpreted in any way. * It may contain :: but the string is not interpreted as a namespace * qualifier command name. Thus, hiding foo::bar to foo::bar and then * trying to expose or invoke ::foo::bar will NOT work; but if the * application always uses the same strings it will get consistent * behaviour. * * But as we currently limit ourselves to the global namespace only for * the source, in order to avoid potential confusion, lets prevent "::" in * the token too. - dl */ if (strstr(hiddenCmdToken, "::") != NULL) { Tcl_AppendResult(interp, "cannot use namespace qualifiers in hidden command", " token (rename)", (char *) NULL); return TCL_ERROR; } /* * Find the command to hide. An error is returned if cmdName can't be * found. Look up the command only from the global namespace. Full path of * the command must be given if using namespaces. */ cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); if (cmd == (Tcl_Command) NULL) { return TCL_ERROR; } cmdPtr = (Command *) cmd; /* * Check that the command is really in global namespace */ if (cmdPtr->nsPtr != iPtr->globalNsPtr) { Tcl_AppendResult(interp, "can only hide global namespace commands", " (use rename then hide)", (char *) NULL); return TCL_ERROR; } /* * Initialize the hidden command table if necessary. */ hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr == NULL) { hiddenCmdTablePtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } /* * It is an error to move an exposed command to a hidden command with * hiddenCmdToken if a hidden command with the name hiddenCmdToken already * exists. */ hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new); if (!new) { Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken, "\" already exists", (char *) NULL); return TCL_ERROR; } /* * Nb : This code is currently 'like' a rename to a specialy set apart * name table. Changes here and in TclRenameCommand must be kept in synch * untill the common parts are actually factorized out. */ /* * Remove the hash entry for the command from the interpreter command * table. This is like deleting the command, so bump its command epoch; * this invalidates any cached references that point to the command. */ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = (Tcl_HashEntry *) NULL; cmdPtr->cmdEpoch++; } /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. */ TclInvalidateNsCmdLookup(cmdPtr->nsPtr); /* * Now link the hash table entry with the command structure. We ensured * above that the nsPtr was right. */ cmdPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); /* * If the command being hidden has a compile procedure, increment the * interpreter's compileEpoch to invalidate its compiled code. This makes * sure that we don't later try to execute old code compiled with * command-specific (i.e., inline) bytecodes for the now-hidden command. * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose * compilation epoch doesn't match is recompiled. */ if (cmdPtr->compileProc != NULL) { iPtr->compileEpoch++; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ExposeCommand -- * * Makes a previously hidden command callable from inside the interpreter * instead of only by its ancestors. * * Results: * A standard Tcl result. If an error occurs, a message is left in the * interp's result. * * Side effects: * Moves commands from one hash table to another. * *---------------------------------------------------------------------- */ int Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) Tcl_Interp *interp; /* Interpreter in which to make command * callable. */ CONST char *hiddenCmdToken; /* Name of hidden command. */ CONST char *cmdName; /* Name of to-be-exposed command. */ { Interp *iPtr = (Interp *) interp; Command *cmdPtr; Namespace *nsPtr; Tcl_HashEntry *hPtr; Tcl_HashTable *hiddenCmdTablePtr; int new; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Do not create any new structures, * because it is not safe to modify the interpreter. */ return TCL_ERROR; } /* * Check that we have a regular name for the command (that the user is not * trying to do an expose and a rename (to another namespace) at the same * time). */ if (strstr(cmdName, "::") != NULL) { Tcl_AppendResult(interp, "can not expose to a namespace ", "(use expose to toplevel, then rename)", (char *) NULL); return TCL_ERROR; } /* * Get the command from the hidden command table: */ hPtr = NULL; hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr != NULL) { hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); } if (hPtr == (Tcl_HashEntry *) NULL) { Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken, "\"", (char *) NULL); return TCL_ERROR; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); /* * Check that we have a true global namespace command (enforced by * Tcl_HideCommand() but let's double check. (If it was not, we would not * really know how to handle it). */ if (cmdPtr->nsPtr != iPtr->globalNsPtr) { /* * This case is theoritically impossible, we might rather Tcl_Panic() * than 'nicely' erroring out ? */ Tcl_AppendResult(interp, "trying to expose a non global command name space command", (char *) NULL); return TCL_ERROR; } /* This is the global table */ nsPtr = cmdPtr->nsPtr; /* * It is an error to overwrite an existing exposed command as a result of * exposing a previously hidden command. */ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new); if (!new) { Tcl_AppendResult(interp, "exposed command \"", cmdName, "\" already exists", (char *) NULL); return TCL_ERROR; } /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. */ TclInvalidateNsCmdLookup(nsPtr); /* * Remove the hash entry for the command from the interpreter hidden * command table. */ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; } /* * Now link the hash table entry with the command structure. This is like * creating a new command, so deal with any shadowing of commands in the * global namespace. */ cmdPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); /* * Not needed as we are only in the global namespace (but would be needed * again if we supported namespace command hiding) * * TclResetShadowedCmdRefs(interp, cmdPtr); */ /* * If the command being exposed has a compile procedure, increment * interpreter's compileEpoch to invalidate its compiled code. This makes * sure that we don't later try to execute old code compiled assuming the * command is hidden. This field is checked in Tcl_EvalObj and * ObjInterpProc, and code whose compilation epoch doesn't match is * recompiled. */ if (cmdPtr->compileProc != NULL) { iPtr->compileEpoch++; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_CreateCommand -- * * Define a new command in a command table. * * Results: * The return value is a token for the command, which can be used in * future calls to Tcl_GetCommandName. * * Side effects: * If a command named cmdName already exists for interp, it is deleted. * In the future, when cmdName is seen as the name of a command by * Tcl_Eval, proc will be called. To support the bytecode interpreter, * the command is created with a wrapper Tcl_ObjCmdProc * (TclInvokeStringCommand) that eventially calls proc. When the command * is deleted from the table, deleteProc will be called. See the manual * entry for details on the calling sequence. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) Tcl_Interp *interp; /* Token for command interpreter returned by a * previous call to Tcl_CreateInterp. */ CONST char *cmdName; /* Name of command. If it contains namespace * qualifiers, the new command is put in the * specified namespace; otherwise it is put in * the global namespace. */ Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */ ClientData clientData; /* Arbitrary value passed to string proc. */ Tcl_CmdDeleteProc *deleteProc; /* If not NULL, gives a procedure to call when * this command is deleted. */ { Interp *iPtr = (Interp *) interp; ImportRef *oldRefPtr = NULL; Namespace *nsPtr, *dummy1, *dummy2; Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; CONST char *tail; int new; ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Don't create any new commands; * it's not safe to muck with the interpreter anymore. */ return (Tcl_Command) NULL; } /* * Determine where the command should reside. If its name contains * namespace qualifiers, we put it in the specified namespace; otherwise, * we always put it in the global namespace. */ if (strstr(cmdName, "::") != NULL) { TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if ((nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } } else { nsPtr = iPtr->globalNsPtr; tail = cmdName; } hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { /* * Command already exists. Delete the old one. Be careful to preserve * any existing import links so we can restore them down below. That * way, you can redefine a command and its import status will remain * intact. */ cmdPtr = (Command *) Tcl_GetHashValue(hPtr); oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { /* * If the deletion callback recreated the command, just throw away * the new command (if we try to delete it again, we could get * stuck in an infinite loop). */ ckfree((char*) Tcl_GetHashValue(hPtr)); } } else { /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we * need the info will be soon enough. */ TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = (CompileProc *) NULL; cmdPtr->objProc = TclInvokeStringCommand; cmdPtr->objClientData = (ClientData) cmdPtr; cmdPtr->proc = proc; cmdPtr->clientData = clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; /* * Plug in any existing import references found above. Be sure to update * all of these references to point to the new command. */ if (oldRefPtr != NULL) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { refCmdPtr = oldRefPtr->importedCmdPtr; dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } } /* * We just created a command, so in its namespace and all of its parent * namespaces, it may shadow global commands with the same name. If any * shadowed commands are found, invalidate all cached command references * in the affected namespaces. */ TclResetShadowedCmdRefs(interp, cmdPtr); return (Tcl_Command) cmdPtr; } /* *---------------------------------------------------------------------- * * Tcl_CreateObjCommand -- * * Define a new object-based command in a command table. * * Results: * The return value is a token for the command, which can be used in * future calls to Tcl_GetCommandName. * * Side effects: * If no command named "cmdName" already exists for interp, one is * created. Otherwise, if a command does exist, then if the object-based * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand * was called previously for the same command and just set its * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old * command. * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based * Tcl_ObjCmdProc proc will be called. When the command is deleted from * the table, deleteProc will be called. See the manual entry for details * on the calling sequence. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) Tcl_Interp *interp; /* Token for command interpreter (returned by * previous call to Tcl_CreateInterp). */ CONST char *cmdName; /* Name of command. If it contains namespace * qualifiers, the new command is put in the * specified namespace; otherwise it is put in * the global namespace. */ Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with * name. */ ClientData clientData; /* Arbitrary value to pass to object * procedure. */ Tcl_CmdDeleteProc *deleteProc; /* If not NULL, gives a procedure to call when * this command is deleted. */ { Interp *iPtr = (Interp *) interp; ImportRef *oldRefPtr = NULL; Namespace *nsPtr, *dummy1, *dummy2; Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; CONST char *tail; int new; ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Don't create any new commands; * it's not safe to muck with the interpreter anymore. */ return (Tcl_Command) NULL; } /* * Determine where the command should reside. If its name contains * namespace qualifiers, we put it in the specified namespace; otherwise, * we always put it in the global namespace. */ if (strstr(cmdName, "::") != NULL) { TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if ((nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } } else { nsPtr = iPtr->globalNsPtr; tail = cmdName; } hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); TclInvalidateNsPath(nsPtr); if (!new) { cmdPtr = (Command *) Tcl_GetHashValue(hPtr); /* * Command already exists. If its object-based Tcl_ObjCmdProc is * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the * argument "proc". Otherwise, we delete the old command. */ if (cmdPtr->objProc == TclInvokeStringCommand) { cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; return (Tcl_Command) cmdPtr; } /* * Otherwise, we delete the old command. Be careful to preserve any * existing import links so we can restore them down below. That way, * you can redefine a command and its import status will remain * intact. */ oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { /* * If the deletion callback recreated the command, just throw away * the new command (if we try to delete it again, we could get * stuck in an infinite loop). */ ckfree((char *) Tcl_GetHashValue(hPtr)); } } else { /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we * need the info will be soon enough. */ TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = (CompileProc *) NULL; cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; cmdPtr->proc = TclInvokeObjectCommand; cmdPtr->clientData = (ClientData) cmdPtr; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; /* * Plug in any existing import references found above. Be sure to update * all of these references to point to the new command. */ if (oldRefPtr != NULL) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { refCmdPtr = oldRefPtr->importedCmdPtr; dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } } /* * We just created a command, so in its namespace and all of its parent * namespaces, it may shadow global commands with the same name. If any * shadowed commands are found, invalidate all cached command references * in the affected namespaces. */ TclResetShadowedCmdRefs(interp, cmdPtr); return (Tcl_Command) cmdPtr; } /* *---------------------------------------------------------------------- * * TclInvokeStringCommand -- * * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based * Tcl_CmdProc if no object-based procedure exists for a command. A * pointer to this procedure is stored as the Tcl_ObjCmdProc in a Command * structure. It simply turns around and calls the string Tcl_CmdProc in * the Command structure. * * Results: * A standard Tcl object result value. * * Side effects: * Besides those side effects of the called Tcl_CmdProc, * TclInvokeStringCommand allocates and frees storage. |
︙ | ︙ | |||
1706 1707 1708 1709 1710 1711 1712 | */ #define NUM_ARGS 20 CONST char *(argStorage[NUM_ARGS]); CONST char **argv = argStorage; /* | | | < | 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 | */ #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++) { |
︙ | ︙ | |||
1743 1744 1745 1746 1747 1748 1749 | /* *---------------------------------------------------------------------- * * TclInvokeObjectCommand -- * * "Wrapper" Tcl_CmdProc used to call an existing object-based | | | | | | 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 | /* *---------------------------------------------------------------------- * * TclInvokeObjectCommand -- * * "Wrapper" Tcl_CmdProc used to call an existing object-based * Tcl_ObjCmdProc if no string-based procedure exists for a command. A * pointer to this procedure is stored as the Tcl_CmdProc in a Command * structure. It simply turns around and calls the object Tcl_ObjCmdProc * in the Command structure. * * Results: * A standard Tcl string result value. * * Side effects: * Besides those side effects of the called Tcl_CmdProc, * TclInvokeStringCommand allocates and frees storage. |
︙ | ︙ | |||
1781 1782 1783 1784 1785 1786 1787 | */ #define NUM_ARGS 20 Tcl_Obj *(argStorage[NUM_ARGS]); register Tcl_Obj **objv = argStorage; /* | | | < < | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | < | > | | | | | | | | | | | | | | | | | | | | | | | | | | | < | < | | | | | | | | | | > | | | | | | | | | < | | | | | | | | | | | | | | < | | | 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 | */ #define NUM_ARGS 20 Tcl_Obj *(argStorage[NUM_ARGS]); register Tcl_Obj **objv = argStorage; /* * Create the object argument array "objv". Make sure objv is large enough * to hold the objc arguments plus 1 extra for the zero end-of-objv word. */ if (argc > NUM_ARGS) { objv = (Tcl_Obj **) ckalloc((unsigned)(argc * sizeof(Tcl_Obj *))); } for (i = 0; i < argc; i++) { length = strlen(argv[i]); TclNewStringObj(objPtr, argv[i], length); Tcl_IncrRefCount(objPtr); objv[i] = objPtr; } /* * Invoke the command's object-based Tcl_ObjCmdProc. */ result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv); /* * Move the interpreter's object result to the string result, then reset * the object result. */ (void) Tcl_GetStringResult(interp); /* * Decrement the ref counts for the argument objects created above, then * free the objv array if malloc'ed storage was used. */ for (i = 0; i < argc; i++) { objPtr = objv[i]; Tcl_DecrRefCount(objPtr); } if (objv != argStorage) { ckfree((char *) objv); } return result; #undef NUM_ARGS } /* *---------------------------------------------------------------------- * * TclRenameCommand -- * * Called to give an existing Tcl command a different name. Both the old * command name and the new command name can have "::" namespace * qualifiers. If the new command has a different namespace context, the * command will be moved to that namespace and will execute in the * context of that new namespace. * * If the new command name is NULL or the null string, the command is * deleted. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * If anything goes wrong, an error message is returned in the * interpreter's result object. * *---------------------------------------------------------------------- */ int TclRenameCommand(interp, oldName, newName) Tcl_Interp *interp; /* Current interpreter. */ char *oldName; /* Existing command name. */ char *newName; /* New command name. */ { Interp *iPtr = (Interp *) interp; CONST char *newTail; Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; Tcl_Command cmd; Command *cmdPtr; Tcl_HashEntry *hPtr, *oldHPtr; int new, result; Tcl_Obj* oldFullName; Tcl_DString newFullName; /* * Find the existing command. An error is returned if cmdName can't be * found. */ cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL, /*flags*/ 0); cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { Tcl_AppendResult(interp, "can't ", ((newName == NULL)||(*newName == '\0'))? "delete":"rename", " \"", oldName, "\": command doesn't exist", (char *) NULL); return TCL_ERROR; } cmdNsPtr = cmdPtr->nsPtr; oldFullName = Tcl_NewObj(); Tcl_IncrRefCount(oldFullName); Tcl_GetCommandFullName(interp, cmd, oldFullName); /* * If the new command name is NULL or empty, delete the command. Do this * with Tcl_DeleteCommandFromToken, since we already have the command. */ if ((newName == NULL) || (*newName == '\0')) { Tcl_DeleteCommandFromToken(interp, cmd); result = TCL_OK; goto done; } /* * Make sure that the destination command does not already exist. The * rename operation is like creating a command, so we should automatically * create the containing namespaces just like Tcl_CreateCommand would. */ TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); if ((newNsPtr == NULL) || (newTail == NULL)) { Tcl_AppendResult(interp, "can't rename to \"", newName, "\": bad command name", (char *) NULL); result = TCL_ERROR; goto done; } if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { Tcl_AppendResult(interp, "can't rename to \"", newName, "\": command already exists", (char *) NULL); result = TCL_ERROR; goto done; } /* * Warning: any changes done in the code here are likely to be needed in * Tcl_HideCommand() code too (until the common parts are extracted out). * - dl */ /* * Put the command in the new namespace so we can check for an alias loop. * Since we are adding a new command to a namespace, we must handle any * shadowing of the global commands that this might create. */ oldHPtr = cmdPtr->hPtr; hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new); Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = newNsPtr; TclResetShadowedCmdRefs(interp, cmdPtr); /* * Now check for an alias loop. If we detect one, put everything back the * way it was and report the error. */ result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr); if (result != TCL_OK) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = oldHPtr; cmdPtr->nsPtr = cmdNsPtr; goto done; } /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. These might refer to the same variable, * but that's no big deal. */ TclInvalidateNsCmdLookup(cmdNsPtr); TclInvalidateNsCmdLookup(cmdPtr->nsPtr); /* * Script for rename traces can delete the command "oldName". Therefore * increment the reference count for cmdPtr so that it's Command structure * is freed only towards the end of this function by calling * TclCleanupCommand. * * The trace procedure needs to get a fully qualified name for old and new * commands [Tcl bug #651271], or else there's no way for the trace * procedure to get the namespace from which the old command is being * renamed! */ Tcl_DStringInit(&newFullName); Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1); if (newNsPtr != iPtr->globalNsPtr) { Tcl_DStringAppend(&newFullName, "::", 2); } Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName), Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); Tcl_DStringFree(&newFullName); /* * The new command name is okay, so remove the command from its current * namespace. This is like deleting the command, so bump the cmdEpoch to * invalidate any cached references to the command. */ Tcl_DeleteHashEntry(oldHPtr); cmdPtr->cmdEpoch++; /* * If the command being renamed has a compile procedure, increment the * interpreter's compileEpoch to invalidate its compiled code. This makes * sure that we don't later try to execute old code compiled for the * now-renamed command. */ if (cmdPtr->compileProc != NULL) { iPtr->compileEpoch++; } /* * Now free the Command structure, if the "oldName" command has been * deleted by invocation of rename traces. */ TclCleanupCommand(cmdPtr); result = TCL_OK; done: TclDecrRefCount(oldFullName); return result; } /* *---------------------------------------------------------------------- * * Tcl_SetCommandInfo -- * * Modifies various information about a Tcl command. Note that this * procedure will not change a command's namespace; use TclRenameCommand * to do that. Also, the isNativeObjectProc member of *infoPtr is * ignored. * * Results: * If cmdName exists in interp, then the information at *infoPtr is * stored with the command in place of the current information and 1 is * returned. If the command doesn't exist then 0 is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_SetCommandInfo(interp, cmdName, infoPtr) Tcl_Interp *interp; /* Interpreter in which to look for * command. */ CONST char *cmdName; /* Name of desired command. */ CONST Tcl_CmdInfo *infoPtr; /* Where to find information to store in the * command. */ { Tcl_Command cmd; cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ 0); return Tcl_SetCommandInfoFromToken(cmd, infoPtr); } /* *---------------------------------------------------------------------- * * Tcl_SetCommandInfoFromToken -- * * Modifies various information about a Tcl command. Note that this * procedure will not change a command's namespace; use TclRenameCommand * to do that. Also, the isNativeObjectProc member of *infoPtr is * ignored. * * Results: * If cmdName exists in interp, then the information at *infoPtr is * stored with the command in place of the current information and 1 is * returned. If the command doesn't exist then 0 is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_SetCommandInfoFromToken(cmd, infoPtr) Tcl_Command cmd; CONST Tcl_CmdInfo* infoPtr; { Command* cmdPtr; /* Internal representation of the command */ if (cmd == (Tcl_Command) NULL) { return 0; } /* * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. */ cmdPtr = (Command *) cmd; cmdPtr->proc = infoPtr->proc; cmdPtr->clientData = infoPtr->clientData; if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { cmdPtr->objProc = TclInvokeStringCommand; cmdPtr->objClientData = (ClientData) cmdPtr; } else { |
︙ | ︙ | |||
2119 2120 2121 2122 2123 2124 2125 | *---------------------------------------------------------------------- * * Tcl_GetCommandInfo -- * * Returns various information about a Tcl command. * * Results: | | | | < | | | | | | | | | | | < | | 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 | *---------------------------------------------------------------------- * * Tcl_GetCommandInfo -- * * Returns various information about a Tcl command. * * Results: * If cmdName exists in interp, then *infoPtr is modified to hold * information about cmdName and 1 is returned. If the command doesn't * exist then 0 is returned and *infoPtr isn't modified. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetCommandInfo(interp, cmdName, infoPtr) Tcl_Interp *interp; /* Interpreter in which to look for * command. */ CONST char *cmdName; /* Name of desired command. */ Tcl_CmdInfo *infoPtr; /* Where to store information about * command. */ { Tcl_Command cmd; cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ 0); return Tcl_GetCommandInfoFromToken(cmd, infoPtr); } /* *---------------------------------------------------------------------- * * Tcl_GetCommandInfoFromToken -- * * Returns various information about a Tcl command. * * Results: * Copies information from the command identified by 'cmd' into a * caller-supplied structure and returns 1. If the 'cmd' is NULL, leaves * the structure untouched and returns 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetCommandInfoFromToken(cmd, infoPtr) Tcl_Command cmd; Tcl_CmdInfo* infoPtr; { Command* cmdPtr; /* Internal representation of the command */ if (cmd == (Tcl_Command) NULL) { return 0; } /* * Set isNativeObjectProc 1 if objProc was registered by a call to * Tcl_CreateObjCommand. Otherwise set it to 0. */ |
︙ | ︙ | |||
2202 2203 2204 2205 2206 2207 2208 | } /* *---------------------------------------------------------------------- * * Tcl_GetCommandName -- * | | | | | | < | | > | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_GetCommandName -- * * Given a token returned by Tcl_CreateCommand, this procedure returns * the current name of the command (which may have changed due to * renaming). * * Results: * The return value is the name of the given command. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_GetCommandName(interp, command) Tcl_Interp *interp; /* Interpreter containing the command. */ Tcl_Command command; /* Token for command returned by a previous * call to Tcl_CreateCommand. The command must * not have been deleted. */ { Command *cmdPtr = (Command *) command; if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) { /* * This should only happen if command was "created" after the * interpreter began to be deleted, so there isn't really any command. * Just return an empty string. */ return ""; } return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); } /* *---------------------------------------------------------------------- * * Tcl_GetCommandFullName -- * * Given a token returned by, e.g., Tcl_CreateCommand or Tcl_FindCommand, * this procedure appends to an object the command's full name, qualified * by a sequence of parent namespace names. The command's fully-qualified * name may have changed due to renaming. * * Results: * None. * * Side effects: * The command's fully-qualified name is appended to the string * representation of objPtr. * *---------------------------------------------------------------------- */ void Tcl_GetCommandFullName(interp, command, objPtr) Tcl_Interp *interp; /* Interpreter containing the command. */ Tcl_Command command; /* Token for command returned by a previous * call to Tcl_CreateCommand. The command must * not have been deleted. */ Tcl_Obj *objPtr; /* Points to the object onto which the * command's full name is appended. */ { Interp *iPtr = (Interp *) interp; register Command *cmdPtr = (Command *) command; char *name; |
︙ | ︙ | |||
2298 2299 2300 2301 2302 2303 2304 | *---------------------------------------------------------------------- * * Tcl_DeleteCommand -- * * Remove the given command from the given interpreter. * * Results: | | | | < | | | | | | | | | | | | | | | | | | | | | > > > | | > | | | | | | > | | > > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | > | > | | | | | | < | | | | 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 | *---------------------------------------------------------------------- * * Tcl_DeleteCommand -- * * Remove the given command from the given interpreter. * * Results: * 0 is returned if the command was deleted successfully. -1 is returned * if there didn't exist a command by that name. * * Side effects: * cmdName will no longer be recognized as a valid command for interp. * *---------------------------------------------------------------------- */ int Tcl_DeleteCommand(interp, cmdName) Tcl_Interp *interp; /* Token for command interpreter (returned by * a previous Tcl_CreateInterp call). */ CONST char *cmdName; /* Name of command to remove. */ { Tcl_Command cmd; /* * Find the desired command and delete it. */ cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ 0); if (cmd == (Tcl_Command) NULL) { return -1; } return Tcl_DeleteCommandFromToken(interp, cmd); } /* *---------------------------------------------------------------------- * * Tcl_DeleteCommandFromToken -- * * Removes the given command from the given interpreter. This procedure * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead of * a command name for efficiency. * * Results: * 0 is returned if the command was deleted successfully. -1 is returned * if there didn't exist a command by that name. * * Side effects: * The command specified by "cmd" will no longer be recognized as a valid * command for "interp". * *---------------------------------------------------------------------- */ int Tcl_DeleteCommandFromToken(interp, cmd) Tcl_Interp *interp; /* Token for command interpreter returned by a * previous call to Tcl_CreateInterp. */ Tcl_Command cmd; /* Token for command to delete. */ { Interp *iPtr = (Interp *) interp; Command *cmdPtr = (Command *) cmd; ImportRef *refPtr, *nextRefPtr; Tcl_Command importCmd; /* * The code here is tricky. We can't delete the hash table entry before * invoking the deletion callback because there are cases where the * deletion callback needs to invoke the command (e.g. object systems such * as OTcl). However, this means that the callback could try to delete or * rename the command. The deleted flag allows us to detect these cases * and skip nested deletes. */ if (cmdPtr->flags & CMD_IS_DELETED) { /* * Another deletion is already in progress. Remove the hash table * entry now, but don't invoke a callback or free the command * structure. Take care to only remove the hash entry if it has not * already been removed; otherwise if we manage to hit this function * three times, everything goes up in smoke. [Bug 1220058] */ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; } return 0; } /* * We must delete this command, even though both traces and delete procs * may try to avoid this (renaming the command etc). Also traces and * delete procs may try to delete the command themsevles. This flag * declares that a delete is in progress and that recursive deletes should * be ignored. */ cmdPtr->flags |= CMD_IS_DELETED; /* * Call trace procedures for the command being deleted. Then delete its * traces. */ if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); /* * Now delete these traces. */ tracePtr = cmdPtr->tracePtr; while (tracePtr != NULL) { CommandTrace *nextPtr = tracePtr->nextPtr; if ((--tracePtr->refCount) <= 0) { ckfree((char*)tracePtr); } tracePtr = nextPtr; } cmdPtr->tracePtr = NULL; } /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. */ TclInvalidateNsCmdLookup(cmdPtr->nsPtr); /* * If the command being deleted has a compile procedure, increment the * interpreter's compileEpoch to invalidate its compiled code. This makes * sure that we don't later try to execute old code compiled with * command-specific (i.e., inline) bytecodes for the now-deleted command. * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose * compilation epoch doesn't match is recompiled. */ if (cmdPtr->compileProc != NULL) { iPtr->compileEpoch++; } if (cmdPtr->deleteProc != NULL) { /* * Delete the command's client data. If this was an imported command * created when a command was imported into a namespace, this client * data will be a pointer to a ImportedCmdData structure describing * the "real" command that this imported command refers to. */ /* * If you are getting a crash during the call to deleteProc and * cmdPtr->deleteProc is a pointer to the function free(), the most * likely cause is that your extension allocated memory for the * clientData argument to Tcl_CreateObjCommand() with the ckalloc() * macro and you are now trying to deallocate this memory with free() * instead of ckfree(). You should pass a pointer to your own method * that calls ckfree(). */ (*cmdPtr->deleteProc)(cmdPtr->deleteData); } /* * Bump the command epoch counter. This will invalidate all cached * references that point to this command. */ cmdPtr->cmdEpoch++; /* * If this command was imported into other namespaces, then imported * commands were created that refer back to this command. Delete these * imported commands now. */ for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; refPtr = nextRefPtr) { nextRefPtr = refPtr->nextPtr; importCmd = (Tcl_Command) refPtr->importedCmdPtr; Tcl_DeleteCommandFromToken(interp, importCmd); } /* * Don't use hPtr to delete the hash entry here, because it's possible * that the deletion callback renamed the command. Instead, use * cmdPtr->hptr, and make sure that no-one else has already deleted the * hash entry. */ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); } /* * Mark the Command structure as no longer valid. This allows * TclExecuteByteCode to recognize when a Command has logically been * deleted and a pointer to this Command structure cached in a CmdName * object is invalid. TclExecuteByteCode will look up the command again in * the interpreter's command hashtable. */ cmdPtr->objProc = NULL; /* * Now free the Command structure, unless there is another reference to it * from a CmdName Tcl object in some ByteCode code sequence. In that case, * delay the cleanup until all references are either discarded (when a * ByteCode is freed) or replaced by a new reference (when a cached * CmdName Command reference is found to be invalid and TclExecuteByteCode * looks up the command in the command hashtable). */ 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 indicating the type of traces to * trigger, either TCL_TRACE_DELETE or * TCL_TRACE_RENAME. */ { register CommandTrace *tracePtr; ActiveCommandTrace active; char *result; Tcl_Obj *oldNamePtr = NULL; if (cmdPtr->flags & CMD_TRACE_ACTIVE) { /* * While a rename trace is active, we will not process any more rename * traces; while a delete trace is active we will never reach here - * because Tcl_DeleteCommandFromToken checks for the condition * (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a * command deletion is in progress. For all other traces, delete * traces will not be invoked but a call to TraceCommandProc will * ensure that tracePtr->clientData is freed whenever the command * "oldName" is deleted. */ if (cmdPtr->flags & TCL_TRACE_RENAME) { flags &= ~TCL_TRACE_RENAME; } if (flags == 0) { return NULL; } } cmdPtr->flags |= CMD_TRACE_ACTIVE; cmdPtr->refCount++; result = NULL; active.nextPtr = iPtr->activeCmdTracePtr; active.reverseScan = 0; iPtr->activeCmdTracePtr = &active; if (flags & TCL_TRACE_DELETE) { flags |= TCL_TRACE_DESTROYED; } active.cmdPtr = cmdPtr; Tcl_Preserve((ClientData) iPtr); for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; tracePtr = active.nextTracePtr) { 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); } tracePtr->refCount++; (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, oldName, newName, flags); cmdPtr->flags &= ~tracePtr->flags; if ((--tracePtr->refCount) <= 0) { ckfree((char*)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; cmdPtr->refCount--; iPtr->activeCmdTracePtr = active.nextPtr; Tcl_Release((ClientData) iPtr); return result; } /* *---------------------------------------------------------------------- * * TclCleanupCommand -- * * This procedure frees up a Command structure unless it is still * referenced from an interpreter's command hashtable or from a CmdName * Tcl object representing the name of a command in a ByteCode * instruction sequence. * * Results: * None. * * Side effects: * Memory gets freed unless a reference to the Command structure still * exists. In that case the cleanup is delayed until the command is |
︙ | ︙ | |||
2636 2637 2638 2639 2640 2641 2642 | } /* *---------------------------------------------------------------------- * * Tcl_CreateMathFunc -- * | | < | | | | | | | | | | | | | | | < < < < < < < < < | < < < < < < < < < < < < < < < < < | | < | < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > | > > > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > | > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | | | | | | | | | | < | | | > > > | > > > > > > > > | | > | > > > | > < < < | < > > > | > > | < | | < | < < | > > > | < > | | | | > > > > | | | | > > > > > > > > > > > | > | | | < | | < < | | > > | | | < | | | | | | | | < | | | | | | | | | | | | < | < | | | | | | | | < < < < < < | | | | < | | | | > > > | > | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | > | | | > | | | | | > | | | | | < | | | | | > | > > | < > | < < > | > | | | | | | | | | | < | | | | | | | | | | | | < | < | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_CreateMathFunc -- * * Creates a new math function for expressions in a given interpreter. * * Results: * None. * * Side effects: * The function defined by "name" is created or redefined. If the * function already exists then its definition is replaced; this includes * the builtin functions. Redefining a builtin function forces all * existing code to be invalidated since that code may be compiled using * an instruction specific to the replaced function. In addition, * redefioning a non-builtin function will force existing code to be * invalidated if the number of arguments has changed. * *---------------------------------------------------------------------- */ void Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) Tcl_Interp *interp; /* Interpreter in which function is to be * available. */ CONST char *name; /* Name of function (e.g. "sin"). */ int numArgs; /* Nnumber of arguments required by * function. */ Tcl_ValueType *argTypes; /* Array of types acceptable for each * argument. */ Tcl_MathProc *proc; /* Procedure that implements the math * function. */ ClientData clientData; /* Additional value to pass to the * function. */ { Tcl_DString bigName; OldMathFuncData *data = (OldMathFuncData *) ckalloc(sizeof(OldMathFuncData)); if (numArgs > MAX_MATH_ARGS) { Tcl_Panic("attempt to create a math function with too many args"); } data->proc = proc; data->numArgs = numArgs; data->argTypes = (Tcl_ValueType*) Tcl_Alloc(numArgs * sizeof(Tcl_ValueType)); memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); data->clientData = clientData; Tcl_DStringInit(&bigName); Tcl_DStringAppend(&bigName, "::tcl::mathfunc::", -1); Tcl_DStringAppend(&bigName, name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName), OldMathFuncProc, (ClientData) data, OldMathFuncDeleteProc); Tcl_DStringFree(&bigName); } /* *---------------------------------------------------------------------- * * OldMathFuncProc -- * * Dispatch to a math function created with Tcl_CreateMathFunc * * Results: * Returns a standard Tcl result. * * Side effects: * Whatever the math function does. * *---------------------------------------------------------------------- */ static int OldMathFuncProc(clientData, interp, objc, objv) ClientData clientData; /* Ponter to OldMathFuncData describing the * function being called */ Tcl_Interp *interp; /* Tcl interpreter */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Parameter vector */ { Tcl_Obj* valuePtr; OldMathFuncData* dataPtr = (OldMathFuncData*) clientData; Tcl_Value args[MAX_MATH_ARGS]; Tcl_Value funcResult; int result; #if 0 int i; #endif int j, k; double d; /* * Check argument count. */ if (objc != dataPtr->numArgs + 1) { MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv); return TCL_ERROR; } /* * Convert arguments from Tcl_Obj's to Tcl_Value's. */ #if 0 for (j = 1, k = 0; j < objc; ++j, ++k) { valuePtr = objv[j]; if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { return TCL_ERROR; } /* * Copy the object's numeric value to the argument record, converting * it if necessary. */ if (valuePtr->typePtr == &tclIntType) { i = valuePtr->internalRep.longValue; if (dataPtr->argTypes[k] == TCL_DOUBLE) { args[k].type = TCL_DOUBLE; args[k].doubleValue = i; } else if (dataPtr->argTypes[k] == TCL_WIDE_INT) { args[k].type = TCL_WIDE_INT; args[k].wideValue = Tcl_LongAsWide(i); } else { args[k].type = TCL_INT; args[k].intValue = i; } } else if (valuePtr->typePtr == &tclWideIntType) { Tcl_WideInt w; TclGetWide(w,valuePtr); if (dataPtr->argTypes[k] == TCL_DOUBLE) { args[k].type = TCL_DOUBLE; args[k].doubleValue = Tcl_WideAsDouble(w); } else if (dataPtr->argTypes[k] == TCL_INT) { args[k].type = TCL_INT; args[k].intValue = Tcl_WideAsLong(w); } else { args[k].type = TCL_WIDE_INT; args[k].wideValue = w; } } else { d = valuePtr->internalRep.doubleValue; if (dataPtr->argTypes[k] == TCL_INT) { args[k].type = TCL_INT; args[k].intValue = (long) d; } else if (dataPtr->argTypes[k] == TCL_WIDE_INT) { args[k].type = TCL_WIDE_INT; args[k].wideValue = Tcl_DoubleAsWide(d); } else { args[k].type = TCL_DOUBLE; args[k].doubleValue = d; } } } #else for (j = 1, k = 0; j < objc; ++j, ++k) { valuePtr = objv[j]; result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); #ifdef ACCEPT_NAN if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) { d = valuePtr->internalRep.doubleValue; result = TCL_OK; } #endif if (result != TCL_OK) { /* Non-numeric argument */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", -1)); TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); return TCL_ERROR; } /* * Copy the object's numeric value to the argument record, * converting it if necessary. * * NOTE: no bignum support; use the new mathfunc interface for that */ args[k].type = dataPtr->argTypes[k]; switch (args[k].type) { case TCL_EITHER: if (Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue)) == TCL_OK) { args[k].type = TCL_INT; break; } if (Tcl_GetWideIntFromObj(interp, valuePtr, &(args[k].wideValue)) == TCL_OK) { args[k].type = TCL_WIDE_INT; break; } args[k].type = TCL_DOUBLE; /* FALLTHROUGH */ case TCL_DOUBLE: args[k].doubleValue = d; break; case TCL_INT: if (ExprIntFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) { return TCL_ERROR; } valuePtr = Tcl_GetObjResult(interp); Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue)); Tcl_ResetResult(interp); break; case TCL_WIDE_INT: if (ExprWideFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) { return TCL_ERROR; } valuePtr = Tcl_GetObjResult(interp); Tcl_GetWideIntFromObj(NULL, valuePtr, &(args[k].wideValue)); Tcl_ResetResult(interp); break; } } #endif /* * Call the function. */ errno = 0; result = (*dataPtr->proc)(dataPtr->clientData, interp, args, &funcResult); if (result != TCL_OK) { return result; } /* * Return the result of the call. */ if (funcResult.type == TCL_INT) { TclNewLongObj(valuePtr, funcResult.intValue); } else if (funcResult.type == TCL_WIDE_INT) { valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); } else { return CheckDoubleResult(interp, funcResult.doubleValue); } Tcl_SetObjResult(interp, valuePtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * OldMathFuncDeleteProc -- * * Cleans up after deleting a math function registered with * Tcl_CreateMathFunc * * Results: * None. * * Side effects: * Frees allocated memory. * *---------------------------------------------------------------------- */ static void OldMathFuncDeleteProc(clientData) ClientData clientData; { OldMathFuncData* dataPtr = (OldMathFuncData*) clientData; Tcl_Free((VOID*) dataPtr->argTypes); Tcl_Free((VOID*) dataPtr); } /* *---------------------------------------------------------------------- * * Tcl_GetMathFuncInfo -- * * Discovers how a particular math function was created in a given * interpreter. * * Results: * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message in the * interpreter result if that happens.) * * Side effects: * If this function succeeds, the variables pointed to by the numArgsPtr * and argTypePtr arguments will be updated to detail the arguments * allowed by the function. The variable pointed to by the procPtr * argument will be set to NULL if the function is a builtin function, * and will be set to the address of the C function used to implement the * math function otherwise (in which case the variable pointed to by the * clientDataPtr argument will also be updated.) * *---------------------------------------------------------------------- */ int Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr, clientDataPtr) Tcl_Interp *interp; CONST char *name; int *numArgsPtr; Tcl_ValueType **argTypesPtr; Tcl_MathProc **procPtr; ClientData *clientDataPtr; { Tcl_Obj* cmdNameObj; Command* cmdPtr; /* * Get the command that implements the math function. */ cmdNameObj = Tcl_NewStringObj("tcl::mathfunc::", -1); Tcl_AppendToObj(cmdNameObj, name, -1); Tcl_IncrRefCount(cmdNameObj); cmdPtr = (Command*) Tcl_GetCommandFromObj(interp, cmdNameObj); Tcl_DecrRefCount(cmdNameObj); /* * Report unknown functions. */ if (cmdPtr == NULL) { Tcl_Obj* message; message = Tcl_NewStringObj("unknown math function \"", -1); Tcl_AppendToObj(message, name, -1); Tcl_AppendToObj(message, "\"", 1); *numArgsPtr = -1; *argTypesPtr = NULL; *procPtr = NULL; *clientDataPtr = NULL; return TCL_ERROR; } /* * Retrieve function info for user defined functions; return dummy * information for builtins. */ if (cmdPtr->objProc == &OldMathFuncProc) { OldMathFuncData* dataPtr = (OldMathFuncData*) cmdPtr->clientData; *procPtr = dataPtr->proc; *numArgsPtr = dataPtr->numArgs; *argTypesPtr = dataPtr->argTypes; *clientDataPtr = dataPtr->clientData; } else { *procPtr = NULL; *numArgsPtr = -1; *argTypesPtr = NULL; *procPtr = NULL; *clientDataPtr = NULL; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ListMathFuncs -- * * Produces a list of all the math functions defined in a given * interpreter. * * Results: * A pointer to a Tcl_Obj structure with a reference count of zero, or * NULL in the case of an error (in which case a suitable error message * will be left in the interpreter result.) * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_ListMathFuncs(interp, pattern) Tcl_Interp *interp; CONST char *pattern; { Namespace* globalNsPtr = (Namespace*) Tcl_GetGlobalNamespace(interp); Namespace* nsPtr; Namespace* dummy1NsPtr; Namespace* dummy2NsPtr; CONST char* dummyNamePtr; Tcl_Obj* result = Tcl_NewObj(); Tcl_HashEntry* cmdHashEntry; Tcl_HashSearch cmdHashSearch; CONST char* cmdNamePtr; TclGetNamespaceForQualName(interp, "::tcl::mathfunc", globalNsPtr, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &dummyNamePtr); if (nsPtr != NULL) { if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { if (Tcl_FindHashEntry(&nsPtr->cmdTable, pattern) != NULL) { Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(pattern, -1)); } } else { cmdHashEntry = Tcl_FirstHashEntry(&nsPtr->cmdTable,&cmdHashSearch); for (; cmdHashEntry != NULL; cmdHashEntry = Tcl_NextHashEntry(&cmdHashSearch)) { cmdNamePtr = Tcl_GetHashKey(&nsPtr->cmdTable, cmdHashEntry); if (pattern == NULL || Tcl_StringMatch(cmdNamePtr, pattern)) { Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(cmdNamePtr, -1)); } } } } return result; } /* *---------------------------------------------------------------------- * * TclInterpReady -- * * Check if an interpreter is ready to eval commands or scripts, i.e., if * it was not deleted and if the nesting level is not too high. * * Results: * The return value is TCL_OK if it the interpreter is ready, TCL_ERROR * otherwise. * * Side effects: * The interpreters object and string results are cleared. * *---------------------------------------------------------------------- */ int TclInterpReady(interp) Tcl_Interp *interp; { register Interp *iPtr = (Interp *) interp; /* * Reset both the interpreter's string and object results and clear out * any previous error information. */ Tcl_ResetResult(interp); /* * If the interpreter has been deleted, return an error. */ if (iPtr->flags & DELETED) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "attempt to call eval in deleted interpreter", (char *) NULL); Tcl_SetErrorCode(interp, "CORE", "IDELETE", "attempt to call eval in deleted interpreter", (char *) NULL); return TCL_ERROR; } /* * 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_AppendResult(interp, "too many nested evaluations (infinite loop?)", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclEvalObjvInternal -- * * This procedure evaluates a Tcl command that has already been parsed * into words, with one Tcl_Obj holding each word. The caller is * responsible for managing the iPtr->numLevels. * * Results: * The return value is a standard Tcl completion code such as TCL_OK or * TCL_ERROR. A result or error message is left in interp's result. If an * error occurs, this procedure does NOT add any information to the * errorInfo variable. * * Side effects: * Depends on the command. * *---------------------------------------------------------------------- */ int 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 (TclInterpReady(interp) == TCL_ERROR) { return TCL_ERROR; } if (objc == 0) { return TCL_OK; } /* * 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. * * If caller requests, or if we're resolving the target end of an * interpeter alias (TCL_EVAL_INVOKE), be sure to do command name * resolution in the global namespace. * * If any execution traces rename or delete the current command, we may * need (at most) two passes here. */ reparseBecauseOfTraces: savedVarFramePtr = iPtr->varFramePtr; if (flags & (TCL_EVAL_INVOKE | TCL_EVAL_GLOBAL)) { 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_AppendResult(interp, "invalid command name \"", TclGetString(objv[0]), "\"", (char *) NULL); code = TCL_ERROR; } else { iPtr->numLevels++; code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0); iPtr->numLevels--; } Tcl_DecrRefCount(newObjv[0]); ckfree((char *) newObjv); 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; goto reparseBecauseOfTraces; } } /* * Finally, invoke the command's Tcl_ObjCmdProc. */ cmdPtr->refCount++; iPtr->cmdCount++; if (code == TCL_OK && traceCode == TCL_OK && !Tcl_LimitExceeded(interp)) { savedVarFramePtr = iPtr->varFramePtr; if (flags & TCL_EVAL_GLOBAL) { iPtr->varFramePtr = NULL; } if (!(flags & TCL_EVAL_INVOKE) && (iPtr->ensembleRewrite.sourceObjs != NULL) && !Tcl_IsEnsemble((Tcl_Command) cmdPtr)) { iPtr->ensembleRewrite.sourceObjs = NULL; } code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); iPtr->varFramePtr = savedVarFramePtr; } if (Tcl_AsyncReady()) { code = Tcl_AsyncInvoke(interp, code); } if (code == TCL_OK && Tcl_LimitReady(interp)) { code = Tcl_LimitCheck(interp); } /* * 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. */ if (*(iPtr->result) != 0) { (void) Tcl_GetObjResult(interp); } done: return code; } /* *---------------------------------------------------------------------- * * Tcl_EvalObjv -- * * This procedure evaluates a Tcl command that has already been parsed * into words, with one Tcl_Obj holding each word. * * Results: * The return value is a standard Tcl completion code such as TCL_OK or * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: * Depends on the command. * *---------------------------------------------------------------------- */ int Tcl_EvalObjv(interp, objc, objv, 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. */ 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++) { Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); } cmdString = Tcl_DStringValue(&cmdBuf); cmdLen = Tcl_DStringLength(&cmdBuf); break; } } iPtr->numLevels++; code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags); iPtr->numLevels--; /* * If we are again at the top level, process any unusual return code * returned by the evaluated code. */ if (iPtr->numLevels == 0) { if (code == TCL_RETURN) { code = TclUpdateReturnInfo(iPtr); } if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) { ProcessUnexpectedResult(interp, code); code = TCL_ERROR; } } if ((code == TCL_ERROR) && !(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) { Tcl_DStringInit(&cmdBuf); for (i = 0; i < objc; i++) { Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); |
︙ | ︙ | |||
3208 3209 3210 3211 3212 3213 3214 | } /* *---------------------------------------------------------------------- * * Tcl_LogCommandInfo -- * | | | | | | | | | | | | | > > | < < | < < | < < < | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | < | | | | | | | | | < | > | | | | | | | | | | < < < < < < < < > | > > | > | | | | < < < < < < < < < < > | | > | > | > > > > | > > > > > | | | > | > | 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 | } /* *---------------------------------------------------------------------- * * Tcl_LogCommandInfo -- * * This procedure is invoked after an error occurs in an interpreter. It * adds information to iPtr->errorInfo field to describe the command that * was being executed when the error occurred. * * Results: * None. * * Side effects: * Information about the command is added to errorInfo and the line * number stored internally in the interpreter is set. * *---------------------------------------------------------------------- */ void Tcl_LogCommandInfo(interp, script, command, length) Tcl_Interp *interp; /* Interpreter in which to log 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). */ { register CONST char *p; Interp *iPtr = (Interp *) interp; int overflow, limit = 150; if (iPtr->flags & ERR_ALREADY_LOGGED) { /* * Someone else has already logged error information for this command; * we shouldn't add anything more. */ return; } /* * Compute the line number where the error occurred. */ iPtr->errorLine = 1; for (p = script; p != command; p++) { if (*p == '\n') { iPtr->errorLine++; } } overflow = (length > limit); TclFormatToErrorInfo(interp, "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL) ? "while executing" : "invoked from within"), (overflow ? limit : length), command, (overflow ? "..." : "")); } /* *---------------------------------------------------------------------- * * Tcl_EvalTokensStandard -- * * Given an array of tokens parsed from a Tcl command (e.g., the tokens * that make up a word or the index for an array variable) this procedure * evaluates the tokens and concatenates their values to form a single * result value. * * Results: * The return value is a standard Tcl completion code such as TCL_OK or * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: * Depends on the array of tokens being evaled. * *---------------------------------------------------------------------- */ int Tcl_EvalTokensStandard(interp, tokenPtr, count) Tcl_Interp *interp; /* Interpreter in which to lookup variables, * execute nested commands, and report * errors. */ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens to * evaluate and concatenate. */ int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL); } /* *---------------------------------------------------------------------- * * Tcl_EvalTokens -- * * Given an array of tokens parsed from a Tcl command (e.g., the tokens * that make up a word or the index for an array variable) this procedure * evaluates the tokens and concatenates their values to form a single * result value. * * Results: * The return value is a pointer to a newly allocated Tcl_Obj containing * the value of the array of tokens. The reference count of the returned * object has been incremented. If an error occurs in evaluating the * tokens then a NULL value is returned and an error message is left in * interp's result. * * Side effects: * A new object is allocated to hold the result. * *---------------------------------------------------------------------- * * This uses a non-standard return convention; its use is now deprecated. It * is a wrapper for the new function Tcl_EvalTokensStandard, and is not used * in the core any longer. It is only kept for backward compatibility. */ Tcl_Obj * Tcl_EvalTokens(interp, tokenPtr, count) Tcl_Interp *interp; /* Interpreter in which to lookup variables, * execute nested commands, and report * errors. */ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens to * evaluate and concatenate. */ int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { int code; Tcl_Obj *resPtr; code = Tcl_EvalTokensStandard(interp, tokenPtr, count); if (code == TCL_OK) { resPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resPtr); Tcl_ResetResult(interp); return resPtr; } else { return NULL; } } /* *---------------------------------------------------------------------- * * Tcl_EvalEx -- * * This procedure evaluates a Tcl script without using the compiler or * byte-code interpreter. It just parses the script, creates values for * each word of each command, then calls EvalObjv to execute each * command. * * Results: * The return value is a standard Tcl completion code such as TCL_OK or * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: * Depends on the script. * *---------------------------------------------------------------------- */ 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, **objvSpace; int expandStatic[NUM_STATIC_OBJS], *expand; Tcl_Token *tokenPtr; int i, code, commandLength, bytesLeft, expandRequested; CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); /* * The variables below keep track of how much state has been allocated * while evaluating the script, so that it can be freed properly if an * error occurs. */ int gotParse = 0, objectsUsed = 0; if (numBytes < 0) { numBytes = strlen(script); } Tcl_ResetResult(interp); savedVarFramePtr = iPtr->varFramePtr; if (flags & TCL_EVAL_GLOBAL) { iPtr->varFramePtr = NULL; } /* * Each iteration through the following loop parses the next command from * the script and then executes it. */ objv = objvSpace = staticObjArray; expand = expandStatic; p = script; bytesLeft = numBytes; iPtr->evalFlags = 0; do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) { code = TCL_ERROR; goto error; } gotParse = 1; if (parse.numWords > 0) { /* * Generate an array of objects for the words of the command. */ int objectsNeeded = 0; if (parse.numWords > NUM_STATIC_OBJS) { expand = (int *) ckalloc((unsigned) (parse.numWords * sizeof(int))); objvSpace = (Tcl_Obj **) ckalloc((unsigned) (parse.numWords*sizeof(Tcl_Obj *))); } expandRequested = 0; objv = objvSpace; for (objectsUsed = 0, tokenPtr = parse.tokenPtr; objectsUsed < parse.numWords; objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { code = TclSubstTokens(interp, tokenPtr+1, tokenPtr->numComponents, NULL); if (code != TCL_OK) { goto error; } objv[objectsUsed] = Tcl_GetObjResult(interp); Tcl_IncrRefCount(objv[objectsUsed]); if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { int numElements; code = Tcl_ListObjLength(interp, objv[objectsUsed], &numElements); if (code == TCL_ERROR) { /* Attempt to expand a non-list. */ TclFormatToErrorInfo(interp, "\n (expanding word %d)", objectsUsed); Tcl_DecrRefCount(objv[objectsUsed]); goto error; } expandRequested = 1; expand[objectsUsed] = 1; objectsNeeded += (numElements ? numElements : 1); } else { expand[objectsUsed] = 0; objectsNeeded++; } } if (expandRequested) { /* * Some word expansion was requested. Check for objv resize. */ Tcl_Obj **copy = objvSpace; int wordIdx = parse.numWords; int objIdx = objectsNeeded - 1; if ((parse.numWords > NUM_STATIC_OBJS) || (objectsNeeded > NUM_STATIC_OBJS)) { objv = objvSpace = (Tcl_Obj **) ckalloc((unsigned) (objectsNeeded * sizeof(Tcl_Obj *))); } objectsUsed = 0; while (wordIdx--) { if (expand[wordIdx]) { int numElements; Tcl_Obj **elements, *temp = copy[wordIdx]; Tcl_ListObjGetElements(NULL, temp, &numElements, &elements); objectsUsed += numElements; while (numElements--) { objv[objIdx--] = elements[numElements]; Tcl_IncrRefCount(elements[numElements]); } Tcl_DecrRefCount(temp); } else { objv[objIdx--] = copy[wordIdx]; objectsUsed++; } } objv += objIdx+1; if (copy != staticObjArray) { ckfree((char *) copy); } } /* * Execute the command and free the objects for its words. */ iPtr->numLevels++; code = TclEvalObjvInternal(interp, objectsUsed, objv, parse.commandStart, parse.commandSize, 0); iPtr->numLevels--; if (code != TCL_OK) { goto error; } for (i = 0; i < objectsUsed; i++) { Tcl_DecrRefCount(objv[i]); } objectsUsed = 0; if (objvSpace != staticObjArray) { ckfree((char *) objvSpace); objvSpace = staticObjArray; } /* * Free expand separately since objvSpace could have been * reallocated above. */ if (expand != expandStatic) { ckfree((char *) expand); expand = expandStatic; } } /* * Advance to the next command in the script. */ next = parse.commandStart + parse.commandSize; bytesLeft -= next - p; p = next; Tcl_FreeParse(&parse); gotParse = 0; } while (bytesLeft > 0); iPtr->varFramePtr = savedVarFramePtr; return TCL_OK; error: /* * Generate and log various pieces of error information. */ if (iPtr->numLevels == 0) { if (code == TCL_RETURN) { code = TclUpdateReturnInfo(iPtr); } if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) { ProcessUnexpectedResult(interp, code); code = TCL_ERROR; } } if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { commandLength = parse.commandSize; if (parse.term == parse.commandStart + commandLength - 1) { /* * The terminator character (such as ; or ]) of the command where * the error occurred is the last character in the parsed command. * Reduce the length by one so that the error message doesn't * include the terminator character. */ commandLength -= 1; } Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength); } iPtr->flags &= ~ERR_ALREADY_LOGGED; /* * Then free resources that had been allocated to the command. */ for (i = 0; i < objectsUsed; i++) { Tcl_DecrRefCount(objv[i]); } if (gotParse) { Tcl_FreeParse(&parse); } |
︙ | ︙ | |||
3619 3620 3621 3622 3623 3624 3625 | } /* *---------------------------------------------------------------------- * * Tcl_Eval -- * | | | | | < | | < | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_Eval -- * * Execute a Tcl command in a string. This procedure executes the script * directly, rather than compiling it to bytecodes. Before the arrival of * the bytecode compiler in Tcl 8.0 Tcl_Eval was the main procedure used * for executing Tcl commands, but nowadays it isn't used much. * * Results: * The return value is one of the return codes defined in tcl.h (such as * TCL_OK), and interp's result contains a value to supplement the return * code. The value of the result will persist only until the next call to * Tcl_Eval or Tcl_EvalObj: you must copy it or lose it! * * Side effects: * Can be almost arbitrary, depending on the commands in the script. * *---------------------------------------------------------------------- */ int Tcl_Eval(interp, script) Tcl_Interp *interp; /* Token for command interpreter (returned by * previous call to Tcl_CreateInterp). */ CONST char *script; /* Pointer to TCL command to execute. */ { int code = Tcl_EvalEx(interp, script, -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). */ (void) Tcl_GetStringResult(interp); return code; } /* |
︙ | ︙ | |||
3697 3698 3699 3700 3701 3702 3703 | /* *---------------------------------------------------------------------- * * Tcl_EvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are | | | | | | | | | < | < | | | | | < | < | | | | | | | | | > > > > > > | < | > | > > > > > > > > > > > > | | | > > > > > > > > > > > > > > > > | | < | | | | | | > | | | | | | < | | | | | | | | < < | | > > | | > | < | < | < > | > | | < | > | > > > > | | < > > > | < | < < | | < | < < | < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > | > > > > > > > > > > > | > | | | | | | | < | | | | | > > | > > | > > > | > > > > | > > > | > > | > > | > | > > | | | | < | | | | | > > > > > > | < < < | > | > > > > | > | > | | | < | | | | < < < < < | < | | < | | | | < | < > | | | | | | | | | < | | | | | 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 | /* *---------------------------------------------------------------------- * * Tcl_EvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is * specified. * * Results: * The return value is one of the return codes defined in tcl.h (such as * TCL_OK), and the interpreter's result contains a value to supplement * the return code. * * Side effects: * The object is converted, if necessary, to a ByteCode object that holds * the bytecode instructions for the commands. Executing the commands * will almost certainly have side effects that depend on those commands. * *---------------------------------------------------------------------- */ int Tcl_EvalObjEx(interp, objPtr, flags) Tcl_Interp *interp; /* Token for command interpreter (returned by * a previous call to Tcl_CreateInterp). */ register Tcl_Obj *objPtr; /* Pointer to object containing commands to * execute. */ int flags; /* Collection of OR-ed bits that control the * evaluation of the script. Supported values * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ { register Interp *iPtr = (Interp *) interp; char *script; int numSrcBytes; int result; CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); Tcl_IncrRefCount(objPtr); if (flags & TCL_EVAL_DIRECT) { /* * We're not supposed to use the compiler or byte-code interpreter. * Let Tcl_EvalEx evaluate the command directly (and probably more * slowly). * * Pure List Optimization (no string representation). In this case, we * can safely use Tcl_EvalObjv instead and get an appreciable * improvement in execution speed. This is because it allows us to * avoid a setFromAny step that would just pack everything into a * string and back out again. * * This restriction has been relaxed a bit by storing in lists whether * they are "canonical" or not (a canonical list being one that is * either pure or that has its string rep derived by * UpdateStringOfList from the internal rep). */ if (objPtr->typePtr == &tclListType) { /* is a list... */ List *listRepPtr; listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1; if (objPtr->bytes == NULL || /* ...without a string rep */ listRepPtr->canonicalFlag) {/* ...or that is canonical */ /* * Increase the reference count of the List structure, to * avoid a segfault if objPtr loses its List internal rep [Bug * 1119369] */ listRepPtr->refCount++; result = Tcl_EvalObjv(interp, listRepPtr->elemCount, &listRepPtr->elements, flags); /* * If we are the last users of listRepPtr, free it. */ if (--listRepPtr->refCount <= 0) { int i, elemCount = listRepPtr->elemCount; Tcl_Obj **elements = &listRepPtr->elements; for (i=0; i<elemCount; i++) { Tcl_DecrRefCount(elements[i]); } ckfree((char *) listRepPtr); } goto done; } } script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); } else { /* * Let the compiler/engine subsystem do the evaluation. */ savedVarFramePtr = iPtr->varFramePtr; if (flags & TCL_EVAL_GLOBAL) { iPtr->varFramePtr = NULL; } result = TclCompEvalObj(interp, objPtr); /* * If we are again at the top level, process any unusual return code * returned by the evaluated code. */ if (iPtr->numLevels == 0) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) { ProcessUnexpectedResult(interp, result); result = TCL_ERROR; script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } } iPtr->evalFlags = 0; iPtr->varFramePtr = savedVarFramePtr; } done: TclDecrRefCount(objPtr); return result; } /* *---------------------------------------------------------------------- * * ProcessUnexpectedResult -- * * Procedure called by Tcl_EvalObj to set the interpreter's result value * to an appropriate error message when the code it evaluates returns an * unexpected result code (not TCL_OK and not TCL_ERROR) to the topmost * evaluation level. * * Results: * None. * * Side effects: * The interpreter result is set to an error message appropriate to the * result code. * *---------------------------------------------------------------------- */ static void ProcessUnexpectedResult(interp, returnCode) Tcl_Interp *interp; /* The interpreter in which the unexpected * result code was returned. */ int returnCode; /* The unexpected result code. */ { Tcl_ResetResult(interp); if (returnCode == TCL_BREAK) { Tcl_AppendResult(interp, "invoked \"break\" outside of a loop", (char *) NULL); } else if (returnCode == TCL_CONTINUE) { Tcl_AppendResult(interp, "invoked \"continue\" outside of a loop", (char *) NULL); } else { Tcl_Obj *objPtr = Tcl_NewObj(); TclObjPrintf(NULL, objPtr, "command returned bad code: %d", returnCode); Tcl_SetObjResult(interp, objPtr); } } /* *--------------------------------------------------------------------------- * * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- * * Procedures to evaluate an expression and return its value in a * particular form. * * Results: * Each of the procedures below returns a standard Tcl result. If an * error occurs then an error message is left in the interp's result. * Otherwise the value of the expression, in the appropriate form, is * stored at *ptr. If the expression had a result that was incompatible * with the desired form then an error is returned. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int Tcl_ExprLong(interp, exprstring, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ CONST char *exprstring; /* Expression to evaluate. */ long *ptr; /* Where to store result. */ { register Tcl_Obj *exprPtr; int result = TCL_OK; if (*exprstring == '\0') { /* Legacy compatibility - return 0 for the zero-length string. */ *ptr = 0; } else { exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprLongObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); if (result != TCL_OK) { (void) Tcl_GetStringResult(interp); } } return result; } int Tcl_ExprDouble(interp, exprstring, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ CONST char *exprstring; /* Expression to evaluate. */ double *ptr; /* Where to store result. */ { register Tcl_Obj *exprPtr; int result = TCL_OK; if (*exprstring == '\0') { /* Legacy compatibility - return 0 for the zero-length string. */ *ptr = 0.0; } else { exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); /* discard the expression object */ if (result != TCL_OK) { (void) Tcl_GetStringResult(interp); } } return result; } int Tcl_ExprBoolean(interp, exprstring, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ CONST char *exprstring; /* Expression to evaluate. */ int *ptr; /* Where to store 0/1 result. */ { if (*exprstring == '\0') { /* * An empty string. Just set the result boolean to 0 (false). */ *ptr = 0; return TCL_OK; } else { int result; Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); if (result != TCL_OK) { /* * Move the interpreter's object result to the string result, then * reset the object result. */ (void) Tcl_GetStringResult(interp); } return result; } } /* *-------------------------------------------------------------- * * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj -- * * Procedures to evaluate an expression in an object and return its value * in a particular form. * * Results: * Each of the procedures below returns a standard Tcl result object. If * an error occurs then an error message is left in the interpreter's * result. Otherwise the value of the expression, in the appropriate * form, is stored at *ptr. If the expression had a result that was * incompatible with the desired form then an error is returned. * * Side effects: * None. * *-------------------------------------------------------------- */ int Tcl_ExprLongObj(interp, objPtr, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ register Tcl_Obj *objPtr; /* Expression to evaluate. */ long *ptr; /* Where to store long result. */ { Tcl_Obj *resultPtr; int result, type; double d; ClientData internalPtr; result = Tcl_ExprObj(interp, objPtr, &resultPtr); if (result != TCL_OK) { return TCL_ERROR; } if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type) != TCL_OK) { return TCL_ERROR; } switch (type) { case TCL_NUMBER_DOUBLE: { mp_int big; d = *((CONST double *)internalPtr); Tcl_DecrRefCount(resultPtr); if (TclInitBignumFromDouble(interp, d, &big) != TCL_OK) { return TCL_ERROR; } resultPtr = Tcl_NewBignumObj(&big); /* FALLTHROUGH */ } case TCL_NUMBER_LONG: case TCL_NUMBER_WIDE: case TCL_NUMBER_BIG: result = Tcl_GetLongFromObj(interp, resultPtr, ptr); break; case TCL_NUMBER_NAN: Tcl_GetDoubleFromObj(interp, resultPtr, &d); result = TCL_ERROR; } Tcl_DecrRefCount(resultPtr); /* discard the result object */ return result; } int Tcl_ExprDoubleObj(interp, objPtr, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ register Tcl_Obj *objPtr; /* Expression to evaluate. */ double *ptr; /* Where to store double result. */ { Tcl_Obj *resultPtr; int result, type; ClientData internalPtr; result = Tcl_ExprObj(interp, objPtr, &resultPtr); if (result != TCL_OK) { return TCL_ERROR; } result = TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type); if (result == TCL_OK) { switch (type) { case TCL_NUMBER_NAN: #ifndef ACCEPT_NAN result = Tcl_GetDoubleFromObj( interp, resultPtr, ptr ); break; #endif case TCL_NUMBER_DOUBLE: *ptr = *((CONST double *)internalPtr); result = TCL_OK; break; default: result = Tcl_GetDoubleFromObj( interp, resultPtr, ptr ); } } Tcl_DecrRefCount(resultPtr); /* discard the result object */ return result; } int Tcl_ExprBooleanObj(interp, objPtr, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ register Tcl_Obj *objPtr; /* Expression to evaluate. */ int *ptr; /* Where to store 0/1 result. */ { Tcl_Obj *resultPtr; int result; result = Tcl_ExprObj(interp, objPtr, &resultPtr); if (result == TCL_OK) { result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); Tcl_DecrRefCount(resultPtr); /* discard the result object */ } return result; } /* *---------------------------------------------------------------------- * * TclObjInvokeNamespace -- * * Object version: Invokes a Tcl command, given an objv/objc, from either * the exposed or hidden set of commands in the given interpreter. * NOTE: The command is invoked in the global stack frame of the * interpreter or namespace, thus it cannot see any current state on the * stack of that interpreter. * * Results: * A standard Tcl result. * * Side effects: * Whatever the command does. * *---------------------------------------------------------------------- */ int TclObjInvokeNamespace(interp, objc, objv, nsPtr, flags) Tcl_Interp *interp; /* Interpreter in which command is to be * invoked. */ int objc; /* Count of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the * name of the command to invoke. */ Tcl_Namespace *nsPtr; /* The namespace to use. */ int flags; /* Combination of flags controlling the call: * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, * or TCL_INVOKE_NO_TRACEBACK. */ { int result; Tcl_CallFrame *framePtr; /* * Make the specified namespace the current namespace and invoke the * command. */ result = TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return TCL_ERROR; } result = TclObjInvoke(interp, objc, objv, flags); TclPopStackFrame(interp); return result; } /* *---------------------------------------------------------------------- * * TclObjInvoke -- * * Invokes a Tcl command, given an objv/objc, from either the exposed or * the hidden sets of commands in the given interpreter. * * Results: * A standard Tcl object result. * * Side effects: * Whatever the command does. * *---------------------------------------------------------------------- */ int TclObjInvoke(interp, objc, objv, flags) Tcl_Interp *interp; /* Interpreter in which command is to be * invoked. */ int objc; /* Count of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the * name of the command to invoke. */ int flags; /* Combination of flags controlling the call: * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, * or TCL_INVOKE_NO_TRACEBACK. */ { register Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ char *cmdName; /* Name of the command from objv[0]. */ Tcl_HashEntry *hPtr = NULL; Command *cmdPtr; int result; if (interp == (Tcl_Interp *) NULL) { return TCL_ERROR; } if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) { Tcl_AppendResult(interp, "illegal argument vector", (char *) NULL); return TCL_ERROR; } if ((flags & TCL_INVOKE_HIDDEN) == 0) { Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } if (TclInterpReady(interp) == TCL_ERROR) { |
︙ | ︙ | |||
4225 4226 4227 4228 4229 4230 4231 | if (hPtr == NULL) { Tcl_AppendResult(interp, "invalid hidden command name \"", cmdName, "\"", (char *) NULL); return TCL_ERROR; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); | > | > | | | > > > | | | < | | < < < < | < < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > | > > > > > > > > > > > > > > | | | | | | > | | | | | | | | | | | | | | < | | | | | | | | > | 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 | if (hPtr == NULL) { Tcl_AppendResult(interp, "invalid hidden command name \"", cmdName, "\"", (char *) NULL); return TCL_ERROR; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); /* * Invoke the command procedure. */ iPtr->cmdCount++; result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); /* * If an error occurred, record information about what was being executed * when the error occurred. */ if ((result == TCL_ERROR) && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { int length; Tcl_Obj *command = Tcl_NewListObj(objc, objv); CONST char* cmdString; Tcl_IncrRefCount(command); cmdString = Tcl_GetStringFromObj(command, &length); Tcl_LogCommandInfo(interp, cmdString, cmdString, length); Tcl_DecrRefCount(command); iPtr->flags &= ~ERR_ALREADY_LOGGED; } return result; } /* *--------------------------------------------------------------------------- * * Tcl_ExprString -- * * Evaluate an expression in a string and return its value in string * form. * * Results: * A standard Tcl result. If the result is TCL_OK, then the interp's * result is set to the string value of the expression. If the result is * TCL_ERROR, then the interp's result contains an error message. * * Side effects: * A Tcl object is allocated to hold a copy of the expression string. * This expression object is passed to Tcl_ExprObj and then deallocated. * *--------------------------------------------------------------------------- */ int Tcl_ExprString(interp, expr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ CONST char *expr; /* Expression to evaluate. */ { int code = TCL_OK; if (expr[0] == '\0') { /* * An empty string. Just set the interpreter's result to 0. */ Tcl_SetResult(interp, "0", TCL_VOLATILE); } else { Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1); Tcl_IncrRefCount(exprObj); code = Tcl_ExprObj(interp, exprObj, &resultPtr); Tcl_DecrRefCount(exprObj); if (code == TCL_OK) { Tcl_SetObjResult(interp, resultPtr); Tcl_DecrRefCount(resultPtr); } /* * Force the string rep of the interp result. */ (void) Tcl_GetStringResult(interp); } return code; } /* *---------------------------------------------------------------------- * * TclAppendObjToErrorInfo -- * * Add a Tcl_Obj value to the errorInfo field that describes the current * error. * * Results: * None. * * Side effects: * The value of the Tcl_obj is appended to the errorInfo field. If we are * just starting to log an error, errorInfo is initialized from the error * message in the interpreter's result. * *---------------------------------------------------------------------- */ void TclAppendObjToErrorInfo(interp, objPtr) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ Tcl_Obj *objPtr; /* Message to record. */ { int length; CONST char *message = Tcl_GetStringFromObj(objPtr, &length); Tcl_AddObjErrorInfo(interp, message, length); } /* *---------------------------------------------------------------------- * * Tcl_AddErrorInfo -- * * Add information to the errorInfo field that describes the current * error. * * Results: * None. * * Side effects: * The contents of message are appended to the errorInfo field. If we are * just starting to log an error, errorInfo is initialized from the error * message in the interpreter's result. * *---------------------------------------------------------------------- */ void Tcl_AddErrorInfo(interp, message) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ CONST char *message; /* Message to record. */ { Tcl_AddObjErrorInfo(interp, message, -1); } /* *---------------------------------------------------------------------- * * Tcl_AddObjErrorInfo -- * * Add information to the errorInfo field that describes the current * error. This routine differs from Tcl_AddErrorInfo by taking a byte * pointer and length. * * Results: * None. * * Side effects: * "length" bytes from "message" are appended to the errorInfo field. If * "length" is negative, use bytes up to the first NULL byte. If we are * just starting to log an error, errorInfo is initialized from the error * message in the interpreter's result. * *---------------------------------------------------------------------- */ void Tcl_AddObjErrorInfo(interp, message, length) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ CONST char *message; /* Points to the first byte of an array of * bytes of the message. */ int length; /* The number of bytes in the message. If < 0, * then append all bytes up to a NULL byte. */ { register Interp *iPtr = (Interp *) interp; /* * If we are just starting to log an error, errorInfo is initialized from * the error message in the interpreter's result. */ if (iPtr->errorInfo == NULL) { /* just starting to log error */ if (iPtr->result[0] != 0) { /* * The interp's string result is set, apparently by some extension * making a deprecated direct write to it. That extension may * expect interp->result to continue to be set, so we'll take * special pains to avoid clearing it, until we drop support for * interp->result completely. */ iPtr->errorInfo = Tcl_NewStringObj(interp->result, -1); } else { iPtr->errorInfo = iPtr->objResultPtr; } Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); |
︙ | ︙ | |||
4461 4462 4463 4464 4465 4466 4467 | } /* *--------------------------------------------------------------------------- * * Tcl_VarEvalVA -- * | | | | | | | | | < | 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 | } /* *--------------------------------------------------------------------------- * * Tcl_VarEvalVA -- * * Given a variable number of string arguments, concatenate them all * together and execute the result as a Tcl command. * * Results: * A standard Tcl return result. An error message or other result may be * left in the interp's result. * * Side effects: * Depends on what was done by the command. * *--------------------------------------------------------------------------- */ int Tcl_VarEvalVA(interp, argList) Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ va_list argList; /* Variable argument list. */ { Tcl_DString buf; char *string; int result; /* * Copy the strings one after the other into a single larger string. Use * stack-allocated space for small commands, but if the command gets too * large than call ckalloc to create the space. */ Tcl_DStringInit(&buf); while (1) { string = va_arg(argList, char *); if (string == NULL) { break; |
︙ | ︙ | |||
4509 4510 4511 4512 4513 4514 4515 | } /* *---------------------------------------------------------------------- * * Tcl_VarEval -- * | | | | | | | < | | | | | | < | 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 | } /* *---------------------------------------------------------------------- * * Tcl_VarEval -- * * Given a variable number of string arguments, concatenate them all * together and execute the result as a Tcl command. * * Results: * A standard Tcl return result. An error message or other result may be * left in interp->result. * * Side effects: * Depends on what was done by the command. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_VarEval(Tcl_Interp *interp, ...) { va_list argList; int result; va_start(argList, interp); result = Tcl_VarEvalVA(interp, argList); va_end(argList); return result; } /* *--------------------------------------------------------------------------- * * Tcl_GlobalEval -- * * Evaluate a command at global level in an interpreter. * * Results: * A standard Tcl result is returned, and the interp's result is modified * accordingly. * * Side effects: * The command string is executed in interp, and the execution is carried * out in the variable context of global level (no procedures active), * just as if an "uplevel #0" command were being executed. * --------------------------------------------------------------------------- */ int Tcl_GlobalEval(interp, command) Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ |
︙ | ︙ | |||
4577 4578 4579 4580 4581 4582 4583 | } /* *---------------------------------------------------------------------- * * Tcl_SetRecursionLimit -- * | | | | | | | | < | | < < | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > | 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 | } /* *---------------------------------------------------------------------- * * Tcl_SetRecursionLimit -- * * Set the maximum number of recursive calls that may be active for an * interpreter at once. * * Results: * The return value is the old limit on nesting for interp. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_SetRecursionLimit(interp, depth) Tcl_Interp *interp; /* Interpreter whose nesting limit is to be * set. */ int depth; /* New value for maximimum depth. */ { Interp *iPtr = (Interp *) interp; int old; old = iPtr->maxNestingDepth; if (depth > 0) { iPtr->maxNestingDepth = depth; } return old; } /* *---------------------------------------------------------------------- * * Tcl_AllowExceptions -- * * Sets a flag in an interpreter so that exceptions can occur in the next * call to Tcl_Eval without them being turned into errors. * * Results: * None. * * Side effects: * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's evalFlags * structure. See the reference documentation for more details. * *---------------------------------------------------------------------- */ void Tcl_AllowExceptions(interp) Tcl_Interp *interp; /* Interpreter in which to set flag. */ { Interp *iPtr = (Interp *) interp; iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; } /* *---------------------------------------------------------------------- * * Tcl_GetVersion -- * * Get the Tcl major, minor, and patchlevel version numbers and the * release type. A patch is a release type TCL_FINAL_RELEASE with a * patchLevel > 0. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_GetVersion(majorV, minorV, patchLevelV, type) int *majorV; int *minorV; int *patchLevelV; int *type; { if (majorV != NULL) { *majorV = TCL_MAJOR_VERSION; } if (minorV != NULL) { *minorV = TCL_MINOR_VERSION; } if (patchLevelV != NULL) { *patchLevelV = TCL_RELEASE_SERIAL; } if (type != NULL) { *type = TCL_RELEASE_LEVEL; } } /* *---------------------------------------------------------------------- * * Math Functions -- * * This page contains the procedures that implement all of the built-in * math functions for expressions. * * Results: * Each procedure returns TCL_OK if it succeeds and pushes an Tcl object * holding the result. If it fails it returns TCL_ERROR and leaves an * error message in the interpreter's result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ExprCeilFunc(clientData, interp, objc, objv) ClientData clientData; /* Ignored */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter list */ { int code; double d; mp_int big; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclCeil(&big))); mp_clear(&big); } else { Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d))); } return TCL_OK; } static int ExprFloorFunc(clientData, interp, objc, objv) ClientData clientData; /* Ignored */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter list */ { int code; double d; mp_int big; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclFloor(&big))); mp_clear(&big); } else { Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d))); } return TCL_OK; } static int ExprSqrtFunc(clientData, interp, objc, objv) ClientData clientData; /* Ignored */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter list */ { int code; double d; mp_int big; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } if (d >= 0.0 && TclIsInfinite(d) && Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { mp_int root; mp_init(&root); mp_sqrt(&big, &root); mp_clear(&big); Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root))); mp_clear(&root); } else { Tcl_SetObjResult(interp, Tcl_NewDoubleObj(sqrt(d))); } return TCL_OK; } static int ExprUnaryFunc(clientData, interp, objc, objv) ClientData clientData; /* Contains the address of a procedure that * takes one double argument and returns a * double result. */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter list */ { int code; double d; double (*func)(double) = (double (*)(double)) clientData; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { d = objv[1]->internalRep.doubleValue; Tcl_ResetResult(interp); code = TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } errno = 0; return CheckDoubleResult(interp, (*func)(d)); } static int CheckDoubleResult(interp, dResult) Tcl_Interp *interp; double dResult; { #ifndef ACCEPT_NAN if (TclIsNaN(dResult)) { TclExprFloatError(interp, dResult); return TCL_ERROR; } #endif if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) { /* When ERANGE signals under/overflow, just accept 0.0 or +/-Inf */ } else if (errno != 0) { /* Report other errno values as errors */ TclExprFloatError(interp, dResult); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult)); return TCL_OK; } static int ExprBinaryFunc(clientData, interp, objc, objv) ClientData clientData; /* Contains the address of a procedure that * takes two double arguments and returns a * double result. */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Parameter vector */ { int code; double d1, d2; double (*func)(double, double) = (double (*)(double, double)) clientData; if (objc != 3) { MathFuncWrongNumArgs(interp, 3, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); #ifdef ACCEPT_NAN if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { d1 = objv[1]->internalRep.doubleValue; Tcl_ResetResult(interp); code = TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); #ifdef ACCEPT_NAN if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) { d2 = objv[2]->internalRep.doubleValue; Tcl_ResetResult(interp); code = TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } errno = 0; return CheckDoubleResult(interp, (*func)(d1, d2)); } static int ExprAbsFunc(clientData, interp, objc, objv) ClientData clientData; /* Ignored. */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Parameter vector */ { ClientData ptr; int type; mp_int big; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type == TCL_NUMBER_LONG) { long l = *((CONST long int *)ptr); if (l < (long)0) { if (l == LONG_MIN) { TclBNInitBignumFromLong(&big, l); goto tooLarge; } Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); } else { Tcl_SetObjResult(interp, objv[1]); } return TCL_OK; } if (type == TCL_NUMBER_DOUBLE) { double d = *((CONST double *)ptr); if (d < 0.0) { Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); } else { Tcl_SetObjResult(interp, objv[1]); } return TCL_OK; } #ifndef NO_WIDE_TYPE if (type == TCL_NUMBER_WIDE) { Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr); if (w < (Tcl_WideInt)0) { if (w == LLONG_MIN) { TclBNInitBignumFromWideInt(&big, w); goto tooLarge; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); } else { Tcl_SetObjResult(interp, objv[1]); } return TCL_OK; } #endif if (type == TCL_NUMBER_BIG) { /* TODO: const correctness ? */ if (mp_cmp_d((mp_int *)ptr, 0) == MP_LT) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: mp_neg(&big, &big); Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); } else { Tcl_SetObjResult(interp, objv[1]); } return TCL_OK; } if (type == TCL_NUMBER_NAN) { #ifdef ACCEPT_NAN Tcl_SetObjResult(interp, objv[1]); return TCL_OK; #else double d; Tcl_GetDoubleFromObj(interp, objv[1], &d); return TCL_ERROR; #endif } } static int ExprBoolFunc(clientData, interp, objc, objv) ClientData clientData; /* Ignored. */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter vector */ { int value; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } if (Tcl_GetBooleanFromObj(interp, objv[1], &value) != TCL_OK) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); return TCL_OK; } static int ExprDoubleFunc(clientData, interp, objc, objv) ClientData clientData; /* Ignored. */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter vector */ { double dResult; #if 0 Tcl_Obj* valuePtr; Tcl_Obj* oResult; /* * Check parameter type */ if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); } else { valuePtr = objv[1]; if (VerifyExprObjType(interp, valuePtr) == TCL_OK) { GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr); TclNewDoubleObj(oResult, dResult); Tcl_SetObjResult(interp, oResult); return TCL_OK; } } return TCL_ERROR; #else if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { #ifdef ACCEPT_NAN if (objv[1]->typePtr == &tclDoubleType) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } #endif return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult)); return TCL_OK; #endif } static int ExprEntierFunc(clientData, interp, objc, objv) ClientData clientData; /* Ignored. */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter vector */ { double d; int type; ClientData ptr; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type == TCL_NUMBER_DOUBLE) { d = *((CONST double *)ptr); if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) { mp_int big; if (TclInitBignumFromDouble(interp, d, &big) != TCL_OK) { /* Infinity */ return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; } else { long result = (long)d; Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); return TCL_OK; } } if (type != TCL_NUMBER_NAN) { /* All integers are already of integer type */ Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } /* Get the error message for NaN */ Tcl_GetDoubleFromObj(interp, objv[1], &d); return TCL_ERROR; } static int ExprIntFunc(clientData, interp, objc, objv) ClientData clientData; /* Ignored. */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter vector */ { long iResult; Tcl_Obj *objPtr; #if 0 register Tcl_Obj *valuePtr; Tcl_Obj* oResult; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); } else { valuePtr = objv[1]; if (VerifyExprObjType(interp, valuePtr) == TCL_OK) { if (valuePtr->typePtr == &tclIntType) { iResult = valuePtr->internalRep.longValue; } else if (valuePtr->typePtr == &tclWideIntType) { TclGetLongFromWide(iResult,valuePtr); } else { d = valuePtr->internalRep.doubleValue; if (d < 0.0) { if (d < (double) (long) LONG_MIN) { tooLarge: Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", "integer value too large to represent", (char *) NULL); return TCL_ERROR; } } else if (d > (double) LONG_MAX) { goto tooLarge; } if (IS_NAN(d) || IS_INF(d)) { TclExprFloatError(interp, d); return TCL_ERROR; } iResult = (long) d; } TclNewIntObj(oResult, iResult); Tcl_SetObjResult(interp, oResult); return TCL_OK; } } return TCL_ERROR; #else if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { return TCL_ERROR; } objPtr = Tcl_GetObjResult(interp); if (Tcl_GetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) { /* truncate the bignum; keep only bits in long range */ mp_int big; Tcl_GetBignumFromObj(NULL, objPtr, &big); mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); objPtr = Tcl_NewBignumObj(&big); Tcl_IncrRefCount(objPtr); Tcl_GetLongFromObj(NULL, objPtr, &iResult); Tcl_DecrRefCount(objPtr); } Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult)); return TCL_OK; #endif } static int ExprWideFunc(clientData, interp, objc, objv) ClientData clientData; /* Ignored. */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter vector */ { Tcl_WideInt wResult; Tcl_Obj *objPtr; #if 0 register Tcl_Obj *valuePtr; Tcl_Obj* oResult; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); } else { valuePtr = objv[1]; if (VerifyExprObjType(interp, valuePtr) == TCL_OK) { if (valuePtr->typePtr == &tclIntType) { wResult = valuePtr->internalRep.longValue; } else if (valuePtr->typePtr == &tclWideIntType) { wResult = valuePtr->internalRep.wideValue; } else { d = valuePtr->internalRep.doubleValue; if (d < 0.0) { if (d < Tcl_WideAsDouble(LLONG_MIN)) { tooLarge: Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", "integer value too large to represent", (char *) NULL); return TCL_ERROR; } } else if (d > Tcl_WideAsDouble(LLONG_MAX)) { goto tooLarge; } if (IS_NAN(d) || IS_INF(d)) { TclExprFloatError(interp, d); return TCL_ERROR; } wResult = (Tcl_WideInt) d; } TclNewWideIntObj(oResult, wResult); Tcl_SetObjResult(interp, oResult); return TCL_OK; } } return TCL_ERROR; #else if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { return TCL_ERROR; } objPtr = Tcl_GetObjResult(interp); if (Tcl_GetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) { /* truncate the bignum; keep only bits in wide int range */ mp_int big; Tcl_GetBignumFromObj(NULL, objPtr, &big); mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big); objPtr = Tcl_NewBignumObj(&big); Tcl_IncrRefCount(objPtr); Tcl_GetWideIntFromObj(NULL, objPtr, &wResult); Tcl_DecrRefCount(objPtr); } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); return TCL_OK; #endif } static int ExprRandFunc(clientData, interp, objc, objv) ClientData clientData; /* Ignored. */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter vector */ { Interp *iPtr = (Interp *) interp; double dResult; long tmp; /* Algorithm assumes at least 32 bits. * Only long guarantees that. See below. */ Tcl_Obj* oResult; if (objc != 1) { MathFuncWrongNumArgs(interp, 1, objc, objv); return TCL_ERROR; } if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { iPtr->flags |= RAND_SEED_INITIALIZED; /* * Take into consideration the thread this interp is running in order * to insure different seeds in different threads (bug #416643) */ iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ iPtr->randSeed &= (unsigned long) 0x7fffffff; if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { iPtr->randSeed ^= 123459876; } } /* * Generate the random number using the linear congruential generator * defined by the following recurrence: * seed = ( IA * seed ) mod IM * where IA is 16807 and IM is (2^31) - 1. The recurrence maps a seed in * the range [1, IM - 1] to a new seed in that same range. The recurrence * maps IM to 0, and maps 0 back to 0, so those two values must not be * allowed as initial values of seed. * * In order to avoid potential problems with integer overflow, the * recurrence is implemented in terms of additional constants IQ and IR * such that * IM = IA*IQ + IR * None of the operations in the implementation overflows a 32-bit signed * integer, and the C type long is guaranteed to be at least 32 bits wide. * * For more details on how this algorithm works, refer to the following * papers: * * S.K. Park & K.W. Miller, "Random number generators: good ones are hard * to find," Comm ACM 31(10):1192-1201, Oct 1988 * * W.H. Press & S.A. Teukolsky, "Portable random number generators," * Computers in Physics 6(5):522-524, Sep/Oct 1992. */ #define RAND_IA 16807 #define RAND_IM 2147483647 #define RAND_IQ 127773 #define RAND_IR 2836 #define RAND_MASK 123459876 tmp = iPtr->randSeed/RAND_IQ; iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp; if (iPtr->randSeed < 0) { iPtr->randSeed += RAND_IM; } /* * Since the recurrence keeps seed values in the range [1, RAND_IM - 1], * dividing by RAND_IM yields a double in the range (0, 1). */ dResult = iPtr->randSeed * (1.0/RAND_IM); /* * Push a Tcl object with the result. */ TclNewDoubleObj(oResult, dResult); Tcl_SetObjResult(interp, oResult); return TCL_OK; } static int ExprRoundFunc(clientData, interp, objc, objv) ClientData clientData; /* Ignored. */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Parameter vector */ { double d; ClientData ptr; int type; if (objc != 2) { MathFuncWrongNumArgs(interp, 1, objc, objv); return TCL_ERROR; } if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type == TCL_NUMBER_DOUBLE) { double fractPart, intPart; long max = LONG_MAX, min = LONG_MIN; fractPart = modf(*((CONST double *)ptr), &intPart); if (fractPart <= -0.5) { min++; } else if (fractPart >= 0.5) { max--; } if ((intPart >= (double)max) || (intPart <= (double)min)) { mp_int big; if (TclInitBignumFromDouble(interp, intPart, &big) != TCL_OK) { /* Infinity */ return TCL_ERROR; } if (fractPart <= -0.5) { mp_sub_d(&big, 1, &big); } else if (fractPart >= 0.5) { mp_add_d(&big, 1, &big); } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; } else { long result = (long)intPart; if (fractPart <= -0.5) { result--; } else if (fractPart >= 0.5) { result++; } Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); return TCL_OK; } } if (type != TCL_NUMBER_NAN) { /* All integers are already rounded */ Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } /* Get the error message for NaN */ Tcl_GetDoubleFromObj(interp, objv[1], &d); return TCL_ERROR; } static int ExprSrandFunc(clientData, interp, objc, objv) ClientData clientData; /* Ignored. */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Parameter vector */ { Interp *iPtr = (Interp *) interp; long i = 0; /* Initialized to avoid compiler warning. */ /* * Convert argument and use it to reset the seed. */ if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } if (Tcl_GetLongFromObj(interp, objv[1], &i) != TCL_OK) { /* TODO: more ::errorInfo here? or in caller? */ return TCL_ERROR; } /* * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in * ExprRandFunc() for more details. */ iPtr->flags |= RAND_SEED_INITIALIZED; iPtr->randSeed = i; iPtr->randSeed &= (unsigned long) 0x7fffffff; if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { iPtr->randSeed ^= 123459876; } /* * To avoid duplicating the random number generation code we simply clean * up our state and call the real random number function. That function * will always succeed. */ return ExprRandFunc(clientData, interp, 1, objv); } /* *---------------------------------------------------------------------- * * MathFuncWrongNumArgs -- * * Generate an error message when a math function presents the wrong * number of arguments. * * Results: * None. * * Side effects: * An error message is stored in the interpreter result. * *---------------------------------------------------------------------- */ static void MathFuncWrongNumArgs(interp, expected, found, objv) Tcl_Interp* interp; /* Tcl interpreter */ int expected; /* Formal parameter count */ int found; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter vector */ { Tcl_Obj* errorMessage; CONST char* name = Tcl_GetString(objv[0]); CONST char* tail = name + strlen(name); while (tail > name+1) { --tail; if (*tail == ':' && tail[-1] == ':') { name = tail+1; break; } } errorMessage = Tcl_NewStringObj("too ", -1); if (found < expected) { Tcl_AppendToObj(errorMessage, "few", -1); } else { Tcl_AppendToObj(errorMessage, "many", -1); } Tcl_AppendToObj(errorMessage, " arguments for math function \"", -1); Tcl_AppendToObj(errorMessage, name, -1); Tcl_AppendToObj(errorMessage, "\"", -1); Tcl_SetObjResult(interp, errorMessage); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclBinary.c.
|
| | | | | < < < < | | | | | | < | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 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 | /* * tclBinary.c -- * * This file contains the implementation of the "binary" Tcl built-in * command and the Tcl binary data object. * * Copyright (c) 1997 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclBinary.c,v 1.21.2.6 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.h" #include <math.h> /* * The following constants are used by GetFormatSpec to indicate various * special conditions in the parsing of a format specifier. */ #define BINARY_ALL -1 /* Use all elements in the argument. */ #define BINARY_NOCOUNT -2 /* No count was specified in format. */ /* * The following defines the maximum number of different (integer) numbers * placed in the object cache by 'binary scan' before it bails out and * switches back to Plan A (creating a new object for each value.) * Theoretically, it would be possible to keep the cache about for the values * that are already in it, but that makes the code slower in practise when * overflow happens, and makes little odds the rest of the time (as measured * on my machine.) It is also slower (on the sample I tried at least) to grow * the cache to hold all items we might want to put in it; presumably the * extra cost of managing the memory for the enlarged table outweighs the * benefit from allocating fewer objects. This is probably because as the * number of objects increases, the likelihood of reuse of any particular one * drops, and there is very little gain from larger maximum cache sizes (the * value below is chosen to allow caching to work in full with conversion of * bytes.) - DKF */ #define BINARY_SCAN_MAX_CACHE 260 /* * Prototypes for local procedures defined in this file: */ static void DupByteArrayInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static int FormatNumber(Tcl_Interp *interp, int type, Tcl_Obj *src, unsigned char **cursorPtr); static void FreeByteArrayInternalRep(Tcl_Obj *objPtr); static int GetFormatSpec(char **formatPtr, char *cmdPtr, int *countPtr); static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, Tcl_HashTable **numberCachePtr); static int SetByteArrayFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfByteArray(Tcl_Obj *listPtr); static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); static int NeedReversing(int format); static void CopyNumber(CONST void *from, void *to, unsigned int length, int type); /* * The following object type represents an array of bytes. An array of bytes * is not equivalent to an internationalized string. Conceptually, a string is * an array of 16-bit quantities organized as a sequence of properly formed * UTF-8 characters, while a ByteArray is an array of 8-bit quantities. * Accessor functions are provided to convert a ByteArray to a String or a * String to a ByteArray. Two or more consecutive bytes in an array of bytes * may look like a single UTF-8 character if the array is casually treated as * a string. But obtaining the String from a ByteArray is guaranteed to * produced properly formed UTF-8 sequences so that there is a one-to-one map * between bytes and characters. * * Converting a ByteArray to a String proceeds by casting each byte in the * array to a 16-bit quantity, treating that number as a Unicode character, * and storing the UTF-8 version of that Unicode character in the String. For * ByteArrays consisting entirely of values 1..127, the corresponding String * representation is the same as the ByteArray representation. * * Converting a String to a ByteArray proceeds by getting the Unicode * representation of each character in the String, casting it to a byte by * truncating the upper 8 bits, and then storing the byte in the ByteArray. * Converting from ByteArray to String and back to ByteArray is not lossy, but * converting an arbitrary String to a ByteArray may be. */ Tcl_ObjType tclByteArrayType = { "bytearray", FreeByteArrayInternalRep, DupByteArrayInternalRep, UpdateStringOfByteArray, SetByteArrayFromAny }; /* * The following structure is the internal rep for a ByteArray object. Keeps * track of how much memory has been used and how much has been allocated for * the byte array to enable growing and shrinking of the ByteArray object with * fewer mallocs. */ typedef struct ByteArray { int used; /* The number of bytes used in the byte * array. */ int allocated; /* The amount of space actually allocated * minus 1 byte. */ unsigned char bytes[4]; /* The array of bytes. The actual size of this * field depends on the 'allocated' field * above. */ } ByteArray; #define BYTEARRAY_SIZE(len) \ ((unsigned) (sizeof(ByteArray) - 4 + (len))) #define GET_BYTEARRAY(objPtr) \ ((ByteArray *) (objPtr)->internalRep.otherValuePtr) #define SET_BYTEARRAY(objPtr, baPtr) \ (objPtr)->internalRep.otherValuePtr = (VOID *) (baPtr) /* *---------------------------------------------------------------------- * * Tcl_NewByteArrayObj -- * * This procedure is creates a new ByteArray object and initializes it * from the given array of bytes. * * Results: * The newly create object is returned. This object will have no initial * string representation. The returned object has a ref count of 0. * * Side effects: * Memory allocated for new object and copy of byte array argument. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewByteArrayObj Tcl_Obj * Tcl_NewByteArrayObj( CONST unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ int length) /* Length of the array of bytes, which must be * >= 0. */ { return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewByteArrayObj( CONST unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ int length) /* Length of the array of bytes, which must be * >= 0. */ { Tcl_Obj *objPtr; TclNewObj(objPtr); Tcl_SetByteArrayObj(objPtr, bytes, length); return objPtr; } |
︙ | ︙ | |||
191 192 193 194 195 196 197 | * the [memory active] command will report the correct file name and line * number when reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewByteArrayObj. * * Results: | | | < | | | | | | | | | | | | | | | | | | | | | | | | 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 | * the [memory active] command will report the correct file name and line * number when reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewByteArrayObj. * * Results: * The newly create object is returned. This object will have no initial * string representation. The returned object has a ref count of 0. * * Side effects: * Memory allocated for new object and copy of byte array argument. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewByteArrayObj( CONST unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ int length, /* Length of the array of bytes, which must be * >= 0. */ CONST char *file, /* The name of the source file calling this * procedure; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); Tcl_SetByteArrayObj(objPtr, bytes, length); return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewByteArrayObj( CONST unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ int length, /* Length of the array of bytes, which must be * >= 0. */ CONST char *file, /* The name of the source file calling this * procedure; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { return Tcl_NewByteArrayObj(bytes, length); } #endif /* TCL_MEM_DEBUG */ /* *--------------------------------------------------------------------------- * * Tcl_SetByteArrayObj -- * * Modify an object to be a ByteArray object and to have the specified * array of bytes as its value. * * Results: * None. * * Side effects: * The object's old string rep and internal rep is freed. Memory * allocated for copy of byte array argument. * *---------------------------------------------------------------------- */ void Tcl_SetByteArrayObj( Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */ CONST unsigned char *bytes, /* The array of bytes to use as the new * value. */ int length) /* Length of the array of bytes, which must be * >= 0. */ { ByteArray *byteArrayPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetByteArrayObj called with shared object"); } TclFreeIntRep(objPtr); |
︙ | ︙ | |||
286 287 288 289 290 291 292 | } /* *---------------------------------------------------------------------- * * Tcl_GetByteArrayFromObj -- * | | | | | | | | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_GetByteArrayFromObj -- * * Attempt to get the array of bytes from the Tcl object. If the object * is not already a ByteArray object, an attempt will be made to convert * it to one. * * Results: * Pointer to array of bytes representing the ByteArray object. * * Side effects: * Frees old internal rep. Allocates memory for new internal rep. * *---------------------------------------------------------------------- */ unsigned char * Tcl_GetByteArrayFromObj( Tcl_Obj *objPtr, /* The ByteArray object. */ int *lengthPtr) /* If non-NULL, filled with length of the * array of bytes in the ByteArray object. */ { ByteArray *baPtr; SetByteArrayFromAny(NULL, objPtr); baPtr = GET_BYTEARRAY(objPtr); if (lengthPtr != NULL) { *lengthPtr = baPtr->used; } return (unsigned char *) baPtr->bytes; } /* *---------------------------------------------------------------------- * * Tcl_SetByteArrayLength -- * * This procedure changes the length of the byte array for this object. * Once the caller has set the length of the array, it is acceptable to * directly modify the bytes in the array up until Tcl_GetStringFromObj() * has been called on this object. * * Results: * The new byte array of the specified length. * * Side effects: * Allocates enough memory for an array of bytes of the requested size. * When growing the array, the old array is copied to the new array; new * bytes are undefined. When shrinking, the old array is truncated to the * specified length. * *---------------------------------------------------------------------- */ unsigned char * Tcl_SetByteArrayLength( Tcl_Obj *objPtr, /* The ByteArray object. */ int length) /* New length for internal byte array. */ { ByteArray *byteArrayPtr, *newByteArrayPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetObjLength called with shared object"); } if (objPtr->typePtr != &tclByteArrayType) { SetByteArrayFromAny(NULL, objPtr); } |
︙ | ︙ | |||
385 386 387 388 389 390 391 | * Side effects: * A ByteArray object is stored as the internal rep of objPtr. * *---------------------------------------------------------------------- */ static int | | | | | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 | * Side effects: * A ByteArray object is stored as the internal rep of objPtr. * *---------------------------------------------------------------------- */ static int SetByteArrayFromAny( Tcl_Interp *interp, /* Not used. */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { int length; char *src, *srcEnd; unsigned char *dst; ByteArray *byteArrayPtr; Tcl_UniChar ch; if (objPtr->typePtr != &tclByteArrayType) { src = Tcl_GetStringFromObj(objPtr, &length); srcEnd = src + length; byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); for (dst = byteArrayPtr->bytes; src < srcEnd; ) { src += Tcl_UtfToUniChar(src, &ch); |
︙ | ︙ | |||
427 428 429 430 431 432 433 | * Deallocate the storage associated with a ByteArray data object's * internal representation. * * Results: * None. * * Side effects: | | | | | | < | | | | | | | | | | | | | | | 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 | * Deallocate the storage associated with a ByteArray data object's * internal representation. * * Results: * None. * * Side effects: * Frees memory. * *---------------------------------------------------------------------- */ static void FreeByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { ckfree((char *) GET_BYTEARRAY(objPtr)); } /* *---------------------------------------------------------------------- * * DupByteArrayInternalRep -- * * Initialize the internal representation of a ByteArray Tcl_Obj to a * copy of the internal representation of an existing ByteArray object. * * Results: * None. * * Side effects: * Allocates memory. * *---------------------------------------------------------------------- */ static void DupByteArrayInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { int length; ByteArray *srcArrayPtr, *copyArrayPtr; srcArrayPtr = GET_BYTEARRAY(srcPtr); length = srcArrayPtr->used; copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); copyArrayPtr->used = length; copyArrayPtr->allocated = length; memcpy((VOID *) copyArrayPtr->bytes, (VOID *) srcArrayPtr->bytes, (size_t) length); SET_BYTEARRAY(copyPtr, copyArrayPtr); copyPtr->typePtr = &tclByteArrayType; } /* *---------------------------------------------------------------------- * * UpdateStringOfByteArray -- * * Update the string representation for a ByteArray data object. Note: * This procedure does not invalidate an existing old string rep so * storage will be lost if this has not already been done. * * Results: * None. * * Side effects: * The object's string is set to a valid string that results from the * ByteArray-to-string conversion. * * The object becomes a string object -- the internal rep is discarded * and the typePtr becomes NULL. * *---------------------------------------------------------------------- */ static void UpdateStringOfByteArray( Tcl_Obj *objPtr) /* ByteArray object whose string rep to * update. */ { int i, length, size; unsigned char *src; char *dst; ByteArray *byteArrayPtr; byteArrayPtr = GET_BYTEARRAY(objPtr); src = byteArrayPtr->bytes; length = byteArrayPtr->used; /* * How much space will string rep need? */ size = length; for (i = 0; i < length; i++) { if ((src[i] == 0) || (src[i] > 127)) { size++; } } |
︙ | ︙ | |||
557 558 559 560 561 562 563 | * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ int | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | < | | | | | < | | | | | < | | | | | < | | | | | < | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | < | | | | | | | | | | | | < | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | < | | | | | | | | | | | | < | | | | | | | | < | | | | | < | | | | | | | | | | | | < | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | < | | | | | < | | | | | < | | | | | < | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | < | | < | | | | | | | | | | | | | | | | | | < | | | | | < | | | | | | | | | | < | | | | | | | | | | | < | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_BinaryObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { int arg; /* Index of next argument to consume. */ int value = 0; /* Current integer value to be packed. * Initialized to avoid compiler warning. */ char cmd; /* Current format character. */ int count; /* Count associated with current format * character. */ char *format; /* Pointer to current position in format * string. */ Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */ unsigned char *buffer; /* Start of result buffer. */ unsigned char *cursor; /* Current position within result buffer. */ unsigned char *maxPos; /* Greatest position within result buffer that * cursor has visited.*/ char *errorString, *errorValue, *str; int offset, size, length, index; static CONST char *options[] = { "format", "scan", NULL }; enum options { BINARY_FORMAT, BINARY_SCAN }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { case BINARY_FORMAT: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?"); return TCL_ERROR; } /* * To avoid copying the data, we format the string in two passes. The * first pass computes the size of the output buffer. The second pass * places the formatted data into the buffer. */ format = Tcl_GetString(objv[2]); arg = 3; offset = 0; length = 0; while (*format != '\0') { str = format; if (!GetFormatSpec(&format, &cmd, &count)) { break; } switch (cmd) { case 'a': case 'A': case 'b': case 'B': case 'h': case 'H': /* * For string-type specifiers, the count corresponds to the * number of bytes in a single argument. */ if (arg >= objc) { goto badIndex; } if (count == BINARY_ALL) { Tcl_GetByteArrayFromObj(objv[arg], &count); } else if (count == BINARY_NOCOUNT) { count = 1; } arg++; if (cmd == 'a' || cmd == 'A') { offset += count; } else if (cmd == 'b' || cmd == 'B') { offset += (count + 7) / 8; } else { offset += (count + 1) / 2; } break; case 'c': size = 1; goto doNumbers; case 't': case 's': case 'S': size = 2; goto doNumbers; case 'n': case 'i': case 'I': size = 4; goto doNumbers; case 'm': case 'w': case 'W': size = 8; goto doNumbers; case 'r': case 'R': case 'f': size = sizeof(float); goto doNumbers; case 'q': case 'Q': case 'd': size = sizeof(double); doNumbers: if (arg >= objc) { goto badIndex; } /* * For number-type specifiers, the count corresponds to the * number of elements in the list stored in a single argument. * If no count is specified, then the argument is taken as a * single non-list value. */ if (count == BINARY_NOCOUNT) { arg++; count = 1; } else { int listc; Tcl_Obj **listv; if (Tcl_ListObjGetElements(interp, objv[arg++], &listc, &listv) != TCL_OK) { return TCL_ERROR; } if (count == BINARY_ALL) { count = listc; } else if (count > listc) { Tcl_AppendResult(interp, "number of elements in list does not match count", (char *) NULL); return TCL_ERROR; } } offset += count*size; break; case 'x': if (count == BINARY_ALL) { Tcl_AppendResult(interp, "cannot use \"*\" in format string with \"x\"", (char *) NULL); return TCL_ERROR; } else if (count == BINARY_NOCOUNT) { count = 1; } offset += count; break; case 'X': if (count == BINARY_NOCOUNT) { count = 1; } if ((count > offset) || (count == BINARY_ALL)) { count = offset; } if (offset > length) { length = offset; } offset -= count; break; case '@': if (offset > length) { length = offset; } if (count == BINARY_ALL) { offset = length; } else if (count == BINARY_NOCOUNT) { goto badCount; } else { offset = count; } break; default: errorString = str; goto badField; } } if (offset > length) { length = offset; } if (length == 0) { return TCL_OK; } /* * Prepare the result object by preallocating the caclulated number of * bytes and filling with nulls. */ resultPtr = Tcl_NewObj(); buffer = Tcl_SetByteArrayLength(resultPtr, length); memset((VOID *) buffer, 0, (size_t) length); /* * Pack the data into the result object. Note that we can skip the * error checking during this pass, since we have already parsed the * string once. */ arg = 3; format = Tcl_GetString(objv[2]); cursor = buffer; maxPos = cursor; while (*format != 0) { if (!GetFormatSpec(&format, &cmd, &count)) { break; } if ((count == 0) && (cmd != '@')) { arg++; continue; } switch (cmd) { case 'a': case 'A': { char pad = (char) (cmd == 'a' ? '\0' : ' '); unsigned char *bytes; bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); if (count == BINARY_ALL) { count = length; } else if (count == BINARY_NOCOUNT) { count = 1; } if (length >= count) { memcpy((VOID *) cursor, (VOID *) bytes, (size_t) count); } else { memcpy((VOID *) cursor, (VOID *) bytes, (size_t) length); memset((VOID *) (cursor + length), pad, (size_t) (count - length)); } cursor += count; break; } case 'b': case 'B': { unsigned char *last; str = Tcl_GetStringFromObj(objv[arg++], &length); if (count == BINARY_ALL) { count = length; } else if (count == BINARY_NOCOUNT) { count = 1; } last = cursor + ((count + 7) / 8); if (count > length) { count = length; } value = 0; errorString = "binary"; if (cmd == 'B') { for (offset = 0; offset < count; offset++) { value <<= 1; if (str[offset] == '1') { value |= 1; } else if (str[offset] != '0') { errorValue = str; goto badValue; } if (((offset + 1) % 8) == 0) { *cursor++ = (unsigned char) value; value = 0; } } } else { for (offset = 0; offset < count; offset++) { value >>= 1; if (str[offset] == '1') { value |= 128; } else if (str[offset] != '0') { errorValue = str; goto badValue; } if (!((offset + 1) % 8)) { *cursor++ = (unsigned char) value; value = 0; } } } if ((offset % 8) != 0) { if (cmd == 'B') { value <<= 8 - (offset % 8); } else { value >>= 8 - (offset % 8); } *cursor++ = (unsigned char) value; } while (cursor < last) { *cursor++ = '\0'; } break; } case 'h': case 'H': { unsigned char *last; int c; str = Tcl_GetStringFromObj(objv[arg++], &length); if (count == BINARY_ALL) { count = length; } else if (count == BINARY_NOCOUNT) { count = 1; } last = cursor + ((count + 1) / 2); if (count > length) { count = length; } value = 0; errorString = "hexadecimal"; if (cmd == 'H') { for (offset = 0; offset < count; offset++) { value <<= 4; if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ errorValue = str; goto badValue; } c = str[offset] - '0'; if (c > 9) { c += ('0' - 'A') + 10; } if (c > 16) { c += ('A' - 'a'); } value |= (c & 0xf); if (offset % 2) { *cursor++ = (char) value; value = 0; } } } else { for (offset = 0; offset < count; offset++) { value >>= 4; if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ errorValue = str; goto badValue; } c = str[offset] - '0'; if (c > 9) { c += ('0' - 'A') + 10; } if (c > 16) { c += ('A' - 'a'); } value |= ((c << 4) & 0xf0); if (offset % 2) { *cursor++ = (unsigned char)(value & 0xff); value = 0; } } } if (offset % 2) { if (cmd == 'H') { value <<= 4; } else { value >>= 4; } *cursor++ = (unsigned char) value; } while (cursor < last) { *cursor++ = '\0'; } break; } case 'c': case 't': case 's': case 'S': case 'n': case 'i': case 'I': case 'm': case 'w': case 'W': case 'r': case 'R': case 'd': case 'q': case 'Q': case 'f': { int listc, i; Tcl_Obj **listv; if (count == BINARY_NOCOUNT) { /* * Note that we are casting away the const-ness of objv, * but this is safe since we aren't going to modify the * array. */ listv = (Tcl_Obj**)(objv + arg); listc = 1; count = 1; } else { Tcl_ListObjGetElements(interp, objv[arg], &listc, &listv); if (count == BINARY_ALL) { count = listc; } } arg++; for (i = 0; i < count; i++) { if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) { return TCL_ERROR; } } break; } case 'x': if (count == BINARY_NOCOUNT) { count = 1; } memset(cursor, 0, (size_t) count); cursor += count; break; case 'X': if (cursor > maxPos) { maxPos = cursor; } if (count == BINARY_NOCOUNT) { count = 1; } if ((count == BINARY_ALL) || (count > (cursor - buffer))) { cursor = buffer; } else { cursor -= count; } break; case '@': if (cursor > maxPos) { maxPos = cursor; } if (count == BINARY_ALL) { cursor = maxPos; } else { cursor = buffer + count; } break; } } Tcl_SetObjResult(interp, resultPtr); break; case BINARY_SCAN: { int i; Tcl_Obj *valuePtr, *elementPtr; Tcl_HashTable numberCacheHash; Tcl_HashTable *numberCachePtr; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "value formatString ?varName varName ...?"); return TCL_ERROR; } numberCachePtr = &numberCacheHash; Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); buffer = Tcl_GetByteArrayFromObj(objv[2], &length); format = Tcl_GetString(objv[3]); cursor = buffer; arg = 4; offset = 0; while (*format != '\0') { str = format; if (!GetFormatSpec(&format, &cmd, &count)) { goto done; } switch (cmd) { case 'a': case 'A': { unsigned char *src; if (arg >= objc) { DeleteScanNumberCache(numberCachePtr); goto badIndex; } if (count == BINARY_ALL) { count = length - offset; } else { if (count == BINARY_NOCOUNT) { count = 1; } if (count > (length - offset)) { goto done; } } src = buffer + offset; size = count; /* * Trim trailing nulls and spaces, if necessary. */ if (cmd == 'A') { while (size > 0) { if (src[size-1] != '\0' && src[size-1] != ' ') { break; } size--; } } /* * Have to do this #ifdef-fery because (as part of defining * Tcl_NewByteArrayObj) we removed the #def that hides this * stuff normally. If this code ever gets copied to another * file, it should be changed back to the simpler version. */ #ifdef TCL_MEM_DEBUG valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__,__LINE__); #else valuePtr = Tcl_NewByteArrayObj(src, size); #endif /* TCL_MEM_DEBUG */ resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { DeleteScanNumberCache(numberCachePtr); Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } offset += count; break; } case 'b': case 'B': { unsigned char *src; char *dest; if (arg >= objc) { DeleteScanNumberCache(numberCachePtr); goto badIndex; } if (count == BINARY_ALL) { count = (length - offset) * 8; } else { if (count == BINARY_NOCOUNT) { count = 1; } if (count > (length - offset) * 8) { goto done; } } src = buffer + offset; valuePtr = Tcl_NewObj(); Tcl_SetObjLength(valuePtr, count); dest = Tcl_GetString(valuePtr); if (cmd == 'b') { for (i = 0; i < count; i++) { if (i % 8) { value >>= 1; } else { value = *src++; } *dest++ = (char) ((value & 1) ? '1' : '0'); } } else { for (i = 0; i < count; i++) { if (i % 8) { value <<= 1; } else { value = *src++; } *dest++ = (char) ((value & 0x80) ? '1' : '0'); } } resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { DeleteScanNumberCache(numberCachePtr); Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } offset += (count + 7 ) / 8; break; } case 'h': case 'H': { char *dest; unsigned char *src; int i; static CONST char hexdigit[] = "0123456789abcdef"; if (arg >= objc) { DeleteScanNumberCache(numberCachePtr); goto badIndex; } if (count == BINARY_ALL) { count = (length - offset)*2; } else { if (count == BINARY_NOCOUNT) { count = 1; } if (count > (length - offset)*2) { goto done; } } src = buffer + offset; valuePtr = Tcl_NewObj(); Tcl_SetObjLength(valuePtr, count); dest = Tcl_GetString(valuePtr); if (cmd == 'h') { for (i = 0; i < count; i++) { if (i % 2) { value >>= 4; } else { value = *src++; } *dest++ = hexdigit[value & 0xf]; } } else { for (i = 0; i < count; i++) { if (i % 2) { value <<= 4; } else { value = *src++; } *dest++ = hexdigit[(value >> 4) & 0xf]; } } resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { DeleteScanNumberCache(numberCachePtr); Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } offset += (count + 1) / 2; break; } case 'c': size = 1; goto scanNumber; case 't': case 's': case 'S': size = 2; goto scanNumber; case 'n': case 'i': case 'I': size = 4; goto scanNumber; case 'm': case 'w': case 'W': size = 8; goto scanNumber; case 'r': case 'R': case 'f': size = sizeof(float); goto scanNumber; case 'q': case 'Q': case 'd': { unsigned char *src; size = sizeof(double); /* fall through */ scanNumber: if (arg >= objc) { DeleteScanNumberCache(numberCachePtr); goto badIndex; } if (count == BINARY_NOCOUNT) { if ((length - offset) < size) { goto done; } valuePtr = ScanNumber(buffer+offset, cmd, &numberCachePtr); offset += size; } else { if (count == BINARY_ALL) { count = (length - offset) / size; } if ((length - offset) < (count * size)) { goto done; } valuePtr = Tcl_NewObj(); src = buffer+offset; for (i = 0; i < count; i++) { elementPtr = ScanNumber(src, cmd, &numberCachePtr); src += size; Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr); } offset += count*size; } resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { DeleteScanNumberCache(numberCachePtr); Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } break; } case 'x': if (count == BINARY_NOCOUNT) { count = 1; } if ((count == BINARY_ALL) || (count > (length - offset))) { offset = length; } else { offset += count; } break; case 'X': if (count == BINARY_NOCOUNT) { count = 1; } if ((count == BINARY_ALL) || (count > offset)) { offset = 0; } else { offset -= count; } break; case '@': if (count == BINARY_NOCOUNT) { DeleteScanNumberCache(numberCachePtr); goto badCount; } if ((count == BINARY_ALL) || (count > length)) { offset = length; } else { offset = count; } break; default: DeleteScanNumberCache(numberCachePtr); errorString = str; goto badField; } } /* * Set the result to the last position of the cursor. */ done: Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4)); DeleteScanNumberCache(numberCachePtr); break; } } return TCL_OK; badValue: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected ", errorString, " string but got \"", errorValue, "\" instead", NULL); return TCL_ERROR; badCount: errorString = "missing count for \"@\" field specifier"; goto error; badIndex: errorString = "not enough arguments for all format specifiers"; goto error; badField: { Tcl_UniChar ch; char buf[TCL_UTF_MAX + 1]; Tcl_UtfToUniChar(errorString, &ch); buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); return TCL_ERROR; } error: Tcl_AppendResult(interp, errorString, NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * GetFormatSpec -- * * This function parses the format strings used in the binary format and * scan commands. * * Results: * Moves the formatPtr to the start of the next command. Returns the * current command character and count in cmdPtr and countPtr. The count * is set to BINARY_ALL if the count character was '*' or BINARY_NOCOUNT * if no count was specified. Returns 1 on success, or 0 if the string * did not have a format specifier. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int GetFormatSpec( char **formatPtr, /* Pointer to format string. */ char *cmdPtr, /* Pointer to location of command char. */ int *countPtr) /* Pointer to repeat count value. */ { /* * Skip any leading blanks. */ while (**formatPtr == ' ') { (*formatPtr)++; |
︙ | ︙ | |||
1441 1442 1443 1444 1445 1446 1447 | } /* *---------------------------------------------------------------------- * * NeedReversing -- * | | | | | < | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * NeedReversing -- * * This routine determines, if bytes of a number need to be reversed. * This depends on the endiannes of the machine and the desired format. * It is in effect a table (whose contents depend on the endianness of * the system) describing whether a value needs reversing or not. Anyone * porting the code to a big-endian platform should take care to make * sure that they define WORDS_BIGENDIAN though this is already done by * configure for the Unix build; little-endian platforms (including * Windows) don't need to do anything. * * Results: * 1 if reversion is required, 0 if not. * * Side effects: * None * *---------------------------------------------------------------------- */ static int NeedReversing( int format) { switch (format) { /* native floats and doubles: never reverse */ case 'd': case 'f': /* big endian ints: never reverse */ case 'I': |
︙ | ︙ | |||
1516 1517 1518 1519 1520 1521 1522 | } /* *---------------------------------------------------------------------- * * CopyNumber -- * | | | | | < | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * CopyNumber -- * * This routine is called by FormatNumber and ScanNumber to copy a * floating-point number. If required, bytes are reversed while copying. * The behaviour is only fully defined when used with IEEE float and * double values (guaranteed to be 4 and 8 bytes long, respectively.) * * Results: * None * * Side effects: * Copies length bytes * *---------------------------------------------------------------------- */ static void CopyNumber( CONST void *from, /* source */ void *to, /* destination */ unsigned int length, /* Number of bytes to copy */ int type) /* What type of thing are we copying? */ { if (NeedReversing(type)) { CONST unsigned char *fromPtr = (CONST unsigned char *) from; unsigned char *toPtr = (unsigned char *) to; switch (length) { case 4: |
︙ | ︙ | |||
1561 1562 1563 1564 1565 1566 1567 | toPtr[4] = fromPtr[3]; toPtr[5] = fromPtr[2]; toPtr[6] = fromPtr[1]; toPtr[7] = fromPtr[0]; break; } } else { | | | | | | | | | | | > > > | > > | > > > | > > | | | | 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 | toPtr[4] = fromPtr[3]; toPtr[5] = fromPtr[2]; toPtr[6] = fromPtr[1]; toPtr[7] = fromPtr[0]; break; } } else { memcpy(to, from, length); } } /* *---------------------------------------------------------------------- * * FormatNumber -- * * This routine is called by Tcl_BinaryObjCmd to format a number into a * location pointed at by cursor. * * Results: * A standard Tcl result. * * Side effects: * Moves the cursor to the next location to be written into. * *---------------------------------------------------------------------- */ static int FormatNumber( Tcl_Interp *interp, /* Current interpreter, used to report * errors. */ int type, /* Type of number to format. */ Tcl_Obj *src, /* Number to format. */ unsigned char **cursorPtr) /* Pointer to index into destination buffer. */ { long value; double dvalue; Tcl_WideInt wvalue; float fvalue; switch (type) { case 'd': case 'q': case 'Q': /* * Double-precision floating point values. Tcl_GetDoubleFromObj * returns TCL_ERROR for NaN, but we can check by comparing the * object's type pointer. */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { if ( src->typePtr != &tclDoubleType ) { return TCL_ERROR; } dvalue = src->internalRep.doubleValue; } CopyNumber(&dvalue, *cursorPtr, sizeof(double), type); *cursorPtr += sizeof(double); return TCL_OK; case 'f': case 'r': case 'R': /* * Single-precision floating point values. Tcl_GetDoubleFromObj * returns TCL_ERROR for NaN, but we can check by comparing the * object's type pointer. */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { if ( src->typePtr != &tclDoubleType ) { return TCL_ERROR; } dvalue = src->internalRep.doubleValue; } /* * Because some compilers will generate floating point exceptions on * an overflow cast (e.g. Borland), we restrict the values to the * valid range for float. */ if (fabs(dvalue) > (double)FLT_MAX) { fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX; } else { fvalue = (float) dvalue; } |
︙ | ︙ | |||
1715 1716 1717 1718 1719 1720 1721 | */ case 'c': if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } *(*cursorPtr)++ = (unsigned char) value; return TCL_OK; | | | | | | | | | | | | | | | | | | | | | 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 | */ case 'c': if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } *(*cursorPtr)++ = (unsigned char) value; return TCL_OK; default: Tcl_Panic("unexpected fallthrough"); return TCL_ERROR; } } /* *---------------------------------------------------------------------- * * ScanNumber -- * * This routine is called by Tcl_BinaryObjCmd to scan a number out of a * buffer. * * Results: * Returns a newly created object containing the scanned number. This * object has a ref count of zero. * * Side effects: * Might reuse an object in the number cache, place a new object in the * cache, or delete the cache and set the reference to it (itself passed * in by reference) to NULL. * *---------------------------------------------------------------------- */ static Tcl_Obj * ScanNumber( unsigned char *buffer, /* Buffer to scan number from. */ int type, /* Format character from "binary scan" */ Tcl_HashTable **numberCachePtrPtr) /* Place to look for cache of scanned * value objects, or NULL if too many * different numbers have been scanned. */ { long value; float fvalue; double dvalue; Tcl_WideUInt uwvalue; /* * We cannot rely on the compiler to properly sign extend integer values * when we cast from smaller values to larger values because we don't know * the exact size of the integer types. So, we have to handle sign * extension explicitly by checking the high bit and padding with 1's as * needed. */ switch (type) { case 'c': /* * Characters need special handling. We want to produce a signed * result, but on some platforms (such as AIX) chars are unsigned. To * deal with this, check for a value that should be negative but * isn't. */ value = buffer[0]; if (value & 0x80) { value |= -0x100; } goto returnNumericObject; /* * 16-bit numeric values. We need the sign extension trick (see above) * here as well. */ case 's': case 'S': case 't': if (NeedReversing(type)) { value = (long) (buffer[0] + (buffer[1] << 8)); |
︙ | ︙ | |||
1805 1806 1807 1808 1809 1810 1811 | * 32-bit numeric values. */ case 'i': case 'I': case 'n': if (NeedReversing(type)) { | | | | | 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 | * 32-bit numeric values. */ case 'i': case 'I': case 'n': if (NeedReversing(type)) { value = (long) (buffer[0] + (buffer[1] << 8) + (buffer[2] << 16) + (buffer[3] << 24)); } else { value = (long) (buffer[3] + (buffer[2] << 8) + (buffer[1] << 16) + (buffer[0] << 24)); } /* * Check to see if the value was sign extended properly on systems * where an int is more than 32-bits. */ if ((value & (((unsigned int)1)<<31)) && (value > 0)) { value -= (((unsigned int)1)<<31); value -= (((unsigned int)1)<<31); } |
︙ | ︙ | |||
1840 1841 1842 1843 1844 1845 1846 | int isNew; hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew); if (!isNew) { return (Tcl_Obj *) Tcl_GetHashValue(hPtr); } if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) { | < | | | < | | | | | 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 | int isNew; hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew); if (!isNew) { return (Tcl_Obj *) Tcl_GetHashValue(hPtr); } if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) { /* * We've overflowed the cache! Someone's parsing a LOT of * varied binary data in a single call! Bail out by switching * back to the old behaviour for the rest of the scan. * * Note that anyone just using the 'c' conversion (for bytes) * cannot trigger this. */ DeleteScanNumberCache(tablePtr); *numberCachePtrPtr = NULL; return Tcl_NewLongObj(value); } else { register Tcl_Obj *objPtr = Tcl_NewLongObj(value); Tcl_IncrRefCount(objPtr); Tcl_SetHashValue(hPtr, (ClientData) objPtr); return objPtr; } } /* * Do not cache wide (64-bit) values; they are already too large to * use as keys. */ case 'w': case 'W': case 'm': if (NeedReversing(type)) { uwvalue = ((Tcl_WideUInt) buffer[0]) |
︙ | ︙ | |||
1893 1894 1895 1896 1897 1898 1899 | | (((Tcl_WideUInt) buffer[2]) << 40) | (((Tcl_WideUInt) buffer[1]) << 48) | (((Tcl_WideUInt) buffer[0]) << 56); } return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue); /* | | | | | 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 | | (((Tcl_WideUInt) buffer[2]) << 40) | (((Tcl_WideUInt) buffer[1]) << 48) | (((Tcl_WideUInt) buffer[0]) << 56); } return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue); /* * Do not cache double values; they are already too large to use as * keys and the values stored are utterly incompatible with the * integer part of the cache. */ /* * 32-bit IEEE single-precision floating point. */ case 'f': |
︙ | ︙ | |||
1925 1926 1927 1928 1929 1930 1931 | return NULL; } /* *---------------------------------------------------------------------- * * DeleteScanNumberCache -- | | | | > | | > > > > > > > > | 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 | return NULL; } /* *---------------------------------------------------------------------- * * DeleteScanNumberCache -- * * Deletes the hash table acting as a scan number cache. * * Results: * None * * Side effects: * Decrements the reference counts of the objects in the cache. * *---------------------------------------------------------------------- */ static void DeleteScanNumberCache( Tcl_HashTable *numberCachePtr) /* Pointer to the hash table, or NULL (when * the cache has already been deleted due to * overflow.) */ { Tcl_HashEntry *hEntry; Tcl_HashSearch search; if (numberCachePtr == NULL) { return; } hEntry = Tcl_FirstHashEntry(numberCachePtr, &search); while (hEntry != NULL) { register Tcl_Obj *value = (Tcl_Obj *) Tcl_GetHashValue(hEntry); if (value != NULL) { Tcl_DecrRefCount(value); } hEntry = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(numberCachePtr); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclCkalloc.c.
|
| | | | > | | | | | | | | | | | | | | | | < | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | /* * tclCkalloc.c -- * * Interface to malloc and free that provides support for debugging * problems involving overwritten, double freeing memory and loss of * memory. * * 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. * * This code contributed by Karl Lehenbauer and Mark Diekhans * * RCS: @(#) $Id: tclCkalloc.c,v 1.22.2.2 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" #define FALSE 0 #define TRUE 1 #ifdef TCL_MEM_DEBUG /* * One of the following structures is allocated each time the * "memory tag" command is invoked, to hold the current tag. */ typedef struct MemTag { int refCount; /* Number of mem_headers referencing this * tag. */ char string[4]; /* Actual size of string will be as large as * needed for actual tag. This must be the * last field in the structure. */ } MemTag; #define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3) static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * by "memory tag" command). */ /* * One of the following structures is allocated just before each dynamically * allocated chunk of memory, both to record information about the chunk and * to help detect chunk under-runs. */ #define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8) struct mem_header { struct mem_header *flink; struct mem_header *blink; MemTag *tagPtr; /* Tag from "memory tag" command; may be * NULL. */ CONST char *file; long length; int line; unsigned char low_guard[LOW_GUARD_SIZE]; /* Aligns body on 8-byte boundary, plus * provides at least 8 additional guard bytes * to detect underruns. */ char body[1]; /* First byte of client's space. Actual size * of this field will be larger than one. */ }; static struct mem_header *allocHead = NULL; /* List of allocated structures */ #define GUARD_VALUE 0141 /* * The following macro determines the amount of guard space *above* each chunk * of memory. */ #define HIGH_GUARD_SIZE 8 /* * The following macro computes the offset of the "body" field within * mem_header. It is used to get back to the header pointer from the body * pointer that's used by clients. */ #define BODY_OFFSET \ ((unsigned long) (&((struct mem_header *) 0)->body)) static int total_mallocs = 0; static int total_frees = 0; |
︙ | ︙ | |||
98 99 100 101 102 103 104 | #ifdef MEM_VALIDATE static int validate_memory = TRUE; #else static int validate_memory = FALSE; #endif /* | | | | | | | | > > | | | | > | | | | | | | | | 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 | #ifdef MEM_VALIDATE static int validate_memory = TRUE; #else static int validate_memory = FALSE; #endif /* * The following variable indicates to TclFinalizeMemorySubsystem() that it * should dump out the state of memory before exiting. If the value is * non-NULL, it gives the name of the file in which to dump memory usage * information. */ char *tclMemDumpFileName = NULL; static char *onExitMemDumpFileName = NULL; static char dumpFile[100]; /* Records where to dump memory allocation * information. */ /* * Mutex to serialize allocations. This is a low-level mutex that must be * explicitly initialized. This is necessary because the self initializing * mutexes use ckalloc... */ static Tcl_Mutex *ckallocMutexPtr; 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)); /* *---------------------------------------------------------------------- * * TclInitDbCkalloc -- * * Initialize the locks used by the allocator. This is only appropriate * to call in a single threaded environment, such as during * TclInitSubsystems. * *---------------------------------------------------------------------- */ void TclInitDbCkalloc() { if (!ckallocInit) { ckallocInit = 1; ckallocMutexPtr = Tcl_GetAllocMutex(); } } /* *---------------------------------------------------------------------- * * TclDumpMemoryInfo -- * * Display the global memory management statistics. * *---------------------------------------------------------------------- */ void TclDumpMemoryInfo(outFile) FILE *outFile; { fprintf(outFile,"total mallocs %10d\n", total_mallocs); fprintf(outFile,"total frees %10d\n", total_frees); fprintf(outFile,"current packets allocated %10d\n", current_malloc_packets); fprintf(outFile,"current bytes allocated %10d\n", current_bytes_malloced); fprintf(outFile,"maximum packets allocated %10d\n", maximum_malloc_packets); fprintf(outFile,"maximum bytes allocated %10d\n", maximum_bytes_malloced); } /* *---------------------------------------------------------------------- * * ValidateMemory -- |
︙ | ︙ | |||
209 210 211 212 213 214 215 | * memory guards are to be reset to 0 * after they have been printed */ { unsigned char *hiPtr; int idx; int guard_failed = FALSE; int byte; | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | * memory guards are to be reset to 0 * after they have been printed */ { unsigned char *hiPtr; int idx; int guard_failed = FALSE; int byte; for (idx = 0; idx < LOW_GUARD_SIZE; idx++) { byte = *(memHeaderP->low_guard + idx); if (byte != GUARD_VALUE) { guard_failed = TRUE; fflush(stdout); byte &= 0xff; fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ } } if (guard_failed) { TclDumpMemoryInfo (stderr); fprintf(stderr, "low guard failed at %lx, %s %d\n", (long unsigned int) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length; for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) { byte = *(hiPtr + idx); if (byte != GUARD_VALUE) { guard_failed = TRUE; fflush(stdout); byte &= 0xff; fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ } } if (guard_failed) { TclDumpMemoryInfo(stderr); fprintf(stderr, "high guard failed at %lx, %s %d\n", (long unsigned int) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } if (nukeGuards) { memset((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE); memset((char *) hiPtr, 0, HIGH_GUARD_SIZE); } } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
278 279 280 281 282 283 284 | * Displays memory validation information to stderr. * *---------------------------------------------------------------------- */ void Tcl_ValidateAllMemory(file, line) | | > > | | | | > | | | | | | | < | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | 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 | * Displays memory validation information to stderr. * *---------------------------------------------------------------------- */ void Tcl_ValidateAllMemory(file, line) CONST char *file; /* File from which Tcl_ValidateAllMemory was * called. */ int line; /* Line number of call to * Tcl_ValidateAllMemory */ { struct mem_header *memScanP; if (!ckallocInit) { TclInitDbCkalloc(); } Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { ValidateMemory(memScanP, file, line, FALSE); } Tcl_MutexUnlock(ckallocMutexPtr); } /* *---------------------------------------------------------------------- * * Tcl_DumpActiveMemory -- * * Displays all allocated memory to a file; if no filename is given, * information will be written to stderr. * * Results: * Return TCL_ERROR if an error accessing the file occurs, `errno' will * have the file error number left in it. * *---------------------------------------------------------------------- */ int Tcl_DumpActiveMemory (fileName) CONST char *fileName; /* Name of the file to write info to */ { FILE *fileP; struct mem_header *memScanP; char *address; if (fileName == NULL) { fileP = stderr; } else { fileP = fopen(fileName, "w"); if (fileP == NULL) { return TCL_ERROR; } } Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body [0]; fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", (long unsigned int) address, (long unsigned int) address + memScanP->length - 1, memScanP->length, memScanP->file, memScanP->line, (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); } Tcl_MutexUnlock(ckallocMutexPtr); if (fileP != stderr) { fclose(fileP); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_DbCkalloc - debugging ckalloc * * Allocate the requested amount of space plus some extra for guard bands * at both ends of the request, plus a size, panicing if there isn't * enough space, then write in the guard bands and return the address of * the space in the middle that the user asked for. * * The second and third arguments are file and line, these contain the * filename and line number corresponding to the caller. These are sent * by the ckalloc macro; it uses the preprocessor autodefines __FILE__ * and __LINE__. * *---------------------------------------------------------------------- */ char * Tcl_DbCkalloc(size, file, line) unsigned int size; CONST char *file; int line; { struct mem_header *result; if (validate_memory) { 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); Tcl_Panic("unable to alloc %u 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. */ if (init_malloced_bodies) { memset((VOID *) result, GUARD_VALUE, size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } else { memset((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); } if (!ckallocInit) { TclInitDbCkalloc(); } Tcl_MutexLock(ckallocMutexPtr); result->length = size; result->tagPtr = curTagPtr; if (curTagPtr != NULL) { curTagPtr->refCount++; } result->file = file; result->line = line; result->flink = allocHead; result->blink = NULL; if (allocHead != NULL) { allocHead->blink = result; } allocHead = result; total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); fprintf(stderr, "reached malloc trace enable point (%d)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; trace_on_at_malloc = 0; } if (alloc_tracing) { fprintf(stderr,"ckalloc %lx %u %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); fprintf(stderr, "program will now enter C debugger\n"); (void) fflush(stderr); abort(); } current_malloc_packets++; if (current_malloc_packets > maximum_malloc_packets) { maximum_malloc_packets = current_malloc_packets; } current_bytes_malloced += size; if (current_bytes_malloced > maximum_bytes_malloced) { maximum_bytes_malloced = current_bytes_malloced; } Tcl_MutexUnlock(ckallocMutexPtr); return result->body; } char * Tcl_AttemptDbCkalloc(size, file, line) unsigned int size; CONST char *file; int line; { struct mem_header *result; if (validate_memory) { 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); return NULL; } /* * 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. */ if (init_malloced_bodies) { memset((VOID *) result, GUARD_VALUE, size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } else { memset((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); } if (!ckallocInit) { TclInitDbCkalloc(); } Tcl_MutexLock(ckallocMutexPtr); result->length = size; result->tagPtr = curTagPtr; if (curTagPtr != NULL) { curTagPtr->refCount++; } result->file = file; result->line = line; result->flink = allocHead; result->blink = NULL; if (allocHead != NULL) { allocHead->blink = result; } allocHead = result; total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); fprintf(stderr, "reached malloc trace enable point (%d)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; trace_on_at_malloc = 0; } if (alloc_tracing) { fprintf(stderr,"ckalloc %lx %u %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); fprintf(stderr, "program will now enter C debugger\n"); (void) fflush(stderr); abort(); } current_malloc_packets++; if (current_malloc_packets > maximum_malloc_packets) { maximum_malloc_packets = current_malloc_packets; } current_bytes_malloced += size; if (current_bytes_malloced > maximum_bytes_malloced) { maximum_bytes_malloced = current_bytes_malloced; } Tcl_MutexUnlock(ckallocMutexPtr); return result->body; } /* *---------------------------------------------------------------------- * * Tcl_DbCkfree - debugging ckfree * * Verify that the low and high guards are intact, and if so then free * the buffer else Tcl_Panic. * * The guards are erased after being checked to catch duplicate frees. * * The second and third arguments are file and line, these contain the * filename and line number corresponding to the caller. These are sent * by the ckfree macro; it uses the preprocessor autodefines __FILE__ and * __LINE__. * *---------------------------------------------------------------------- */ int Tcl_DbCkfree(ptr, file, line) char *ptr; CONST char *file; int line; { struct mem_header *memp; if (ptr == NULL) { return 0; } /* * The following cast is *very* tricky. Must convert the pointer to an * integer before doing arithmetic on it, because otherwise the arithmetic * will be done differently (and incorrectly) on word-addressed machines * such as Crays (will subtract only bytes, even though BODY_OFFSET is in * words on these machines). */ memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); if (alloc_tracing) { fprintf(stderr, "ckfree %lx %ld %s %d\n", (long unsigned int) memp->body, memp->length, file, line); } if (validate_memory) { Tcl_ValidateAllMemory(file, line); } Tcl_MutexLock(ckallocMutexPtr); ValidateMemory(memp, file, line, TRUE); if (init_malloced_bodies) { memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length); } |
︙ | ︙ | |||
611 612 613 614 615 616 617 618 | TclpFree((char *) memp->tagPtr); } } /* * Delink from allocated list */ if (memp->flink != NULL) { | > | | | | | | | | < | 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 | TclpFree((char *) memp->tagPtr); } } /* * Delink from allocated list */ if (memp->flink != NULL) { memp->flink->blink = memp->blink; } if (memp->blink != NULL) { memp->blink->flink = memp->flink; } if (allocHead == memp) { allocHead = memp->flink; } TclpFree((char *) memp); Tcl_MutexUnlock(ckallocMutexPtr); return 0; } /* *-------------------------------------------------------------------- * * Tcl_DbCkrealloc - debugging ckrealloc * * Reallocate a chunk of memory by allocating a new one of the right * size, copying the old data to the new location, and then freeing the * old memory space, using all the memory checking features of this * package. * *-------------------------------------------------------------------- */ char * Tcl_DbCkrealloc(ptr, size, file, line) char *ptr; unsigned int size; CONST char *file; int line; { char *new; unsigned int copySize; struct mem_header *memp; if (ptr == NULL) { return Tcl_DbCkalloc(size, file, line); } /* * See comment from Tcl_DbCkfree before you change the following line. */ memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); copySize = size; if (copySize > (unsigned int) memp->length) { copySize = memp->length; |
︙ | ︙ | |||
687 688 689 690 691 692 693 | struct mem_header *memp; if (ptr == NULL) { return Tcl_AttemptDbCkalloc(size, file, line); } /* | | < | 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 | struct mem_header *memp; if (ptr == NULL) { return Tcl_AttemptDbCkalloc(size, file, line); } /* * See comment from Tcl_DbCkfree before you change the following line. */ memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); copySize = size; if (copySize > (unsigned int) memp->length) { copySize = memp->length; |
︙ | ︙ | |||
712 713 714 715 716 717 718 | /* *---------------------------------------------------------------------- * * Tcl_Alloc, et al. -- * | | | | 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 | /* *---------------------------------------------------------------------- * * Tcl_Alloc, et al. -- * * These functions are defined in terms of the debugging versions when * TCL_MEM_DEBUG is set. * * Results: * Same as the debug versions. * * Side effects: * Same as the debug versions. * |
︙ | ︙ | |||
770 771 772 773 774 775 776 | return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0); } /* *---------------------------------------------------------------------- * * MemoryCmd -- | > | | | | 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 | return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0); } /* *---------------------------------------------------------------------- * * MemoryCmd -- * * Implements the Tcl "memory" command, which provides Tcl-level control * of Tcl memory debugging information. * memory active $file * memory break_on_malloc $count * memory info * memory init on|off * memory onexit $file * memory tag $string * memory trace on|off * memory trace_on_at_malloc $count * memory validate on|off * * Results: * Standard TCL results. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int MemoryCmd(clientData, interp, argc, argv) ClientData clientData; |
︙ | ︙ | |||
806 807 808 809 810 811 812 | if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option [args..]\"", (char *) NULL); return TCL_ERROR; } if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) { | | | | | | | | | | | | | | | | | | | | | | 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 | if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option [args..]\"", (char *) NULL); return TCL_ERROR; } if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " file\"", (char *) NULL); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); if (fileName == NULL) { return TCL_ERROR; } result = Tcl_DumpActiveMemory (fileName); Tcl_DStringFree(&buffer); if (result != TCL_OK) { Tcl_AppendResult(interp, "error accessing ", argv[2], (char *) NULL); return TCL_ERROR; } return TCL_OK; } if (strcmp(argv[1],"break_on_malloc") == 0) { if (argc != 3) { goto argError; } if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } if (strcmp(argv[1],"info") == 0) { Tcl_Obj *objPtr = Tcl_NewObj(); TclObjPrintf(NULL, objPtr, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, "current bytes allocated", current_bytes_malloced, "maximum packets allocated", maximum_malloc_packets, "maximum bytes allocated", maximum_bytes_malloced); Tcl_SetObjResult(interp, objPtr); return TCL_OK; } if (strcmp(argv[1],"init") == 0) { if (argc != 3) { goto bad_suboption; } init_malloced_bodies = (strcmp(argv[2],"on") == 0); return TCL_OK; } if (strcmp(argv[1],"onexit") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " onexit file\"", (char *) NULL); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); if (fileName == NULL) { return TCL_ERROR; |
︙ | ︙ | |||
881 882 883 884 885 886 887 | } curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2]))); curTagPtr->refCount = 0; strcpy(curTagPtr->string, argv[2]); return TCL_OK; } if (strcmp(argv[1],"trace") == 0) { | | | | | | | | | | | | | | | | < | 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 | } curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2]))); curTagPtr->refCount = 0; strcpy(curTagPtr->string, argv[2]); return TCL_OK; } if (strcmp(argv[1],"trace") == 0) { if (argc != 3) { goto bad_suboption; } alloc_tracing = (strcmp(argv[2],"on") == 0); return TCL_OK; } if (strcmp(argv[1],"trace_on_at_malloc") == 0) { if (argc != 3) { goto argError; } if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } if (strcmp(argv[1],"validate") == 0) { if (argc != 3) { goto bad_suboption; } validate_memory = (strcmp(argv[2],"on") == 0); return TCL_OK; } Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be active, break_on_malloc, info, init, onexit, ", "tag, trace, trace_on_at_malloc, or validate", (char *) NULL); return TCL_ERROR; argError: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " count\"", (char *) NULL); return TCL_ERROR; bad_suboption: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " on|off\"", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * CheckmemCmd -- * * This is the command procedure for the "checkmem" command, which causes * the application to exit after printing information about memory usage * to the file passed to this command as its first argument. * * Results: * Returns a standard Tcl completion code. * * Side effects: * None. * |
︙ | ︙ | |||
962 963 964 965 966 967 968 | } /* *---------------------------------------------------------------------- * * Tcl_InitMemory -- * | | < | > | | > | | | | | | > | | > | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_InitMemory -- * * Create the "memory" and "checkmem" commands in the given interpreter. * * Results: * None. * * Side effects: * New commands are added to the interpreter. * *---------------------------------------------------------------------- */ void Tcl_InitMemory(interp) Tcl_Interp *interp; /* Interpreter in which commands should be added */ { TclInitDbCkalloc(); Tcl_CreateCommand(interp, "memory", MemoryCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); } #else /* TCL_MEM_DEBUG */ /* This is the !TCL_MEM_DEBUG case */ #undef Tcl_InitMemory #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory /* *---------------------------------------------------------------------- * * Tcl_Alloc -- * * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check * that memory was actually allocated. * *---------------------------------------------------------------------- */ char * Tcl_Alloc(size) unsigned int size; { char *result; result = TclpAlloc(size); /* * Most systems will not alloc(0), instead bumping it to one so that NULL * isn't returned. Some systems (AIX, Tru64) will alloc(0) 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) { Tcl_Panic("unable to alloc %u 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); Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); } return result; } /* *---------------------------------------------------------------------- * * Tcl_AttemptAlloc -- * * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not * check that memory was actually allocated. * *---------------------------------------------------------------------- */ char * Tcl_AttemptAlloc(size) unsigned int size; |
︙ | ︙ | |||
1075 1076 1077 1078 1079 1080 1081 | int line; { char *result; result = (char *) TclpAlloc(size); return result; } | < > | | | 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 | int line; { char *result; result = (char *) TclpAlloc(size); return result; } /* *---------------------------------------------------------------------- * * Tcl_Realloc -- * * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does check * that memory was actually allocated. * *---------------------------------------------------------------------- */ char * Tcl_Realloc(ptr, size) char *ptr; |
︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 | int line; { char *result; result = (char *) TclpRealloc(ptr, size); if ((result == NULL) && size) { | | | > | | | 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 | int line; { char *result; result = (char *) TclpRealloc(ptr, size); if ((result == NULL) && size) { fflush(stdout); Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line); } return result; } /* *---------------------------------------------------------------------- * * Tcl_AttemptRealloc -- * * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does not * check that memory was actually allocated. * *---------------------------------------------------------------------- */ char * Tcl_AttemptRealloc(ptr, size) char *ptr; |
︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 | return result; } /* *---------------------------------------------------------------------- * * Tcl_Free -- | > | | | | 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 | return result; } /* *---------------------------------------------------------------------- * * Tcl_Free -- * * Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here rather * in the macro to keep some modules from being compiled with * TCL_MEM_DEBUG enabled and some with it disabled. * *---------------------------------------------------------------------- */ void Tcl_Free(ptr) char *ptr; |
︙ | ︙ | |||
1186 1187 1188 1189 1190 1191 1192 | return 0; } /* *---------------------------------------------------------------------- * * Tcl_InitMemory -- | > | | | 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 | return 0; } /* *---------------------------------------------------------------------- * * Tcl_InitMemory -- * * Dummy initialization for memory command, which is only available if * TCL_MEM_DEBUG is on. * *---------------------------------------------------------------------- */ /* ARGSUSED */ void Tcl_InitMemory(interp) Tcl_Interp *interp; |
︙ | ︙ | |||
1213 1214 1215 1216 1217 1218 1219 | Tcl_ValidateAllMemory(file, line) CONST char *file; int line; { } void | | | | | | | < > > > | > > > > > > > > | 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 | Tcl_ValidateAllMemory(file, line) CONST char *file; int line; { } void TclDumpMemoryInfo(outFile) FILE *outFile; { } #endif /* TCL_MEM_DEBUG */ /* *--------------------------------------------------------------------------- * * TclFinalizeMemorySubsystem -- * * This procedure is called to finalize all the structures that are used * by the memory allocator on a per-process basis. * * Results: * None. * * Side effects: * This subsystem is self-initializing, since memory can be allocated * before Tcl is formally initialized. After this call, this subsystem * has been reset to its initial state and is usable again. * *--------------------------------------------------------------------------- */ 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 } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclClock.c.
︙ | ︙ | |||
8 9 10 11 12 13 14 | * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans. * Copyright (c) 1995 Sun Microsystems, Inc. * Copyright (c) 2004 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 1991-1995 Karl Lehenbauer and Mark Diekhans. * Copyright (c) 1995 Sun Microsystems, Inc. * Copyright (c) 2004 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: tclClock.c,v 1.37.2.2 2005/08/15 18:13:58 dgp Exp $ */ #include "tclInt.h" /* * Windows has mktime. The configurators do not check. */ |
︙ | ︙ | |||
162 163 164 165 166 167 168 169 170 171 172 173 174 175 | Tcl_NewStringObj("number too large to represent as a Posix time", -1) ); Tcl_SetErrorCode( interp, "CLOCK", "argTooLarge", (char*) NULL ); return TCL_ERROR; } TzsetIfNecessary(); timeVal = ThreadSafeLocalTime( &tock ); /* Package the results */ returnVec[0] = Tcl_NewIntObj( timeVal->tm_year + 1900 ); returnVec[1] = Tcl_NewIntObj( timeVal->tm_mon + 1); returnVec[2] = Tcl_NewIntObj( timeVal->tm_mday ); returnVec[3] = Tcl_NewIntObj( timeVal->tm_hour ); | > > > > > > > > | 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 | Tcl_NewStringObj("number too large to represent as a Posix time", -1) ); Tcl_SetErrorCode( interp, "CLOCK", "argTooLarge", (char*) NULL ); return TCL_ERROR; } TzsetIfNecessary(); timeVal = ThreadSafeLocalTime( &tock ); if ( timeVal == NULL ) { Tcl_SetObjResult(interp, Tcl_NewStringObj("localtime failed (clock " "value may be too large/" "small to represent)", -1)); Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", (char*) NULL); return TCL_ERROR; } /* Package the results */ returnVec[0] = Tcl_NewIntObj( timeVal->tm_year + 1900 ); returnVec[1] = Tcl_NewIntObj( timeVal->tm_mon + 1); returnVec[2] = Tcl_NewIntObj( timeVal->tm_mday ); returnVec[3] = Tcl_NewIntObj( timeVal->tm_hour ); |
︙ | ︙ | |||
195 196 197 198 199 200 201 | * Invokes localtime or localtime_r as appropriate. * *---------------------------------------------------------------------- */ static struct tm * ThreadSafeLocalTime(timePtr) | | | < < > > > > > > > | | > | | 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 | * 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, (int) sizeof(struct tm)); #ifdef HAVE_LOCALTIME_R localtime_r(timePtr, tmPtr); #else struct tm *sysTmPtr; Tcl_MutexLock(&clockMutex); sysTmPtr = localtime(timePtr); if (sysTmPtr == NULL) { Tcl_MutexUnlock(&clockMutex); return NULL; } else { memcpy((VOID *) tmPtr, (VOID *) localtime(timePtr), sizeof(struct tm)); Tcl_MutexUnlock(&clockMutex); } #endif return tmPtr; } /* *---------------------------------------------------------------------- * * TclClockMktimeObjCmd -- |
︙ | ︙ | |||
301 302 303 304 305 306 307 | } toConvert.tm_min = i; if ( Tcl_GetIntFromObj( interp, objv[6], &i ) != TCL_OK ) { return TCL_ERROR; } toConvert.tm_sec = i; toConvert.tm_isdst = -1; | | | | > > | 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 | } toConvert.tm_min = i; if ( Tcl_GetIntFromObj( interp, objv[6], &i ) != TCL_OK ) { return TCL_ERROR; } toConvert.tm_sec = i; toConvert.tm_isdst = -1; toConvert.tm_wday = -1; toConvert.tm_yday = -1; /* Convert the time. It is rumored that mktime is not thread * safe on some platforms. */ TzsetIfNecessary(); Tcl_MutexLock( &clockMutex ); errno = 0; convertedTime = mktime( &toConvert ); localErrno = errno; Tcl_MutexUnlock( &clockMutex ); /* Return the converted time, or an error if conversion fails */ if ( localErrno != 0 || ( convertedTime == -1 && toConvert.tm_yday == -1 ) ) { Tcl_SetObjResult ( interp, Tcl_NewStringObj( "time value too large/small to represent", -1 ) ); return TCL_ERROR; } else { Tcl_SetObjResult( interp, |
︙ | ︙ |
Changes to generic/tclCmdAH.c.
|
| | | | < | | | > > | | | < | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 | /* * 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.57.2.10 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" #include <locale.h> #define NEW_FORMAT 1 /* * Prototypes for local procedures defined in this file: */ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode); static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr); static char * GetTypeFromMode(int mode); static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); /* *---------------------------------------------------------------------- * * Tcl_BreakObjCmd -- * * This procedure is invoked to process the "break" Tcl command. See the * user documentation for details on what it does. * * With the bytecode compiler, this procedure is only called when a * command name is computed at runtime, and is "break" or the name to * which "break" was renamed: e.g., "set z break; $z" * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_BreakObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } return TCL_BREAK; } /* *---------------------------------------------------------------------- * * Tcl_CaseObjCmd -- * * This procedure is invoked to process the "case" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
112 113 114 115 116 117 118 | } else { i = 2; } caseObjc = objc - i; caseObjv = objv + i; /* | | | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | } else { i = 2; } caseObjc = objc - i; caseObjv = objv + i; /* * If all of the pattern/command pairs are lumped into a single argument, * split them out again. */ if (caseObjc == 1) { Tcl_Obj **newObjv; Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv); caseObjv = newObjv; |
︙ | ︙ | |||
136 137 138 139 140 141 142 | if (i == (caseObjc - 1)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "extra case pattern with no body", NULL); return TCL_ERROR; } /* | | | | | | < < < | | < | | 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 | if (i == (caseObjc - 1)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "extra case pattern with no body", NULL); return TCL_ERROR; } /* * Check for special case of single pattern (no list) with no * backslash sequences. */ pat = TclGetString(caseObjv[i]); for (p = (unsigned char *) pat; *p != '\0'; p++) { if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */ break; } } if (*p == '\0') { if ((*pat == 'd') && (strcmp(pat, "default") == 0)) { body = i + 1; } if (Tcl_StringMatch(stringPtr, pat)) { body = i + 1; goto match; } continue; } /* * Break up pattern lists, then check each of the patterns in the * list. */ result = Tcl_SplitList(interp, pat, &patObjc, &patObjv); if (result != TCL_OK) { return result; } for (j = 0; j < patObjc; j++) { if (Tcl_StringMatch(stringPtr, patObjv[j])) { body = i + 1; break; } } ckfree((char *) patObjv); if (j < patObjc) { break; } } match: if (body != -1) { armPtr = caseObjv[body - 1]; result = Tcl_EvalObjEx(interp, caseObjv[body], 0); if (result == TCL_ERROR) { TclFormatToErrorInfo(interp, "\n (\"%.50s\" arm line %d)", TclGetString(armPtr), interp->errorLine); } return result; } /* * Nothing matched: return nothing. */ return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_CatchObjCmd -- * * This object-based procedure is invoked to process the "catch" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. |
︙ | ︙ | |||
247 248 249 250 251 252 253 | } result = Tcl_EvalObjEx(interp, objv[1], 0); /* * We disable catch in interpreters where the limit has been exceeded. */ | < < > | | | | | | | | 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 | } result = Tcl_EvalObjEx(interp, objv[1], 0); /* * We disable catch in interpreters where the limit has been exceeded. */ if (Tcl_LimitExceeded(interp)) { TclFormatToErrorInfo(interp, "\n (\"catch\" body line %d)", interp->errorLine); return TCL_ERROR; } if (objc >= 3) { if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL, Tcl_GetObjResult(interp), 0)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't save command result in variable", NULL); return TCL_ERROR; } } if (objc == 4) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, options, 0)) { Tcl_DecrRefCount(options); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't save return options in variable", NULL); return TCL_ERROR; } } Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_CdObjCmd -- * * This procedure is invoked to process the "cd" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
370 371 372 373 374 375 376 | } return TCL_OK; } /* *---------------------------------------------------------------------- * | | | | | | | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 | } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ContinueObjCmd -- * * This procedure is invoked to process the "continue" Tcl command. See * the user documentation for details on what it does. * * With the bytecode compiler, this procedure is only called when a * command name is computed at runtime, and is "continue" or the name to * which "continue" was renamed: e.g., "set z continue; $z" * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
426 427 428 429 430 431 432 | int Tcl_EncodingObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { | | < < < | | | < | > > > > > | | | | | > > | | | | | < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 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 | int Tcl_EncodingObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int index; static CONST char *optionStrings[] = { "convertfrom", "convertto", "names", "system", NULL }; enum options { ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { case ENC_CONVERTTO: case ENC_CONVERTFROM: { Tcl_Obj *data; Tcl_DString ds; Tcl_Encoding encoding; int length; char *stringPtr; if (objc == 3) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[2]; } else if (objc == 4) { if (TclGetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) { return TCL_ERROR; } data = objv[3]; } else { Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); return TCL_ERROR; } if ((enum options) index == ENC_CONVERTFROM) { /* * Treat the string as binary data. */ stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds); /* * Note that we cannot use Tcl_DStringResult here because it will * truncate the string at the first null byte. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); Tcl_DStringFree(&ds); } else { /* * Store the result as binary data. */ stringPtr = Tcl_GetStringFromObj(data, &length); Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( (unsigned char *) Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); Tcl_DStringFree(&ds); } Tcl_FreeEncoding(encoding); break; } case ENC_NAMES: if (objc > 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } Tcl_GetEncodingNames(interp); break; case ENC_SYSTEM: if (objc > 3) { Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); return TCL_ERROR; } if (objc == 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( Tcl_GetEncodingName(NULL), -1)); } else { return Tcl_SetSystemEncoding(interp, TclGetString(objv[2])); } break; } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclEncodingDirsObjCmd -- * * This command manipulates the encoding search path. * * Results: * A standard Tcl result. * * Side effects: * Can set the encoding search path. * *---------------------------------------------------------------------- */ int TclEncodingDirsObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?dirList?"); return TCL_ERROR; } if (objc == 1) { Tcl_SetObjResult(interp, TclGetEncodingSearchPath()); return TCL_OK; } if (TclSetEncodingSearchPath(objv[1]) == TCL_ERROR) { Tcl_AppendResult(interp, "expected directory list but got \"", Tcl_GetString(objv[1]), "\"", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ErrorObjCmd -- * * This procedure is invoked to process the "error" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
581 582 583 584 585 586 587 | } /* *---------------------------------------------------------------------- * * Tcl_EvalObjCmd -- * | | | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 | } /* *---------------------------------------------------------------------- * * Tcl_EvalObjCmd -- * * This object-based procedure is invoked to process the "eval" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. |
︙ | ︙ | |||
614 615 616 617 618 619 620 | } if (objc == 2) { result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT); } else { /* * More than one argument: concatenate them together with spaces | | | > < | | < | | | 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 | } if (objc == 2) { result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT); } else { /* * More than one argument: concatenate them together with spaces * between, then evaluate the result. Tcl_EvalObjEx will delete the * object when it decrements its refcount after eval'ing it. */ objPtr = Tcl_ConcatObj(objc-1, objv+1); result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { TclFormatToErrorInfo(interp,"\n (\"eval\" body line %d)", interp->errorLine); } return result; } /* *---------------------------------------------------------------------- * * Tcl_ExitObjCmd -- * * This procedure is invoked to process the "exit" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
680 681 682 683 684 685 686 | * * Tcl_ExprObjCmd -- * * This object-based procedure is invoked to process the "expr" Tcl * command. See the user documentation for details on what it does. * * With the bytecode compiler, this procedure is called in two | | | | | | | | < | | | | | | | | | | | | | | | < > | | > > | | | | | | | | | | | | > | | | | > > > > > > | | | | | | | > | | | < | | > | | | | > | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | > | | | | | | | | | > > > < | | > | > > > | | | | | > > > > > > | > > > | | | | | | | | | | | | | | | | | | | < | | > | > > | | | | | | | | > | > > | | | | | | | | | | | | | | | | | | > > | > > | | | | | < | > | | < | | | | | | < | > | | | > | | | | | | | | | | | | | | | < | | < | | | | | | | | | | | | | | > > | > > | | | | | | | | | | | | | | | > | | | | < > | > | | | | | | | | < | < < < < < < < < < < | < < < < | > | | | | > > > > | < < | > > | < < | | > > > | < < < < < < | | | < | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < | | | | | | | | | | | | | | | | < < < < < < < < < < < < | | | | | | | | | | | < | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < | | | | | | | | | | | | | | | | | | | 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 | * * Tcl_ExprObjCmd -- * * This object-based procedure is invoked to process the "expr" Tcl * command. See the user documentation for details on what it does. * * With the bytecode compiler, this procedure is called in two * circumstances: 1) to execute expr commands that are too complicated or * too unsafe to try compiling directly into an inline sequence of * instructions, and 2) to execute commands where the command name is * computed at runtime and is "expr" or the name to which "expr" was * renamed (e.g., "set z expr; $z 2+3") * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ExprObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Tcl_Obj *objPtr; Tcl_Obj *resultPtr; int result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); return TCL_ERROR; } objPtr = Tcl_ConcatObj(objc-1, objv+1); Tcl_IncrRefCount(objPtr); result = Tcl_ExprObj(interp, objPtr, &resultPtr); Tcl_DecrRefCount(objPtr); if (result == TCL_OK) { Tcl_SetObjResult(interp, resultPtr); Tcl_DecrRefCount(resultPtr); /* done with the result object */ } return result; } /* *---------------------------------------------------------------------- * * Tcl_FileObjCmd -- * * This procedure is invoked to process the "file" Tcl command. See the * user documentation for details on what it does. PLEASE NOTE THAT THIS * FAILS WITH FILENAMES AND PATHS WITH EMBEDDED NULLS. With the * object-based Tcl_FS APIs, the above NOTE may no longer be true. In any * case this assertion should be tested. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_FileObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int index; /* * 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 { FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY, FCMD_DELETE, FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION, FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK, FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME, FCMD_NORMALIZE, FCMD_OWNED, FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME, FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT, FCMD_STAT, FCMD_SYSTEM, FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { { Tcl_StatBuf buf; struct utimbuf tval; case FCMD_ATIME: case FCMD_MTIME: if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); return TCL_ERROR; } if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } if (objc == 4) { /* * Need separate variable for reading longs from an object on * 64-bit platforms. [Bug #698146] */ long newTime; if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) { return TCL_ERROR; } if (index == FCMD_ATIME) { tval.actime = newTime; tval.modtime = buf.st_mtime; } else { /* index == FCMD_MTIME */ tval.actime = buf.st_atime; tval.modtime = newTime; } if (Tcl_FSUtime(objv[2], &tval) != 0) { Tcl_AppendResult(interp, "could not set ", (index == FCMD_ATIME ? "access" : "modification"), " time for file \"", TclGetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } /* * Do another stat to ensure that the we return the new recognized * atime - hopefully the same as the one we sent in. However, fs's * like FAT don't even know what atime is. */ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_NewLongObj((long) (index == FCMD_ATIME ? buf.st_atime : buf.st_mtime))); return TCL_OK; } case FCMD_ATTRIBUTES: return TclFileAttrsCmd(interp, objc, objv); case FCMD_CHANNELS: if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } return Tcl_GetChannelNamesEx(interp, ((objc == 2) ? NULL : TclGetString(objv[2]))); case FCMD_COPY: return TclFileCopyCmd(interp, objc, objv); case FCMD_DELETE: return TclFileDeleteCmd(interp, objc, objv); case FCMD_DIRNAME: { Tcl_Obj *dirPtr; if (objc != 3) { goto only3Args; } dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME); if (dirPtr == NULL) { return TCL_ERROR; } else { Tcl_SetObjResult(interp, dirPtr); Tcl_DecrRefCount(dirPtr); return TCL_OK; } } case FCMD_EXECUTABLE: if (objc != 3) { goto only3Args; } return CheckAccess(interp, objv[2], X_OK); case FCMD_EXISTS: if (objc != 3) { goto only3Args; } return CheckAccess(interp, objv[2], F_OK); case FCMD_EXTENSION: { Tcl_Obj *ext; if (objc != 3) { goto only3Args; } ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION); if (ext != NULL) { Tcl_SetObjResult(interp, ext); Tcl_DecrRefCount(ext); return TCL_OK; } else { return TCL_ERROR; } } { int value; Tcl_StatBuf buf; case FCMD_ISDIRECTORY: if (objc != 3) { goto only3Args; } value = 0; if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { value = S_ISDIR(buf.st_mode); } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); return TCL_OK; case FCMD_ISFILE: if (objc != 3) { goto only3Args; } value = 0; if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { value = S_ISREG(buf.st_mode); } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); return TCL_OK; case FCMD_OWNED: if (objc != 3) { goto only3Args; } value = 0; if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { /* * For Windows, there are no user ids associated with a file, so * we always return 1. */ #if defined(__WIN32__) value = 1; #else value = (geteuid() == buf.st_uid); #endif } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); return TCL_OK; } case FCMD_JOIN: { Tcl_Obj *resObj; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); return TCL_ERROR; } resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); Tcl_SetObjResult(interp, resObj); return TCL_OK; } case FCMD_LINK: { Tcl_Obj *contents; int index; if (objc < 3 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?"); return TCL_ERROR; } /* * 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 three 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 \"", TclGetString(objv[index]), "\": that path already exists", (char *) NULL); } else if (errno == ENOENT) { /* * There are two cases here: either the target doesn't * exist, or the directory of the src doesn't exist. */ int access; Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], TCL_PATH_DIRNAME); if (dirPtr == NULL) { return TCL_ERROR; } access = Tcl_FSAccess(dirPtr, F_OK); Tcl_DecrRefCount(dirPtr); if (access != 0) { Tcl_AppendResult(interp, "could not create new link \"", TclGetString(objv[index]), "\": no such file or directory", (char *) NULL); } else { Tcl_AppendResult(interp, "could not create new link \"", TclGetString(objv[index]), "\": target \"", TclGetString(objv[index+1]), "\" doesn't exist", (char *) NULL); } } else { Tcl_AppendResult(interp, "could not create new link \"", TclGetString(objv[index]), "\" pointing to \"", TclGetString(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 \"", TclGetString(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; } { Tcl_StatBuf buf; case FCMD_LSTAT: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "name varName"); return TCL_ERROR; } if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { return TCL_ERROR; } return StoreStatData(interp, objv[3], &buf); case FCMD_STAT: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "name varName"); return TCL_ERROR; } if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } return StoreStatData(interp, objv[3], &buf); case FCMD_SIZE: if (objc != 3) { goto only3Args; } if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); return TCL_OK; case FCMD_TYPE: if (objc != 3) { goto only3Args; } if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewStringObj( GetTypeFromMode((unsigned short) buf.st_mode), -1)); return TCL_OK; } case FCMD_MKDIR: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); return TCL_ERROR; } return TclFileMakeDirsCmd(interp, objc, objv); case FCMD_NATIVENAME: { CONST char *fileName; Tcl_DString ds; if (objc != 3) { goto only3Args; } fileName = TclGetString(objv[2]); fileName = Tcl_TranslateFileName(interp, fileName, &ds); if (fileName == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, Tcl_DStringLength(&ds))); Tcl_DStringFree(&ds); return TCL_OK; } case FCMD_NORMALIZE: { Tcl_Obj *fileName; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "filename"); return TCL_ERROR; } fileName = Tcl_FSGetNormalizedPath(interp, objv[2]); if (fileName == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, fileName); return TCL_OK; } case FCMD_PATHTYPE: if (objc != 3) { goto only3Args; } switch (Tcl_FSGetPathType(objv[2])) { case TCL_PATH_ABSOLUTE: Tcl_SetObjResult(interp, Tcl_NewStringObj("absolute", -1)); break; case TCL_PATH_RELATIVE: Tcl_SetObjResult(interp, Tcl_NewStringObj("relative", -1)); break; case TCL_PATH_VOLUME_RELATIVE: Tcl_SetObjResult(interp, Tcl_NewStringObj("volumerelative", -1)); break; } return TCL_OK; case FCMD_READABLE: if (objc != 3) { goto only3Args; } return CheckAccess(interp, objv[2], R_OK); case FCMD_READLINK: { Tcl_Obj *contents; if (objc != 3) { goto only3Args; } if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { return TCL_ERROR; } contents = Tcl_FSLink(objv[2], NULL, 0); if (contents == NULL) { Tcl_AppendResult(interp, "could not readlink \"", TclGetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, contents); Tcl_DecrRefCount(contents); return TCL_OK; } case FCMD_RENAME: return TclFileRenameCmd(interp, objc, objv); case FCMD_ROOTNAME: { Tcl_Obj *root; if (objc != 3) { goto only3Args; } root = TclPathPart(interp, objv[2], TCL_PATH_ROOT); if (root != NULL) { Tcl_SetObjResult(interp, root); Tcl_DecrRefCount(root); return TCL_OK; } else { return TCL_ERROR; } } case FCMD_SEPARATOR: if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 2, objv, "?name?"); return TCL_ERROR; } if (objc == 2) { char *separator = NULL; /* lint */ switch (tclPlatform) { case TCL_PLATFORM_UNIX: separator = "/"; break; case TCL_PLATFORM_WINDOWS: separator = "\\"; break; } Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1)); } else { Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]); if (separatorObj != NULL) { Tcl_SetObjResult(interp, separatorObj); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj("Unrecognised path",-1)); return TCL_ERROR; } } return TCL_OK; case FCMD_SPLIT: { Tcl_Obj *res; if (objc != 3) { goto only3Args; } res = Tcl_FSSplitPath(objv[2], NULL); if (res == NULL) { if (interp != NULL) { Tcl_AppendResult(interp, "could not read \"", TclGetString(objv[2]), "\": no such file or directory", (char *) NULL); } return TCL_ERROR; } else { Tcl_SetObjResult(interp, res); return TCL_OK; } } case FCMD_SYSTEM: { Tcl_Obj* fsInfo; if (objc != 3) { goto only3Args; } fsInfo = Tcl_FSFileSystemInfo(objv[2]); if (fsInfo != NULL) { Tcl_SetObjResult(interp, fsInfo); return TCL_OK; } else { Tcl_SetObjResult(interp, Tcl_NewStringObj("Unrecognised path",-1)); return TCL_ERROR; } } case FCMD_TAIL: { Tcl_Obj *dirPtr; if (objc != 3) { goto only3Args; } dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL); if (dirPtr == NULL) { return TCL_ERROR; } else { Tcl_SetObjResult(interp, dirPtr); Tcl_DecrRefCount(dirPtr); return TCL_OK; } } case FCMD_VOLUMES: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_FSListVolumes()); return TCL_OK; case FCMD_WRITABLE: if (objc != 3) { goto only3Args; } return CheckAccess(interp, objv[2], W_OK); } only3Args: Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * CheckAccess -- * * Utility procedure used by Tcl_FileObjCmd() to query file attributes * available through the access() system call. * * Results: * Always returns TCL_OK. Sets interp's result to boolean true or false * depending on whether the file has the specified attribute. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int CheckAccess(interp, pathPtr, mode) Tcl_Interp *interp; /* Interp for status return. Must not be * NULL. */ Tcl_Obj *pathPtr; /* Name of file to check. */ int mode; /* Attribute to check; passed as argument to * access(). */ { int value; |
︙ | ︙ | |||
1402 1403 1404 1405 1406 1407 1408 | } /* *--------------------------------------------------------------------------- * * GetStatBuf -- * | | | | | | | | | 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 | } /* *--------------------------------------------------------------------------- * * GetStatBuf -- * * Utility procedure used by Tcl_FileObjCmd() to query file attributes * available through the stat() or lstat() system call. * * Results: * The return value is TCL_OK if the specified file exists and can be * stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an error * message is left in interp's result. If TCL_OK is returned, *statPtr is * filled with information about the specified file. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int GetStatBuf(interp, pathPtr, statProc, statPtr) Tcl_Interp *interp; /* Interp for error return. May be NULL. */ Tcl_Obj *pathPtr; /* Path name to examine. */ Tcl_FSStatProc *statProc; /* Either stat() or lstat() depending on * desired behavior. */ Tcl_StatBuf *statPtr; /* Filled with info about file obtained by * calling (*statProc)(). */ { int status; |
︙ | ︙ | |||
1450 1451 1452 1453 1454 1455 1456 | } /* *---------------------------------------------------------------------- * * StoreStatData -- * | | | | | | | | | | | | | > | | | | < > > | | | | | | | | | | | > | < | 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 | } /* *---------------------------------------------------------------------- * * StoreStatData -- * * This is a utility procedure that breaks out the fields of a "stat" * structure and stores them in textual form into the elements of an * associative array. * * Results: * Returns a standard Tcl return value. If an error occurs then a message * is left in interp's result. * * Side effects: * Elements of the associative array given by "varName" are modified. * *---------------------------------------------------------------------- */ static int StoreStatData(interp, varName, statPtr) Tcl_Interp *interp; /* Interpreter for error reports. */ Tcl_Obj *varName; /* Name of associative array variable in which * to store stat results. */ Tcl_StatBuf *statPtr; /* Pointer to buffer containing stat data to * store in varName. */ { Tcl_Obj *field = Tcl_NewObj(); Tcl_Obj *value; register unsigned short mode; /* * Assume Tcl_ObjSetVar2() does not keep a copy of the field name! * * Might be a better idea to call Tcl_SetVar2Ex() instead so we don't have * to make assumptions that might go wrong later. */ #define STORE_ARY(fieldName, object) \ Tcl_SetStringObj(field, (fieldName), -1); \ value = (object); \ if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG)==NULL) { \ Tcl_DecrRefCount(field); \ Tcl_DecrRefCount(value); \ return TCL_ERROR; \ } Tcl_IncrRefCount(field); /* * Watch out porters; the inode is meant to be an *unsigned* value, so the * cast might fail when there isn't a real arithmentic 'long long' type... */ STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev)); STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink)); STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid)); STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid)); STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); #ifdef HAVE_ST_BLOCKS STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); #endif STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime)); STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime)); STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime)); mode = (unsigned short) statPtr->st_mode; STORE_ARY("mode", Tcl_NewIntObj(mode)); STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); #undef STORE_ARY Tcl_DecrRefCount(field); return TCL_OK; } /* *---------------------------------------------------------------------- * * GetTypeFromMode -- * * Given a mode word, returns a string identifying the type of a file. * * Results: * A static text string giving the file type from mode. * * Side effects: * None. * |
︙ | ︙ | |||
1565 1566 1567 1568 1569 1570 1571 | } /* *---------------------------------------------------------------------- * * Tcl_ForObjCmd -- * | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | < | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_ForObjCmd -- * * This procedure is invoked to process the "for" Tcl command. See the * user documentation for details on what it does. * * With the bytecode compiler, this procedure is only called when a * command name is computed at runtime, and is "for" or the name to which * "for" was renamed: e.g., * "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}" * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ForObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); return TCL_ERROR; } result = Tcl_EvalObjEx(interp, objv[1], 0); if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); } return result; } while (1) { /* * We need to reset the result before passing it off to * Tcl_ExprBooleanObj. Otherwise, any error message will be appended * to the result of the last evaluation. */ Tcl_ResetResult(interp); result = Tcl_ExprBooleanObj(interp, objv[2], &value); if (result != TCL_OK) { return result; } if (!value) { break; } result = Tcl_EvalObjEx(interp, objv[4], 0); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { TclFormatToErrorInfo(interp, "\n (\"for\" body line %d)", interp->errorLine); } break; } result = Tcl_EvalObjEx(interp, objv[3], 0); if (result == TCL_BREAK) { break; } else if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); } return result; } } if (result == TCL_BREAK) { result = TCL_OK; } if (result == TCL_OK) { Tcl_ResetResult(interp); } return result; } /* *---------------------------------------------------------------------- * * Tcl_ForeachObjCmd -- * * This object-based procedure is invoked to process the "foreach" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
1681 1682 1683 1684 1685 1686 1687 | int i; /* i selects a value list */ int j, maxj; /* Number of loop iterations */ int v; /* v selects a loop variable */ int numLists; /* Count of value lists */ Tcl_Obj *bodyPtr; /* | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | 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 | int i; /* i selects a value list */ int j, maxj; /* Number of loop iterations */ int v; /* v selects a loop variable */ int numLists; /* Count of value lists */ Tcl_Obj *bodyPtr; /* * We copy the argument object pointers into a local array to avoid the * problem that "objv" might become invalid. It is a pointer into the * evaluation stack and that stack might be grown and reallocated if the * loop body requires a large amount of stack space. */ #define NUM_ARGS 9 Tcl_Obj *(argObjStorage[NUM_ARGS]); Tcl_Obj **argObjv = argObjStorage; #define STATIC_LIST_SIZE 4 int indexArray[STATIC_LIST_SIZE]; int varcListArray[STATIC_LIST_SIZE]; Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; int argcListArray[STATIC_LIST_SIZE]; Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; int *index = indexArray; /* Array of value list indices */ int *varcList = varcListArray; /* # loop variables per list */ Tcl_Obj ***varvList = varvListArray;/* Array of var name lists */ int *argcList = argcListArray; /* Array of value list sizes */ Tcl_Obj ***argvList = argvListArray;/* Array of value lists */ if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, "varList list ?varList list ...? command"); return TCL_ERROR; } /* * Create the object argument array "argObjv". Make sure argObjv is large * enough to hold the objc arguments. */ if (objc > NUM_ARGS) { argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *)); } for (i=0 ; i<objc ; i++) { argObjv[i] = objv[i]; } /* * Manage numList parallel value lists. * argvList[i] is a value list counted by argcList[i]l; * varvList[i] is the list of variables associated with the value list; * varcList[i] is the number of variables associated with the value list; * index[i] is the current pointer into the value list argvList[i]. */ numLists = (objc-2)/2; if (numLists > STATIC_LIST_SIZE) { index = (int *) ckalloc(numLists * sizeof(int)); varcList = (int *) ckalloc(numLists * sizeof(int)); varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **)); argcList = (int *) ckalloc(numLists * sizeof(int)); argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **)); } for (i = 0; i < numLists; i++) { index[i] = 0; varcList[i] = 0; varvList[i] = (Tcl_Obj **) NULL; argcList[i] = 0; argvList[i] = (Tcl_Obj **) NULL; } /* * Break up the value lists and variable lists into elements. */ maxj = 0; for (i=0 ; i<numLists ; i++) { result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], &varcList[i], &varvList[i]); if (result != TCL_OK) { goto done; } if (varcList[i] < 1) { Tcl_AppendResult(interp, "foreach varlist is empty", NULL); result = TCL_ERROR; goto done; } result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], &argcList[i], &argvList[i]); if (result != TCL_OK) { goto done; } j = argcList[i] / varcList[i]; if ((argcList[i] % varcList[i]) != 0) { j++; } if (j > maxj) { maxj = j; } } /* * Iterate maxj times through the lists in parallel. If some value lists * run out of values, set loop vars to "" */ bodyPtr = argObjv[objc-1]; for (j=0 ; j<maxj ; j++) { for (i=0 ; i<numLists ; i++) { /* * Refetch the list members; we assume that the sizes are the * same, but the array of elements might be different if the * internal rep of the objects has been lost and recreated (it is * too difficult to accurately tell when this happens, which can * lead to some wierd crashes, like Bug #494348...) */ result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], &varcList[i], &varvList[i]); if (result != TCL_OK) { Tcl_Panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i); } result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], &argcList[i], &argvList[i]); if (result != TCL_OK) { Tcl_Panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i); } for (v=0 ; v<varcList[i] ; v++) { int k = index[i]++; Tcl_Obj *valuePtr, *varValuePtr; int isEmptyObj = 0; if (k < argcList[i]) { valuePtr = argvList[i][k]; } else { |
︙ | ︙ | |||
1829 1830 1831 1832 1833 1834 1835 | } Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't set loop variable: \"", TclGetString(varvList[i][v]), "\"", (char *) NULL); result = TCL_ERROR; goto done; } | < < | | < < | | | > | | | | | | | | | > > | | | | > | | | | | | | | | | | > > > > > > > > > > > > > > | | < > | | | | | | | > | 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 | } Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't set loop variable: \"", TclGetString(varvList[i][v]), "\"", (char *) NULL); result = TCL_ERROR; goto done; } } } result = Tcl_EvalObjEx(interp, bodyPtr, 0); if (result != TCL_OK) { if (result == TCL_CONTINUE) { result = TCL_OK; } else if (result == TCL_BREAK) { result = TCL_OK; break; } else if (result == TCL_ERROR) { TclFormatToErrorInfo(interp, "\n (\"foreach\" body line %d)", interp->errorLine); break; } else { break; } } } if (result == TCL_OK) { Tcl_ResetResult(interp); } done: if (numLists > STATIC_LIST_SIZE) { ckfree((char *) index); ckfree((char *) varcList); ckfree((char *) argcList); ckfree((char *) varvList); ckfree((char *) argvList); } if (argObjv != argObjStorage) { ckfree((char *) argObjv); } return result; #undef STATIC_LIST_SIZE #undef NUM_ARGS } /* *---------------------------------------------------------------------- * * Tcl_FormatObjCmd -- * * This procedure is invoked to process the "format" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_FormatObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { #ifndef NEW_FORMAT char *format; /* Used to read characters from the format * string. */ int formatLen; /* The length of the format string */ char *endPtr; /* Points to the last char in format array */ char newFormat[43]; /* A new format specifier is generated here. */ int width; /* Field width from field specifier, or 0 if * no width given. */ int precision; /* Field precision from field specifier, or 0 * if no precision given. */ int size; /* Number of bytes needed for result of * conversion, based on type of conversion * ("e", "s", etc.), width, and precision. */ long intValue; /* Used to hold value to pass to sprintf, if * it's a one-word integer or char value */ char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if * it's a one-word value. */ double doubleValue; /* Used to hold value to pass to sprintf if * it's a double value. */ Tcl_WideInt wideValue; /* Used to hold value to pass to sprintf if * it's a 'long long' value. */ int whichValue; /* Indicates which of intValue, ptrValue, or * doubleValue has the value to pass to * sprintf, according to the following * definitions: */ #define INT_VALUE 0 #define CHAR_VALUE 1 #define PTR_VALUE 2 #define DOUBLE_VALUE 3 #define STRING_VALUE 4 #define WIDE_VALUE 5 #define MAX_FLOAT_SIZE 320 #endif Tcl_Obj *resultPtr; /* Where result is stored finally. */ #ifndef NEW_FORMAT char staticBuf[MAX_FLOAT_SIZE + 1]; /* A static buffer to copy the format results * into */ char *dst = staticBuf; /* The buffer that sprintf writes into each * time the format processes a specifier */ int dstSize = MAX_FLOAT_SIZE; /* The size of the dst buffer */ int noPercent; /* Special case for speed: indicates there's * no field specifier, just a string to * copy. */ int objIndex; /* Index of argument to substitute next. */ int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style * specifier has been seen. */ int gotSequential = 0; /* Non-zero means that a regular sequential * (non-XPG3) conversion specifier has been * seen. */ int useShort; /* Value to be printed is short (half word). */ char *end; /* Used to locate end of numerical fields. */ int stringLen = 0; /* Length of string in characters rather than * bytes. Used for %s substitution. */ int gotMinus; /* Non-zero indicates that a minus flag has * been seen in the current field. */ int gotPrecision; /* Non-zero indicates that a precision has * been set for the current field. */ int gotZero; /* Non-zero indicates that a zero flag has * been seen in the current field. */ int useWide; /* Value to be printed is Tcl_WideInt. */ /* * This procedure is a bit nasty. The goal is to use sprintf to do most of * the dirty work. There are several problems: * 1. this procedure can't trust its arguments. * 2. we must be able to provide a large enough result area to hold * whatever's generated. This is hard to estimate. * 3. there's no way to move the arguments from objv to the call to * sprintf in a reasonable way. This is particularly nasty because * some of the arguments may be two-word values (doubles and * wide-ints). * So, what happens here is to scan the format string one % group at a * time, making many individual calls to sprintf. */ #endif if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?"); return TCL_ERROR; } #ifdef NEW_FORMAT resultPtr = Tcl_NewObj(); Tcl_IncrRefCount(resultPtr); if (TclAppendFormattedObjs(interp, resultPtr, Tcl_GetString(objv[1]), objc-2, objv+2) != TCL_OK) { Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } Tcl_SetObjResult(interp, resultPtr); Tcl_DecrRefCount(resultPtr); return TCL_OK; #else format = Tcl_GetStringFromObj(objv[1], &formatLen); endPtr = format + formatLen; resultPtr = Tcl_NewObj(); objIndex = 2; while (format < endPtr) { register char *newPtr = newFormat; width = precision = noPercent = useShort = 0; gotZero = gotMinus = gotPrecision = 0; useWide = 0; whichValue = PTR_VALUE; /* * Get rid of any characters before the next field specifier. */ if (*format != '%') { ptrValue = format; while ((*format != '%') && (format < endPtr)) { format++; } size = format - ptrValue; noPercent = 1; goto doField; } if (format[1] == '%') { ptrValue = format; size = 1; noPercent = 1; format += 2; goto doField; } /* * Parse off a field specifier, compute how many characters will be * needed to store the result, and substitute for "*" size specifiers. */ *newPtr = '%'; newPtr++; format++; if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ int tmp; /* * Check for an XPG3-style %n$ specification. Note: there must not * be a mixture of XPG3 specs and non-XPG3 specs in the same * format string. */ tmp = strtoul(format, &end, 10); /* INTL: "C" locale. */ if (*end != '$') { goto notXpg; } format = end+1; gotXpg = 1; if (gotSequential) { goto mixedXPG; } objIndex = tmp+1; if ((objIndex < 2) || (objIndex >= objc)) { goto badIndex; } goto xpgCheckDone; } notXpg: gotSequential = 1; if (gotXpg) { goto mixedXPG; } xpgCheckDone: while ((*format == '-') || (*format == '#') || (*format == '0') || (*format == ' ') || (*format == '+')) { if (*format == '-') { gotMinus = 1; } if (*format == '0') { /* * This will be handled by sprintf for numbers, but we need to * do the char/string ones ourselves. */ gotZero = 1; } *newPtr = *format; newPtr++; format++; } if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ |
︙ | ︙ | |||
2088 2089 2090 2091 2092 2093 2094 | newPtr++; } objIndex++; format++; } if (width > 100000) { /* | | | < | > | | > | 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 | newPtr++; } objIndex++; format++; } if (width > 100000) { /* * Don't allow arbitrarily large widths: could cause core dump * when we try to allocate a zillion bytes of memory below. */ width = 100000; } else if (width < 0) { width = 0; } if (width != 0) { TclFormatInt(newPtr, width); /* INTL: printf format. */ while (*newPtr != 0) { newPtr++; } } if (*format == '.') { *newPtr = '.'; newPtr++; format++; gotPrecision = 1; } if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ precision = strtoul(format, &end, 10); /* INTL: "C" locale. */ format = end; } else if (*format == '*') { if (objIndex >= objc) { goto badIndex; } if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ objv[objIndex], &precision) != TCL_OK) { goto fmtError; } objIndex++; format++; } if (gotPrecision) { TclFormatInt(newPtr, precision); /* INTL: printf format. */ while (*newPtr != 0) { newPtr++; } } if (*format == 'l') { useWide = 1; /* * Only add a 'll' modifier for integer values as it makes some * libc's go into spasm otherwise. [Bug #702622] */ switch (format[1]) { case 'i': case 'd': case 'o': case 'u': case 'x': case 'X': |
︙ | ︙ | |||
2180 2181 2182 2183 2184 2185 2186 | break; } if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */ objv[objIndex], &intValue) != TCL_OK) { goto fmtError; } #if (LONG_MAX > INT_MAX) | > | | | | > > > > > | > | | | | > | | | | | 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 | break; } if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */ objv[objIndex], &intValue) != TCL_OK) { goto fmtError; } #if (LONG_MAX > INT_MAX) if (!useShort) { /* * Add the 'l' for long format type because we are on an LP64 * archtecture and we are really going to pass a long argument * to sprintf. * * Do not add this if we're going to pass in a short (i.e. if * we've got an 'h' modifier already in the string); some libc * implementations of sprintf() do not like it at all. [Bug * 1154163] */ newPtr++; *newPtr = 0; newPtr[-1] = newPtr[-2]; newPtr[-2] = 'l'; } #endif /* LONG_MAX > INT_MAX */ whichValue = INT_VALUE; size = 40 + precision; break; case 's': /* * Compute the length of the string in characters and add any * additional space required by the field width. All of the extra * characters will be spaces, so one byte per character is * adequate. */ whichValue = STRING_VALUE; ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size); stringLen = Tcl_NumUtfChars(ptrValue, size); if (gotPrecision && (precision < stringLen)) { stringLen = precision; |
︙ | ︙ | |||
2225 2226 2227 2228 2229 2230 2231 | size = width + TCL_UTF_MAX; break; case 'e': case 'E': case 'f': case 'g': case 'G': | | > | 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 | size = width + TCL_UTF_MAX; break; case 'e': case 'E': case 'f': case 'g': case 'G': if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */ objv[objIndex], &doubleValue) != TCL_OK) { /*TODO: figure out ACCEPT_NAN */ goto fmtError; } whichValue = DOUBLE_VALUE; size = MAX_FLOAT_SIZE; if (precision > 10) { size += precision; } |
︙ | ︙ | |||
2253 2254 2255 2256 2257 2258 2259 | goto fmtError; } } objIndex++; format++; /* | | | | | | 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 | goto fmtError; } } objIndex++; format++; /* * Make sure that there's enough space to hold the formatted result, * then format it. */ doField: if (width > size) { size = width; } if (noPercent) { Tcl_AppendToObj(resultPtr, ptrValue, size); } else { if (size > dstSize) { if (dst != staticBuf) { ckfree(dst); } dst = (char *) ckalloc((unsigned) (size + 1)); dstSize = size; } switch (whichValue) { case DOUBLE_VALUE: |
︙ | ︙ | |||
2320 2321 2322 2323 2324 2325 2326 | if (!gotMinus) { while (pad > 0) { *ptr++ = padChar; pad--; } } | | | 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 | if (!gotMinus) { while (pad > 0) { *ptr++ = padChar; pad--; } } size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; if (size) { memcpy(ptr, ptrValue, (size_t) size); ptr += size; } while (pad > 0) { *ptr++ = padChar; pad--; |
︙ | ︙ | |||
2346 2347 2348 2349 2350 2351 2352 | Tcl_SetObjResult(interp, resultPtr); if (dst != staticBuf) { ckfree(dst); } return TCL_OK; | | | | | | | > > > > > > > > > | 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 | Tcl_SetObjResult(interp, resultPtr); if (dst != staticBuf) { ckfree(dst); } return TCL_OK; mixedXPG: Tcl_SetResult(interp, "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC); goto fmtError; badIndex: if (gotXpg) { Tcl_SetResult(interp, "\"%n$\" argument index out of range", TCL_STATIC); } else { Tcl_SetResult(interp, "not enough arguments for all format specifiers", TCL_STATIC); } fmtError: if (dst != staticBuf) { ckfree(dst); } Tcl_DecrRefCount(resultPtr); return TCL_ERROR; #endif } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclCmdIL.c.
|
| | | | | | > | | | | | | | | | | > > > > > > > > | | | | < | | > > | | | | | | | | | | | | | | | | | > | | | < | | < < | | < | | | < | | < | | < | | < | | < | | < | | < | | < | < | | | < | | < | | < | | | | | < | < | | | < | | < | | < | < | | | < | | | | | | < | | | | | | > | | | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | /* * tclCmdIL.c -- * * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters I through L. It * contains only commands in the generic core (i.e. those that don't * depend much upon UNIX facilities). * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2005 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclCmdIL.c,v 1.70.2.9 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" #include "tclRegexp.h" /* * During execution of the "lsort" command, structures of the following type * are used to arrange the objects being sorted into a collection of linked * lists. */ typedef struct SortElement { Tcl_Obj *objPtr; /* Object being sorted. */ int count; /* number of same elements in list */ struct SortElement *nextPtr;/* Next element in the list, or NULL for end * of list. */ } SortElement; /* * These function pointer types are used with the "lsearch" and "lsort" * commands to facilitate the "-nocase" option. */ typedef int (*SortStrCmpFn_t) (const char *, const char *); typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t); /* * The "lsort" command needs to pass certain information down to the function * that compares two list elements, and the comparison function needs to pass * success or failure information back up to the top-level "lsort" command. * The following structure is used to pass this information. */ typedef struct SortInfo { int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* values * defined below */ SortStrCmpFn_t strCmpFn; /* Basic string compare command (used with * ASCII mode). */ Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode is * SORTMODE_COMMAND. Pre-initialized to hold * base of command.*/ int *indexv; /* If the -index option was specified, this * holds the indexes contained in the list * supplied as an argument to that option. * NULL if no indexes supplied, and points to * singleIndex field when only one * supplied. */ int indexc; /* Number of indexes in indexv array. */ int singleIndex; /* Static space for common index case. */ Tcl_Interp *interp; /* The interpreter in which the sort is being * done. */ int resultCode; /* Completion code for the lsort command. If * an error occurs during the sort this is * changed from TCL_OK to TCL_ERROR. */ } SortInfo; /* * The "sortMode" field of the SortInfo structure can take on any of the * following values. */ #define SORTMODE_ASCII 0 #define SORTMODE_INTEGER 1 #define SORTMODE_REAL 2 #define SORTMODE_COMMAND 3 #define SORTMODE_DICTIONARY 4 /* * Magic values for the index field of the SortInfo structure. Note that the * index "end-1" will be translated to SORTIDX_END-1, etc. */ #define SORTIDX_NONE -1 /* Not indexed; use whole value. */ #define SORTIDX_END -2 /* Indexed from end. */ /* * Forward declarations for procedures defined in this file: */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, CONST char *pattern, int includeLinks); static int DictionaryCompare(char *left, char *right); static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoCmdCountCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoCommandsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoExistsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoLevelCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoNameOfExecutableCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoPatchLevelCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoProcsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoVarsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static SortElement * MergeSort(SortElement *headPt, SortInfo *infoPtr); static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, SortInfo *infoPtr); static int SortCompare(Tcl_Obj *firstPtr, Tcl_Obj *second, SortInfo *infoPtr); static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, SortInfo *infoPtr); /* *---------------------------------------------------------------------- * * Tcl_IfObjCmd -- * * This procedure is invoked to process the "if" Tcl command. See the * user documentation for details on what it does. * * With the bytecode compiler, this procedure is only called when a * command name is computed at runtime, and is "if" or the name to which * "if" was renamed: e.g., "set z if; $z 1 {puts foo}" * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_IfObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int thenScriptIndex = 0; /* "then" script to be evaled after * syntax check */ int i, result, value; char *clause; i = 1; while (1) { /* * At this point in the loop, objv and objc refer to an expression to * test, either for the main expression or an expression following an * "elseif". The arguments after the expression must be "then" * (optional) and a script to execute if the expression is true. */ if (i >= objc) { clause = TclGetString(objv[i-1]); Tcl_AppendResult(interp, "wrong # args: no expression after \"", clause, "\" argument", (char *) NULL); return TCL_ERROR; |
︙ | ︙ | |||
235 236 237 238 239 240 241 | } if (value) { thenScriptIndex = i; value = 0; } /* | | | | | | | 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 | } if (value) { thenScriptIndex = i; value = 0; } /* * The expression evaluated to false. Skip the command, then see if * there is an "else" or "elseif" clause. */ i++; if (i >= objc) { if (thenScriptIndex) { return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); } return TCL_OK; } clause = TclGetString(objv[i]); if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) { i++; continue; } break; } /* * Couldn't find a "then" or "elseif" clause to execute. Check now for an * "else" clause. We know that there's at least one more argument when we * get here. */ if (strcmp(clause, "else") == 0) { i++; if (i >= objc) { Tcl_AppendResult(interp, "wrong # args: no script following \"else\" argument", |
︙ | ︙ | |||
286 287 288 289 290 291 292 | } /* *---------------------------------------------------------------------- * * Tcl_IncrObjCmd -- * | | | | | | > < > > > | | | > | 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 | } /* *---------------------------------------------------------------------- * * Tcl_IncrObjCmd -- * * This procedure is invoked to process the "incr" Tcl command. See the * user documentation for details on what it does. * * With the bytecode compiler, this procedure is only called when a * command name is computed at runtime, and is "incr" or the name to * which "incr" was renamed: e.g., "set z incr; $z i -1" * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_IncrObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { #if 0 long incrAmount = 1; Tcl_WideInt wideIncrAmount; int isWide = 0; #endif Tcl_Obj *newValuePtr, *incrPtr; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?"); return TCL_ERROR; } #if 0 /* * Calculate the amount to increment by. */ if (objc == 3) { /* * Need to be a bit cautious to ensure that [expr]-like rules are * enforced for interpretation of wide integers, despite the fact that * the underlying API itself is a 'long' only one. */ if (objv[2]->typePtr == &tclIntType) { incrAmount = objv[2]->internalRep.longValue; isWide = 0; } else if (objv[2]->typePtr == &tclWideIntType) { wideIncrAmount = objv[2]->internalRep.wideValue; isWide = 1; } else { |
︙ | ︙ | |||
365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 | if (isWide) { newValuePtr = TclIncrWideVar2(interp, objv[1], (Tcl_Obj *) NULL, wideIncrAmount, TCL_LEAVE_ERR_MSG); } else { newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount, TCL_LEAVE_ERR_MSG); } if (newValuePtr == NULL) { return TCL_ERROR; } /* * Set the interpreter's object result to refer to the variable's new * value object. */ Tcl_SetObjResult(interp, newValuePtr); | > > > > > > > > > > > > | | | | 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 | if (isWide) { newValuePtr = TclIncrWideVar2(interp, objv[1], (Tcl_Obj *) NULL, wideIncrAmount, TCL_LEAVE_ERR_MSG); } else { newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount, TCL_LEAVE_ERR_MSG); } #else if (objc == 3) { incrPtr = objv[2]; } else { incrPtr = Tcl_NewIntObj(1); } Tcl_IncrRefCount(incrPtr); newValuePtr = TclIncrObjVar2(interp, objv[1], NULL, incrPtr, TCL_LEAVE_ERR_MSG); Tcl_DecrRefCount(incrPtr); #endif if (newValuePtr == NULL) { return TCL_ERROR; } /* * Set the interpreter's object result to refer to the variable's new * value object. */ Tcl_SetObjResult(interp, newValuePtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_InfoObjCmd -- * * This procedure is invoked to process the "info" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
503 504 505 506 507 508 509 | } /* *---------------------------------------------------------------------- * * InfoArgsCmd -- * | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoArgsCmd -- * * Called to implement the "info args" command that returns the argument * list for a procedure. Handles the following syntax: * * info args procName * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoArgsCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
565 566 567 568 569 570 571 | } /* *---------------------------------------------------------------------- * * InfoBodyCmd -- * | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoBodyCmd -- * * Called to implement the "info body" command that returns the body for * a procedure. Handles the following syntax: * * info body procName * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoBodyCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
605 606 607 608 609 610 611 | procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", (char *) NULL); return TCL_ERROR; } | | | | | | | | | > | | | | | | | 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 | procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", (char *) NULL); return TCL_ERROR; } /* * Here we used to return procPtr->bodyPtr, except when the body was * bytecompiled - in that case, the return was a copy of the body's string * rep. In order to better isolate the implementation details of the * compiler/engine subsystem, we now always return a copy of the string * rep. It is important to return a copy so that later manipulations of * the object do not invalidate the internal rep. */ bodyPtr = procPtr->bodyPtr; if (bodyPtr->bytes == NULL) { /* * The string rep might not be valid if the procedure has never been * run before. [Bug #545644] */ (void) Tcl_GetString(bodyPtr); } resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * InfoCmdCountCmd -- * * Called to implement the "info cmdcount" command that returns the * number of commands that have been executed. Handles the following * syntax: * * info cmdcount * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoCmdCountCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
672 673 674 675 676 677 678 | } /* *---------------------------------------------------------------------- * * InfoCommandsCmd -- * | | | | | | | | | | | | > | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoCommandsCmd -- * * Called to implement the "info commands" command that returns the list * of commands in the interpreter that match an optional pattern. The * pattern, if any, consists of an optional sequence of namespace names * separated by "::" qualifiers, which is followed by a glob-style * pattern that restricts which commands are returned. Handles the * following syntax: * * info commands ?pattern? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoCommandsCmd(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 *cmdName, *pattern; CONST char *simplePattern; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Namespace *nsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ Tcl_Command cmd; int i; /* * Get the pattern and find the "effective namespace" in which to list * commands. */ if (objc == 2) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; } else if (objc == 3) { /* * From the pattern, get the effective namespace and the simple * pattern (no namespace qualifiers or ::'s) at the end. If an error * was found while parsing the pattern, return it. Otherwise, if the * namespace wasn't found, just leave nsPtr NULL: we will return an * empty list since no commands there can be found. */ Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = TclGetString(objv[2]); TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); |
︙ | ︙ | |||
750 751 752 753 754 755 756 | */ if (nsPtr == NULL) { return TCL_OK; } /* | | | | | | | < > > > > | > > > > > > > > > | > > > > > > | > | > > > > > > > > | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | 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 | */ if (nsPtr == NULL) { return TCL_OK; } /* * Scan through the effective namespace's command table and create a list * with all commands that match the pattern. If a specific namespace was * requested in the pattern, qualify the command names with the namespace * name. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { /* * Special case for when the pattern doesn't include any of glob's * special characters. This lets us avoid scans of any hash tables. */ entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if (entryPtr != NULL) { if (specificNsInPattern) { cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); elemObjPtr = Tcl_NewStringObj(cmdName, -1); } Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } if ((nsPtr != globalNsPtr) && !specificNsInPattern) { Tcl_HashTable *tablePtr = NULL; /* Quell warning */ for (i=0 ; i<nsPtr->commandPathLength ; i++) { Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr; if (pathNsPtr == NULL) { continue; } tablePtr = &pathNsPtr->cmdTable; entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern); if (entryPtr != NULL) { break; } } if (entryPtr == NULL) { tablePtr = &globalNsPtr->cmdTable; entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern); } if (entryPtr != NULL) { cmdName = Tcl_GetHashKey(tablePtr, entryPtr); Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(cmdName, -1)); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } } } else if (nsPtr->commandPathLength == 0 || specificNsInPattern) { /* * The pattern is non-trivial, but either there is no explicit path or * there is an explicit namespace in the pattern. In both cases, the * old matching scheme is perfect. */ entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { if (specificNsInPattern) { cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(cmdName, -1); } Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } entryPtr = Tcl_NextHashEntry(&search); } /* * If the effective namespace isn't the global :: namespace, and a * specific namespace wasn't requested in the pattern, then add in all * global :: commands that match the simple pattern. Of course, we add * in only those commands that aren't hidden by a command in the * effective namespace. */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(cmdName, -1)); } } entryPtr = Tcl_NextHashEntry(&search); } } } else { /* * The pattern is non-trivial (can match more than one command name), * there is an explicit path, and there is no explicit namespace in * the pattern. This means that we have to traverse the path to * discover all the commands defined. */ Tcl_HashTable addedCommandsTable; int isNew; int foundGlobal = (nsPtr == globalNsPtr); /* * We keep a hash of the objects already added to the result list. */ Tcl_InitObjHashTable(&addedCommandsTable); entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { elemObjPtr = Tcl_NewStringObj(cmdName, -1); Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); (void) Tcl_CreateHashEntry(&addedCommandsTable, (char *)elemObjPtr, &isNew); } entryPtr = Tcl_NextHashEntry(&search); } /* * Search the path next. */ for (i=0 ; i<nsPtr->commandPathLength ; i++) { Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr; if (pathNsPtr == NULL) { continue; } if (pathNsPtr == globalNsPtr) { foundGlobal = 1; } entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search); while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { elemObjPtr = Tcl_NewStringObj(cmdName, -1); (void) Tcl_CreateHashEntry(&addedCommandsTable, (char *) elemObjPtr, &isNew); if (isNew) { Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } else { TclDecrRefCount(elemObjPtr); } } entryPtr = Tcl_NextHashEntry(&search); } } /* * If the effective namespace isn't the global :: namespace, and a * specific namespace wasn't requested in the pattern, then add in all * global :: commands that match the simple pattern. Of course, we add * in only those commands that aren't hidden by a command in the * effective namespace. */ if (!foundGlobal) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { elemObjPtr = Tcl_NewStringObj(cmdName, -1); if (Tcl_FindHashEntry(&addedCommandsTable, (char *) elemObjPtr) == NULL) { Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } else { TclDecrRefCount(elemObjPtr); } } entryPtr = Tcl_NextHashEntry(&search); } } Tcl_DeleteHashTable(&addedCommandsTable); } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * InfoCompleteCmd -- * * Called to implement the "info complete" command that determines * whether a string is a complete Tcl command. Handles the following * syntax: * * info complete command * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoCompleteCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
877 878 879 880 881 882 883 | } /* *---------------------------------------------------------------------- * * InfoDefaultCmd -- * | | | < | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoDefaultCmd -- * * Called to implement the "info default" command that returns the * default value for a procedure argument. Handles the following syntax: * * info default procName arg varName * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoDefaultCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
961 962 963 964 965 966 967 | } /* *---------------------------------------------------------------------- * * InfoExistsCmd -- * | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoExistsCmd -- * * Called to implement the "info exists" command that determines whether * a variable exists. Handles the following syntax: * * info exists varName * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoExistsCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 | } /* *---------------------------------------------------------------------- * * InfoFunctionsCmd -- * | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoFunctionsCmd -- * * Called to implement the "info functions" command that returns the list * of math functions matching an optional pattern. Handles the following * syntax: * * info functions ?pattern? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoFunctionsCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
1054 1055 1056 1057 1058 1059 1060 | } /* *---------------------------------------------------------------------- * * InfoGlobalsCmd -- * | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoGlobalsCmd -- * * Called to implement the "info globals" command that returns the list * of global variables matching an optional pattern. Handles the * following syntax: * * info globals ?pattern? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoGlobalsCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 | if (objc == 2) { pattern = NULL; } else if (objc == 3) { pattern = TclGetString(objv[2]); /* * Strip leading global-namespace qualifiers. [Bug 1057461] */ if (pattern[0] == ':' && pattern[1] == ':') { while (*pattern == ':') { pattern++; } } } else { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } /* | > | | > > | | > | 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 | if (objc == 2) { pattern = NULL; } else if (objc == 3) { pattern = TclGetString(objv[2]); /* * Strip leading global-namespace qualifiers. [Bug 1057461] */ if (pattern[0] == ':' && pattern[1] == ':') { while (*pattern == ':') { pattern++; } } } else { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } /* * Scan through the global :: namespace's variable table and create a list * of all global variables that match the pattern. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if (pattern != NULL && TclMatchIsTrivial(pattern)) { entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern); if (entryPtr != NULL) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); if (!TclIsVarUndefined(varPtr)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(pattern, -1)); } } } else { for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); if (TclIsVarUndefined(varPtr)) { |
︙ | ︙ | |||
1137 1138 1139 1140 1141 1142 1143 | } /* *---------------------------------------------------------------------- * * InfoHostnameCmd -- * | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoHostnameCmd -- * * Called to implement the "info hostname" command that returns the host * name. Handles the following syntax: * * info hostname * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoHostnameCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
1181 1182 1183 1184 1185 1186 1187 | } /* *---------------------------------------------------------------------- * * InfoLevelCmd -- * | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoLevelCmd -- * * Called to implement the "info level" command that returns information * about the call stack. Handles the following syntax: * * info level ?number? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoLevelCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
1252 1253 1254 1255 1256 1257 1258 | } /* *---------------------------------------------------------------------- * * InfoLibraryCmd -- * | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoLibraryCmd -- * * Called to implement the "info library" command that returns the * library directory for the Tcl installation. Handles the following * syntax: * * info library * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoLibraryCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
1297 1298 1299 1300 1301 1302 1303 | } /* *---------------------------------------------------------------------- * * InfoLoadedCmd -- * | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoLoadedCmd -- * * Called to implement the "info loaded" command that returns the * packages that have been loaded into an interpreter. Handles the * following syntax: * * info loaded ?interp? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoLoadedCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
1342 1343 1344 1345 1346 1347 1348 | } /* *---------------------------------------------------------------------- * * InfoLocalsCmd -- * | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoLocalsCmd -- * * Called to implement the "info locals" command to return a list of * local variables that match an optional pattern. Handles the following * syntax: * * info locals ?pattern? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoLocalsCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
1378 1379 1380 1381 1382 1383 1384 | } else if (objc == 3) { pattern = TclGetString(objv[2]); } else { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } | | > | | | 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 | } else if (objc == 3) { pattern = TclGetString(objv[2]); } else { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } if (iPtr->varFramePtr == NULL || !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC )) { return TCL_OK; } /* * Return a list containing names of first the compiled locals (i.e. the * ones stored in the call frame), then the variables in the local hash * table (if one exists). */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); AppendLocals(interp, listPtr, pattern, 0); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * AppendLocals -- * * Append the local variables for the current frame to the specified list * object. * * Results: * None. * * Side effects: * None. * |
︙ | ︙ | |||
1449 1450 1451 1452 1453 1454 1455 | Tcl_NewStringObj(varName, -1)); } } varPtr++; localPtr = localPtr->nextPtr; } | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | < | | | < | | | | | | | 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 | Tcl_NewStringObj(varName, -1)); } } varPtr++; localPtr = localPtr->nextPtr; } /* * Do nothing if no local variables. */ if (localVarTablePtr == NULL) { return; } /* * Check for the simple and fast case. */ if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { entryPtr = Tcl_FindHashEntry(localVarTablePtr, pattern); if (entryPtr != NULL) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(pattern,-1)); } } return; } /* * Scan over and process all local variables. */ for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { varName = Tcl_GetHashKey(localVarTablePtr, entryPtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(varName, -1)); } } } } /* *---------------------------------------------------------------------- * * InfoNameOfExecutableCmd -- * * Called to implement the "info nameofexecutable" command that returns * the name of the binary file running this application. Handles the * following syntax: * * info nameofexecutable * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoNameOfExecutableCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
1508 1509 1510 1511 1512 1513 1514 | } /* *---------------------------------------------------------------------- * * InfoPatchLevelCmd -- * | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoPatchLevelCmd -- * * Called to implement the "info patchlevel" command that returns the * default value for an argument to a procedure. Handles the following * syntax: * * info patchlevel * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoPatchLevelCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
1552 1553 1554 1555 1556 1557 1558 | } /* *---------------------------------------------------------------------- * * InfoProcsCmd -- * | | | | | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoProcsCmd -- * * Called to implement the "info procs" command that returns the list of * procedures in the interpreter that match an optional pattern. The * pattern, if any, consists of an optional sequence of namespace names * separated by "::" qualifiers, which is followed by a glob-style * pattern that restricts which commands are returned. Handles the * following syntax: * * info procs ?pattern? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoProcsCmd(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 *cmdName, *pattern; CONST char *simplePattern; Namespace *nsPtr; #ifdef INFO_PROCS_SEARCH_GLOBAL_NS Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); #endif Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Command *cmdPtr, *realCmdPtr; /* * Get the pattern and find the "effective namespace" in which to list * procs. */ if (objc == 2) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; } else if (objc == 3) { /* * From the pattern, get the effective namespace and the simple * pattern (no namespace qualifiers or ::'s) at the end. If an error * was found while parsing the pattern, return it. Otherwise, if the * namespace wasn't found, just leave nsPtr NULL: we will return an * empty list since no commands there can be found. */ Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = TclGetString(objv[2]); TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, |
︙ | ︙ | |||
1629 1630 1631 1632 1633 1634 1635 | } if (nsPtr == NULL) { return TCL_OK; } /* | | | | | | | 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 | } if (nsPtr == NULL) { return TCL_OK; } /* * Scan through the effective namespace's command table and create a list * with all procs that match the pattern. If a specific namespace was * requested in the pattern, qualify the command names with the namespace * name. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); #ifndef INFO_PROCS_SEARCH_GLOBAL_NS if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if (entryPtr != NULL) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { goto simpleProcOK; } } else { simpleProcOK: if (specificNsInPattern) { elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(simplePattern, -1); } |
︙ | ︙ | |||
1677 1678 1679 1680 1681 1682 1683 | if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { goto procOK; } } else { | | | | | | | | | | | > | 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 | if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { goto procOK; } } else { procOK: if (specificNsInPattern) { elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(cmdName, -1); } Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } } entryPtr = Tcl_NextHashEntry(&search); } /* * If the effective namespace isn't the global :: namespace, and a * specific namespace wasn't requested in the pattern, then add in all * global :: procs that match the simple pattern. Of course, we add in * only those procs that aren't hidden by a proc in the effective * namespace. */ #ifdef INFO_PROCS_SEARCH_GLOBAL_NS /* * If "info procs" worked like "info commands", returning the commands * also seen in the global namespace, then you would include this * code. As this could break backwards compatibilty with 8.0-8.2, we * decided not to "fix" it in 8.3, leaving the behavior slightly * different. */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); while (entryPtr != NULL) { cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { |
︙ | ︙ | |||
1740 1741 1742 1743 1744 1745 1746 | } /* *---------------------------------------------------------------------- * * InfoScriptCmd -- * | | | < | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoScriptCmd -- * * Called to implement the "info script" command that returns the script * file that is currently being evaluated. Handles the following syntax: * * info script ?newName? * * If newName is specified, it will set that as the internal name. * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. It may change the internal * script filename. * *---------------------------------------------------------------------- */ static int InfoScriptCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
1790 1791 1792 1793 1794 1795 1796 | } /* *---------------------------------------------------------------------- * * InfoSharedlibCmd -- * | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * InfoSharedlibCmd -- * * Called to implement the "info sharedlibextension" command that returns * the file extension used for shared libraries. Handles the following * syntax: * * info sharedlibextension * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoSharedlibCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
1829 1830 1831 1832 1833 1834 1835 | } /* *---------------------------------------------------------------------- * * InfoTclVersionCmd -- * | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | } /* *---------------------------------------------------------------------- * * InfoTclVersionCmd -- * * Called to implement the "info tclversion" command that returns the * version number for this Tcl library. Handles the following syntax: * * info tclversion * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoTclVersionCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Obj *version; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } version = Tcl_GetVar2Ex(interp, "tcl_version", NULL, (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); if (version != NULL) { Tcl_SetObjResult(interp, version); return TCL_OK; } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * InfoVarsCmd -- * * Called to implement the "info vars" command that returns the list of * variables in the interpreter that match an optional pattern. The * pattern, if any, consists of an optional sequence of namespace names * separated by "::" qualifiers, which is followed by a glob-style * pattern that restricts which variables are returned. Handles the * following syntax: * * info vars ?pattern? * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is an * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoVarsCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Interp *iPtr = (Interp *) interp; char *varName, *pattern; CONST char *simplePattern; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Var *varPtr; Namespace *nsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ /* * Get the pattern and find the "effective namespace" in which to list * variables. We only use this effective namespace if there's no active * Tcl procedure frame. */ if (objc == 2) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; } else if (objc == 3) { /* * From the pattern, get the effective namespace and the simple * pattern (no namespace qualifiers or ::'s) at the end. If an error * was found while parsing the pattern, return it. Otherwise, if the * namespace wasn't found, just leave nsPtr NULL: we will return an * empty list since no variables there can be found. */ Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = TclGetString(objv[2]); TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); if (nsPtr != NULL) { /* We successfully found the pattern's ns */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } /* * If the namespace specified in the pattern wasn't found, just return. */ if (nsPtr == NULL) { return TCL_OK; } listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if ((iPtr->varFramePtr == NULL) || !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC) || specificNsInPattern) { /* * There is no frame pointer, the frame pointer was pushed only to * activate a namespace, or we are in a procedure call frame but a * specific namespace was specified. Create a list containing only the * variables in the effective namespace's variable table. */ if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { /* * If we can just do hash lookups, that simplifies things a lot. */ entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern); if (entryPtr != NULL) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { |
︙ | ︙ | |||
2011 2012 2013 2014 2015 2016 2017 | if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(varName, simplePattern)) { if (specificNsInPattern) { elemObjPtr = Tcl_NewObj(); | | > | | | < | | | 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 | if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(varName, simplePattern)) { if (specificNsInPattern) { elemObjPtr = Tcl_NewObj(); Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(varName, -1); } Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } } entryPtr = Tcl_NextHashEntry(&search); } /* * If the effective namespace isn't the global :: namespace, and a * specific namespace wasn't requested in the pattern (i.e., the * pattern only specifies variable names), then add in all global * :: variables that match the simple pattern. Of course, add in * only those variables that aren't hidden by a variable in the * effective namespace. */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); while (entryPtr != NULL) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); |
︙ | ︙ | |||
2065 2066 2067 2068 2069 2070 2071 | } /* *---------------------------------------------------------------------- * * Tcl_JoinObjCmd -- * | | | | 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 | } /* *---------------------------------------------------------------------- * * Tcl_JoinObjCmd -- * * This procedure is invoked to process the "join" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
2101 2102 2103 2104 2105 2106 2107 | joinString = Tcl_GetStringFromObj(objv[2], &joinLength); } else { Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); return TCL_ERROR; } /* | | | | 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 | joinString = Tcl_GetStringFromObj(objv[2], &joinLength); } else { Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); return TCL_ERROR; } /* * Make sure the list argument is a list object and get its length and a * pointer to its array of element pointers. */ result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } |
︙ | ︙ | |||
2172 2173 2174 2175 2176 2177 2178 | /* * First assign values out of the list to variables. */ for (i=0 ; i+2<objc ; i++) { /* | | | > > | | | > | < | | < | | > | 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 | /* * First assign values out of the list to variables. */ for (i=0 ; i+2<objc ; i++) { /* * We do this each time round the loop because that is robust against * shimmering nasties. */ if (Tcl_ListObjIndex(interp, objv[1], i, &valueObj) != TCL_OK) { return TCL_ERROR; } if (valueObj == NULL) { if (emptyObj == NULL) { TclNewObj(emptyObj); Tcl_IncrRefCount(emptyObj); } valueObj = emptyObj; } /* * Make sure the reference count for the value being assigned is * greater than one (other reference minimally in the list) so we * can't get hammered by shimmering. */ Tcl_IncrRefCount(valueObj); if (Tcl_ObjSetVar2(interp, objv[i+2], NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(valueObj); if (emptyObj != NULL) { Tcl_DecrRefCount(emptyObj); } return TCL_ERROR; } Tcl_DecrRefCount(valueObj); } if (emptyObj != NULL) { Tcl_DecrRefCount(emptyObj); } /* * Now place a list of any values left over into the interpreter result. * * First, figure out how many values were not assigned by getting the * length of the list. Note that I do not expect this operation to fail. */ if (Tcl_ListObjGetElements(interp, objv[1], &listObjc, &listObjv) != TCL_OK) { return TCL_ERROR; } if (listObjc > objc-2) { /* * OK, there were left-overs. Make a list of them and slap that back * in the interpreter result. */ Tcl_SetObjResult(interp, Tcl_NewListObj(listObjc - objc + 2, listObjv + objc - 2)); } return TCL_OK; } |
︙ | ︙ | |||
2265 2266 2267 2268 2269 2270 2271 | if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?"); return TCL_ERROR; } /* | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?"); return TCL_ERROR; } /* * If objc==3, then objv[2] may be either a single index or a list of * indices: go to TclLindexList to determine which. If objc>=4, or * objc==2, then objv[2 .. objc-2] are all single indices and processed as * such in TclLindexFlat. */ if (objc == 3) { elemPtr = TclLindexList(interp, objv[1], objv[2]); } else { elemPtr = TclLindexFlat(interp, objv[1], objc-2, objv+2); } /* * Set the interpreter's object result to the last element extracted. */ if (elemPtr == NULL) { return TCL_ERROR; } else { Tcl_SetObjResult(interp, elemPtr); Tcl_DecrRefCount(elemPtr); return TCL_OK; } } /* *---------------------------------------------------------------------- * * TclLindexList -- * * This procedure handles the 'lindex' command when objc==3. * * Results: * Returns a pointer to the object extracted, or NULL if an error * occurred. * * Side effects: * None. * * Notes: * If objv[1] can be parsed as a list, TclLindexList handles extraction * of the desired element locally. Otherwise, it invokes TclLindexFlat to * treat objv[1] as a scalar. * * The reference count of the returned object includes one reference * corresponding to the pointer returned. Thus, the calling code will * usually do something like: * Tcl_SetObjResult(interp, result); * Tcl_DecrRefCount(result); * *---------------------------------------------------------------------- */ Tcl_Obj * TclLindexList(interp, listPtr, argPtr) Tcl_Interp* interp; /* Tcl interpreter */ Tcl_Obj* listPtr; /* List being unpacked */ Tcl_Obj* argPtr; /* Index or index list */ { Tcl_Obj **elemPtrs; /* Elements of the list being manipulated. */ int listLen; /* Length of the list being manipulated. */ int index; /* Index into the list. */ int result; /* Result returned from a Tcl library call. */ int i; /* Current index number. */ Tcl_Obj **indices; /* Array of list indices. */ int indexCount; /* Size of the array of list indices. */ Tcl_Obj *oldListPtr; /* Temp location to preserve the list pointer * when replacing it with a sublist. */ /* * Determine whether argPtr designates a list or a single index. We have * to be careful about the order of the checks to avoid repeated * shimmering; see TIP#22 and TIP#33 for the details. */ if (argPtr->typePtr != &tclListType && TclGetIntForIndex(NULL , argPtr, 0, &index) == TCL_OK) { /* * argPtr designates a single index. */ return TclLindexFlat(interp, listPtr, 1, &argPtr); } if (Tcl_ListObjGetElements(NULL, argPtr, &indexCount, &indices) != TCL_OK){ /* * argPtr designates something that is neither an index nor a * well-formed list. Report the error via TclLindexFlat. */ return TclLindexFlat(interp, listPtr, 1, &argPtr); } /* * Record the reference to the list that we are maintaining in the * activation record. */ Tcl_IncrRefCount(listPtr); /* * argPtr designates a list, and the 'else if' above has parsed it into * indexCount and indices. */ for (i=0 ; i<indexCount ; i++) { /* * Convert the current listPtr to a list if necessary. */ |
︙ | ︙ | |||
2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 | Tcl_DecrRefCount(listPtr); return NULL; } else if (index<0 || index>=listLen) { /* * Index is out of range */ Tcl_DecrRefCount(listPtr); listPtr = Tcl_NewObj(); Tcl_IncrRefCount(listPtr); return listPtr; } /* | > | | | | | | | > | | | | | | | | < | < | | | | | | | | | | | | | | | | | | | | < | | | 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 | Tcl_DecrRefCount(listPtr); return NULL; } else if (index<0 || index>=listLen) { /* * Index is out of range */ Tcl_DecrRefCount(listPtr); listPtr = Tcl_NewObj(); Tcl_IncrRefCount(listPtr); return listPtr; } /* * Make sure listPtr still refers to a list object. If it shared a * Tcl_Obj structure with the arguments, then it might have just been * converted to something else. */ if (listPtr->typePtr != &tclListType) { result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); if (result != TCL_OK) { Tcl_DecrRefCount(listPtr); return NULL; } } /* * Extract the pointer to the appropriate element */ oldListPtr = listPtr; listPtr = elemPtrs[index]; Tcl_IncrRefCount(listPtr); Tcl_DecrRefCount(oldListPtr); /* * The work we did above may have caused the internal rep of *argPtr * to change to something else. Get it back. */ result = Tcl_ListObjGetElements(interp, argPtr, &indexCount, &indices); if (result != TCL_OK) { /* * This can't happen unless some extension corrupted a Tcl_Obj. */ Tcl_DecrRefCount(listPtr); return NULL; } } /* * Return the last object extracted. Its reference count will include the * reference being returned. */ return listPtr; } /* *---------------------------------------------------------------------- * * TclLindexFlat -- * * This procedure handles the 'lindex' command, given that the arguments * to the command are known to be a flat list. * * Results: * Returns a standard Tcl result. * * Side effects: * None. * * Notes: * This procedure is called from either tclExecute.c or Tcl_LindexObjCmd * whenever either is presented with objc==2 or objc>=4. It is also * called from TclLindexList for the objc==3 case once it is determined * that objv[2] cannot be parsed as a list. * *---------------------------------------------------------------------- */ Tcl_Obj * TclLindexFlat(interp, listPtr, indexCount, indexArray) Tcl_Interp *interp; /* Tcl interpreter */ Tcl_Obj *listPtr; /* Tcl object representing the list */ int indexCount; /* Count of indices */ Tcl_Obj *CONST indexArray[]; /* Array of pointers to Tcl objects * representing the indices in the list. */ { int i; /* Current list index. */ int result; /* Result of Tcl library calls. */ int listLen; /* Length of the current list being * processed. */ Tcl_Obj** elemPtrs; /* Array of pointers to the elements of the * current list. */ int index; /* Parsed version of the current element of * indexArray. */ Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that its ref * count can be decremented. */ /* * Record the reference to the 'listPtr' object that we are maintaining in * the C activation record. */ Tcl_IncrRefCount(listPtr); for (i=0 ; i<indexCount ; i++) { /* * Convert the current listPtr to a list if necessary. */ result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); if (result != TCL_OK) { Tcl_DecrRefCount(listPtr); return NULL; } /* * Get the index from objv[i]. */ result = TclGetIntForIndex(interp, indexArray[i], /*endValue*/ listLen-1, &index); if (result != TCL_OK) { /* * Index could not be parsed. */ Tcl_DecrRefCount(listPtr); return NULL; } else if (index<0 || index>=listLen) { /* * Index is out of range. */ Tcl_DecrRefCount(listPtr); listPtr = Tcl_NewObj(); Tcl_IncrRefCount(listPtr); return listPtr; } /* * Make sure listPtr still refers to a list object. It might have been * converted to something else above if objv[1] overlaps with one of * the other parameters. */ if (listPtr->typePtr != &tclListType) { result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); if (result != TCL_OK) { Tcl_DecrRefCount(listPtr); return NULL; } } /* * Extract the pointer to the appropriate element. */ oldListPtr = listPtr; listPtr = elemPtrs[index]; Tcl_IncrRefCount(listPtr); Tcl_DecrRefCount(oldListPtr); } return listPtr; } /* *---------------------------------------------------------------------- * * Tcl_LinsertObjCmd -- * * This object-based procedure is invoked to process the "linsert" Tcl * command. See the user documentation for details on what it does. * * Results: * A new Tcl list object formed by inserting zero or more elements into a * list. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2610 2611 2612 2613 2614 2615 2616 | result = Tcl_ListObjLength(interp, objv[1], &len); if (result != TCL_OK) { return result; } /* | | | | > | 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 | result = Tcl_ListObjLength(interp, objv[1], &len); if (result != TCL_OK) { return result; } /* * Get the index. "end" is interpreted to be the index after the last * element, such that using it will cause any inserted elements to be * appended to the list. */ result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index); if (result != TCL_OK) { return result; } if (index > len) { index = len; } /* * If the list object is unshared we can modify it directly. Otherwise we * create a copy to modify: this is "copy on write". */ listPtr = objv[1]; isDuplicate = 0; if (Tcl_IsShared(listPtr)) { listPtr = Tcl_DuplicateObj(listPtr); isDuplicate = 1; } if ((objc == 4) && (index == len)) { /* * Special case: insert one element at the end of the list. */ result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]); } else if (objc > 3) { result = Tcl_ListObjReplace(interp, listPtr, index, 0, (objc-3), &(objv[3])); } if (result != TCL_OK) { if (isDuplicate) { |
︙ | ︙ | |||
2664 2665 2666 2667 2668 2669 2670 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjCmd -- * | | | | 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjCmd -- * * This procedure is invoked to process the "list" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
2701 2702 2703 2704 2705 2706 2707 | /* *---------------------------------------------------------------------- * * Tcl_LlengthObjCmd -- * * This object-based procedure is invoked to process the "llength" Tcl | | | 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 | /* *---------------------------------------------------------------------- * * Tcl_LlengthObjCmd -- * * This object-based procedure is invoked to process the "llength" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
2734 2735 2736 2737 2738 2739 2740 | result = Tcl_ListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } /* * Set the interpreter's object result to an integer object holding the | | | | | 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 | result = Tcl_ListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } /* * Set the interpreter's object result to an integer object holding the * length. */ Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen)); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LrangeObjCmd -- * * This procedure is invoked to process the "lrange" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
2776 2777 2778 2779 2780 2781 2782 | if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "list first last"); return TCL_ERROR; } /* | | | | 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 | if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "list first last"); return TCL_ERROR; } /* * Make sure the list argument is a list object and get its length and a * pointer to its array of element pointers. */ listPtr = objv[1]; result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); if (result != TCL_OK) { return result; } |
︙ | ︙ | |||
2815 2816 2817 2818 2819 2820 2821 | if (first > last) { return TCL_OK; /* the result is an empty object */ } /* * Make sure listPtr still refers to a list object. It might have been * converted to an int above if the argument objects were shared. | | | | | | | | | | > | > | | < | | < < < < < < < < < < < | < < < | < < | | < < | < | | | | > > < < < < | | | | | | 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 | if (first > last) { return TCL_OK; /* the result is an empty object */ } /* * Make sure listPtr still refers to a list object. It might have been * converted to an int above if the argument objects were shared. */ if (listPtr->typePtr != &tclListType) { result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); if (result != TCL_OK) { return result; } } /* * Extract a range of fields. We modify the interpreter's result object to * be a list object containing the specified elements. */ numElems = (last - first + 1); Tcl_SetObjResult(interp, Tcl_NewListObj(numElems, &(elemPtrs[first]))); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LrepeatObjCmd -- * * This procedure is invoked to process the "lrepeat" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_LrepeatObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ register int objc; /* Number of arguments. */ register Tcl_Obj *CONST objv[]; /* The argument objects. */ { int elementCount, i, result; Tcl_Obj *listPtr, **dataArray; List *listRepPtr; /* * Check arguments for legality: * lrepeat posInt value ?value ...? */ if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "positiveCount value ?value ...?"); return TCL_ERROR; } elementCount = 0; result = Tcl_GetIntFromObj(interp, objv[1], &elementCount); if (result == TCL_ERROR) { return TCL_ERROR; } if (elementCount < 1) { Tcl_AppendResult(interp, "must have a count of at least 1", NULL); return TCL_ERROR; } /* * Skip forward to the interesting arguments now we've finished parsing. */ objc -= 2; objv += 2; /* * Get an empty list object that is allocated large enough to hold each * init value elementCount times. */ listPtr = Tcl_NewListObj(elementCount*objc, NULL); listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; listRepPtr->elemCount = elementCount*objc; dataArray = &listRepPtr->elements; /* * Set the elements. Note that we handle the common degenerate case of a * single value being repeated separately to permit the compiler as much * room as possible to optimize a loop that might be run a very large * number of times. */ if (objc == 1) { register Tcl_Obj *tmpPtr = objv[0]; tmpPtr->refCount += elementCount; for (i=0 ; i<elementCount ; i++) { dataArray[i] = tmpPtr; } } else { int j, k = 0; for (i=0 ; i<elementCount ; i++) { for (j=0 ; j<objc ; j++) { Tcl_IncrRefCount(objv[j]); dataArray[k++] = objv[j]; } } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LreplaceObjCmd -- * * This object-based procedure is invoked to process the "lreplace" Tcl * command. See the user documentation for details on what it does. * * Results: * A new Tcl list object formed by replacing zero or more elements of a * list. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2991 2992 2993 2994 2995 2996 2997 | result = Tcl_ListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } /* | | | | | | | | | | | | | | | > | | | > > > | 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 | result = Tcl_ListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { return result; } /* * Get the first and last indexes. "end" is interpreted to be the index * for the last element, such that using it will cause that element to be * included for deletion. */ result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first); if (result != TCL_OK) { return result; } result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last); if (result != TCL_OK) { return result; } if (first < 0) { first = 0; } /* * Complain if the user asked for a start element that is greater than the * list length. This won't ever trigger for the "end*" case as that will * be properly constrained by TclGetIntForIndex because we use listLen-1 * (to allow for replacing the last elem). */ if ((first >= listLen) && (listLen > 0)) { Tcl_AppendResult(interp, "list doesn't contain element ", TclGetString(objv[2]), (int *) NULL); return TCL_ERROR; } if (last >= listLen) { last = (listLen - 1); } if (first <= last) { numToDelete = (last - first + 1); } else { numToDelete = 0; } /* * If the list object is unshared we can modify it directly, otherwise we * create a copy to modify: this is "copy on write". */ listPtr = objv[1]; isDuplicate = 0; if (Tcl_IsShared(listPtr)) { listPtr = Tcl_DuplicateObj(listPtr); isDuplicate = 1; } if (objc > 4) { result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, (objc-4), &(objv[4])); } else { result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, 0, NULL); } if (result != TCL_OK) { if (isDuplicate) { Tcl_DecrRefCount(listPtr); /* free unneeded obj */ } return result; } /* * Set the interpreter's object result. */ Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LsearchObjCmd -- * * This procedure is invoked to process the "lsearch" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LsearchObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument values. */ { char *bytes, *patternBytes; int i, match, mode, index, result, listc, length, elemLen; int dataType, isIncreasing, lower, upper, patInt, objInt, offset; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; Tcl_RegExp regexp = NULL; static CONST char *options[] = { "-all", "-ascii", "-decreasing", "-dictionary", "-exact", "-glob", "-increasing", "-index", "-inline", "-integer", "-nocase", "-not", "-real", "-regexp", "-sorted", "-start", "-subindices", NULL }; enum options { LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, LSEARCH_START, LSEARCH_SUBINDICES }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL }; enum modes { EXACT, GLOB, REGEXP, SORTED }; SortStrCmpFn_t strCmpFn = strcmp; mode = GLOB; dataType = ASCII; isIncreasing = 1; allMatches = 0; inlineReturn = 0; returnSubindices = 0; negatedMatch = 0; listPtr = NULL; startPtr = NULL; offset = 0; noCase = 0; sortInfo.compareCmdPtr = NULL; sortInfo.isIncreasing = 0; sortInfo.sortMode = 0; sortInfo.interp = interp; sortInfo.resultCode = TCL_OK; sortInfo.indexv = NULL; sortInfo.indexc = 0; |
︙ | ︙ | |||
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 | isIncreasing = 1; break; case LSEARCH_INLINE: /* -inline */ inlineReturn = 1; break; case LSEARCH_INTEGER: /* -integer */ dataType = INTEGER; break; case LSEARCH_NOT: /* -not */ negatedMatch = 1; break; case LSEARCH_REAL: /* -real */ dataType = REAL; break; case LSEARCH_REGEXP: /* -regexp */ mode = REGEXP; break; case LSEARCH_SORTED: /* -sorted */ mode = SORTED; break; case LSEARCH_SUBINDICES: /* -subindices */ returnSubindices = 1; break; case LSEARCH_START: /* -start */ /* | > > > > | | < > | | | < | > | 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 | isIncreasing = 1; break; case LSEARCH_INLINE: /* -inline */ inlineReturn = 1; break; case LSEARCH_INTEGER: /* -integer */ dataType = INTEGER; break; case LSEARCH_NOCASE: /* -nocase */ strCmpFn = strcasecmp; noCase = 1; break; case LSEARCH_NOT: /* -not */ negatedMatch = 1; break; case LSEARCH_REAL: /* -real */ dataType = REAL; break; case LSEARCH_REGEXP: /* -regexp */ mode = REGEXP; break; case LSEARCH_SORTED: /* -sorted */ mode = SORTED; break; case LSEARCH_SUBINDICES: /* -subindices */ returnSubindices = 1; break; case LSEARCH_START: /* -start */ /* * If there was a previous -start option, release its saved index * because it will either be replaced or there will be an error. */ if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } if (i > objc-4) { if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } Tcl_AppendResult(interp, "missing starting index", NULL); return TCL_ERROR; } i++; if (objv[i] == objv[objc - 2]) { /* * Take copy to prevent shimmering problems. Note that it * does not matter if the index obj is also a component of the * list being searched. We only need to copy where the list * and the index are one-and-the-same. */ startPtr = Tcl_DuplicateObj(objv[i]); } else { startPtr = objv[i]; Tcl_IncrRefCount(startPtr); } break; case LSEARCH_INDEX: { /* -index */ |
︙ | ︙ | |||
3242 3243 3244 3245 3246 3247 3248 | "\"-index\" option must be followed by list index", NULL); return TCL_ERROR; } /* * Store the extracted indices for processing by sublist | | | | 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 | "\"-index\" option must be followed by list index", NULL); return TCL_ERROR; } /* * Store the extracted indices for processing by sublist * extraction. Note that we don't do this using objects because * that has shimmering problems. */ i++; if (Tcl_ListObjGetElements(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); |
︙ | ︙ | |||
3267 3268 3269 3270 3271 3272 3273 | break; default: sortInfo.indexv = (int *) ckalloc(sizeof(int) * sortInfo.indexc); } /* | | | | < < < | | < < | 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 | break; default: sortInfo.indexv = (int *) ckalloc(sizeof(int) * sortInfo.indexc); } /* * Fill the array by parsing each index. We don't know whether * their scale is sensible yet, but we at least perform the * syntactic check here. */ for (j=0 ; j<sortInfo.indexc ; j++) { if (TclGetIntForIndex(interp, indices[j], SORTIDX_END, &sortInfo.indexv[j]) != TCL_OK) { if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } TclFormatToErrorInfo(interp, "\n (-index option item number %d)", j); return TCL_ERROR; } } break; } } } |
︙ | ︙ | |||
3311 3312 3313 3314 3315 3316 3317 3318 | } if ((enum modes) mode == REGEXP) { /* * We can shimmer regexp/list if listv[i] == pattern, so get the * regexp rep before the list rep. */ regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], | > | > | | > | 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 | } if ((enum modes) mode == REGEXP) { /* * We can shimmer regexp/list if listv[i] == pattern, so get the * regexp rep before the list rep. */ regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], TCL_REG_ADVANCED | TCL_REG_NOSUB | (noCase ? TCL_REG_NOCASE : 0)); if (regexp == NULL) { if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } return TCL_ERROR; } } /* * Make sure the list argument is a list object and get its length and a * pointer to its array of element pointers. */ result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } return result; } /* * Get the user-specified start offset. */ if (startPtr) { result = TclGetIntForIndex(interp, startPtr, listc-1, &offset); Tcl_DecrRefCount(startPtr); if (result != TCL_OK) { if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } |
︙ | ︙ | |||
3392 3393 3394 3395 3396 3397 3398 | break; } } else { patternBytes = Tcl_GetStringFromObj(patObj, &length); } /* | | | < > | | | | < > | | 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 | break; } } else { patternBytes = Tcl_GetStringFromObj(patObj, &length); } /* * Set default index value to -1, indicating failure; if we find the item * in the course of our search, index will be set to the correct value. */ index = -1; match = 0; if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) { /* * If the data is sorted, we can do a more intelligent search. Note * that there is no point in being smart when -all was specified; in * that case, we have to look at all items anyway, and there is no * sense in doing this when the match sense is inverted. */ lower = offset - 1; upper = listc; while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; itemPtr = SelectObjFromSublist(listv[i], &sortInfo); if (sortInfo.resultCode != TCL_OK) { if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } return sortInfo.resultCode; } switch ((enum datatypes) dataType) { case ASCII: bytes = TclGetString(itemPtr); match = strCmpFn(patternBytes, bytes); break; case DICTIONARY: bytes = TclGetString(itemPtr); match = DictionaryCompare(patternBytes, bytes); break; case INTEGER: result = Tcl_GetIntFromObj(interp, itemPtr, &objInt); |
︙ | ︙ | |||
3462 3463 3464 3465 3466 3467 3468 | } else { match = 1; } break; } if (match == 0) { /* | | | | | > | | | | | > | 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 | } else { match = 1; } break; } if (match == 0) { /* * Normally, binary search is written to stop when it finds a * match. If there are duplicates of an element in the list, * our first match might not be the first occurance. * Consider: 0 0 0 1 1 1 2 2 2 * * To maintain consistancy with standard lsearch semantics, we * must find the leftmost occurance of the pattern in the * list. Thus we don't just stop searching here. This * variation means that a search always makes log n * comparisons (normal binary search might "get lucky" with an * early comparison). */ index = i; upper = i; } else if (match > 0) { if (isIncreasing) { lower = i; } else { upper = i; |
︙ | ︙ | |||
3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 | } else { /* * We need to do a linear search, because (at least one) of: * - our matcher can only tell equal vs. not equal * - our matching sense is negated * - we're building a list of all matched items */ if (allMatches) { listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); } for (i = offset; i < listc; i++) { match = 0; itemPtr = SelectObjFromSublist(listv[i], &sortInfo); if (sortInfo.resultCode != TCL_OK) { | > | 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 | } else { /* * We need to do a linear search, because (at least one) of: * - our matcher can only tell equal vs. not equal * - our matching sense is negated * - we're building a list of all matched items */ if (allMatches) { listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); } for (i = offset; i < listc; i++) { match = 0; itemPtr = SelectObjFromSublist(listv[i], &sortInfo); if (sortInfo.resultCode != TCL_OK) { |
︙ | ︙ | |||
3519 3520 3521 3522 3523 3524 3525 | switch ((enum modes) mode) { case SORTED: case EXACT: switch ((enum datatypes) dataType) { case ASCII: bytes = Tcl_GetStringFromObj(itemPtr, &elemLen); if (length == elemLen) { | > > > > > > > > | | > | 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 | switch ((enum modes) mode) { case SORTED: case EXACT: switch ((enum datatypes) dataType) { case ASCII: bytes = Tcl_GetStringFromObj(itemPtr, &elemLen); if (length == elemLen) { /* * This split allows for more optimal compilation of * memcmp/ */ if (noCase) { match = (strcasecmp(bytes, patternBytes) == 0); } else { match = (memcmp(bytes, patternBytes, (size_t) length) == 0); } } break; case DICTIONARY: bytes = TclGetString(itemPtr); match = (DictionaryCompare(bytes, patternBytes) == 0); break; |
︙ | ︙ | |||
3559 3560 3561 3562 3563 3564 3565 | } match = (objDouble == patDouble); break; } break; case GLOB: | | > > > > | 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 | } match = (objDouble == patDouble); break; } break; case GLOB: match = Tcl_StringCaseMatch(TclGetString(itemPtr), patternBytes, noCase); break; case REGEXP: match = Tcl_RegExpExecObj(interp, regexp, itemPtr, 0, 0, 0); if (match < 0) { Tcl_DecrRefCount(patObj); if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } return TCL_ERROR; } break; } /* * Invert match condition for -not */ if (negatedMatch) { match = !match; } if (!match) { continue; } if (!allMatches) { index = i; break; } else if (inlineReturn) { /* * Note that these appends are not expected to fail. */ if (returnSubindices) { itemPtr = SelectObjFromSublist(listv[i], &sortInfo); } else { itemPtr = listv[i]; } Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else if (returnSubindices) { |
︙ | ︙ | |||
3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 | } } } /* * Return everything or a single value. */ if (allMatches) { Tcl_SetObjResult(interp, listPtr); } else if (!inlineReturn) { if (returnSubindices) { int j; itemPtr = Tcl_NewIntObj(index); for (j=0 ; j<sortInfo.indexc ; j++) { Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj(sortInfo.indexv[j])); } Tcl_SetObjResult(interp, itemPtr); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(index)); } } else if (index < 0) { /* | > | | > > > | | | < | > | > | | > | > | | | | | | | | < | | | > | > | | | | > | > | < | | | 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 | } } } /* * Return everything or a single value. */ if (allMatches) { Tcl_SetObjResult(interp, listPtr); } else if (!inlineReturn) { if (returnSubindices) { int j; itemPtr = Tcl_NewIntObj(index); for (j=0 ; j<sortInfo.indexc ; j++) { Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj(sortInfo.indexv[j])); } Tcl_SetObjResult(interp, itemPtr); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(index)); } } else if (index < 0) { /* * Is this superfluous? The result should be a blank object by * default... */ Tcl_SetObjResult(interp, Tcl_NewObj()); } else { Tcl_SetObjResult(interp, listv[index]); } /* * Cleanup the index list array. */ if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LsetObjCmd -- * * This procedure is invoked to process the "lset" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LsetObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument values. */ { Tcl_Obj* listPtr; /* Pointer to the list being altered. */ Tcl_Obj* finalValuePtr; /* Value finally assigned to the variable. */ /* * Check parameter count. */ if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "listVar index ?index...? value"); return TCL_ERROR; } /* * Look up the list variable's value. */ listPtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, TCL_LEAVE_ERR_MSG); if (listPtr == NULL) { return TCL_ERROR; } /* * Substitute the value in the value. Return either the value or else an * unshared copy of it. */ if (objc == 4) { finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); } else { finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, objv[objc-1]); } /* * If substitution has failed, bail out. */ if (finalValuePtr == NULL) { return TCL_ERROR; } /* * Finally, update the variable so that traces fire. */ listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr, TCL_LEAVE_ERR_MSG); Tcl_DecrRefCount(finalValuePtr); if (listPtr == NULL) { return TCL_ERROR; } /* * Return the new value of the variable as the interpreter result. */ Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LsortObjCmd -- * * This procedure is invoked to process the "lsort" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
3755 3756 3757 3758 3759 3760 3761 | Tcl_Obj *CONST objv[]; /* Argument values. */ { int i, index, unique, indices; Tcl_Obj *resultPtr; int length; Tcl_Obj *cmdPtr, **listObjPtrs; SortElement *elementArray; | | | < | | > | > | | | 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 | Tcl_Obj *CONST objv[]; /* Argument values. */ { int i, index, unique, indices; Tcl_Obj *resultPtr; int length; Tcl_Obj *cmdPtr, **listObjPtrs; SortElement *elementArray; SortElement *elementPtr; SortInfo sortInfo; /* Information about this sort that needs to * be passed to the comparison function. */ static CONST char *switches[] = { "-ascii", "-command", "-decreasing", "-dictionary", "-increasing", "-index", "-indices", "-integer", "-nocase", "-real", "-unique", (char *) NULL }; enum Lsort_Switches { LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY, LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER, LSORT_NOCASE, LSORT_REAL, LSORT_UNIQUE }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?options? list"); return TCL_ERROR; } /* * Parse arguments to set up the mode for the sort. */ sortInfo.isIncreasing = 1; sortInfo.sortMode = SORTMODE_ASCII; sortInfo.strCmpFn = strcmp; sortInfo.indexv = NULL; sortInfo.indexc = 0; sortInfo.interp = interp; sortInfo.resultCode = TCL_OK; cmdPtr = NULL; unique = 0; indices = 0; for (i = 1; i < objc-1; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum Lsort_Switches) index) { case LSORT_ASCII: sortInfo.sortMode = SORTMODE_ASCII; break; case LSORT_COMMAND: |
︙ | ︙ | |||
3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 | ckfree((char *) sortInfo.indexv); } if (i == (objc-2)) { Tcl_AppendResult(interp, "\"-index\" option must be ", "followed by list index", NULL); return TCL_ERROR; } /* * Take copy to prevent shimmering problems. */ | > > | | | | | < < < | | < < > > > | | < | 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 | ckfree((char *) sortInfo.indexv); } if (i == (objc-2)) { Tcl_AppendResult(interp, "\"-index\" option must be ", "followed by list index", NULL); return TCL_ERROR; } /* * Take copy to prevent shimmering problems. */ if (Tcl_ListObjGetElements(interp, objv[i+1], &sortInfo.indexc, &indices) != TCL_OK) { return TCL_ERROR; } switch (sortInfo.indexc) { case 0: sortInfo.indexv = NULL; break; case 1: sortInfo.indexv = &sortInfo.singleIndex; break; default: sortInfo.indexv = (int *) ckalloc(sizeof(int) * sortInfo.indexc); } /* * Fill the array by parsing each index. We don't know whether * their scale is sensible yet, but we at least perform the * syntactic check here. */ for (j=0 ; j<sortInfo.indexc ; j++) { if (TclGetIntForIndex(interp, indices[j], SORTIDX_END, &sortInfo.indexv[j]) != TCL_OK) { if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } TclFormatToErrorInfo(interp, "\n (-index option item number %d)", j); return TCL_ERROR; } } i++; break; } case LSORT_INTEGER: sortInfo.sortMode = SORTMODE_INTEGER; break; case LSORT_NOCASE: sortInfo.strCmpFn = strcasecmp; break; case LSORT_REAL: sortInfo.sortMode = SORTMODE_REAL; break; case LSORT_UNIQUE: unique = 1; break; case LSORT_INDICES: indices = 1; break; } } if (sortInfo.sortMode == SORTMODE_COMMAND) { /* * The existing command is a list. We want to flatten it, append two * dummy arguments on the end, and replace these arguments later. */ Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr); Tcl_Obj *newObjPtr = Tcl_NewObj(); Tcl_IncrRefCount(newCommandPtr); if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr) |
︙ | ︙ | |||
3969 3970 3971 3972 3973 3974 3975 | done: if (sortInfo.sortMode == SORTMODE_COMMAND) { Tcl_DecrRefCount(sortInfo.compareCmdPtr); sortInfo.compareCmdPtr = NULL; } if (sortInfo.indexc > 1) { | | | | | | < | | | | | < | | | | | < | < | < | | | 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 | done: if (sortInfo.sortMode == SORTMODE_COMMAND) { Tcl_DecrRefCount(sortInfo.compareCmdPtr); sortInfo.compareCmdPtr = NULL; } if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } return sortInfo.resultCode; } /* *---------------------------------------------------------------------- * * MergeSort - * * This procedure sorts a linked list of SortElement structures use the * merge-sort algorithm. * * Results: * A pointer to the head of the list after sorting is returned. * * Side effects: * None, unless a user-defined comparison command does something weird. * *---------------------------------------------------------------------- */ static SortElement * MergeSort(headPtr, infoPtr) SortElement *headPtr; /* First element on the list. */ SortInfo *infoPtr; /* Information needed by the comparison * operator. */ { /* * The subList array below holds pointers to temporary lists built during * the merge sort. Element i of the array holds a list of length 2**i. */ # define NUM_LISTS 30 SortElement *subList[NUM_LISTS]; SortElement *elementPtr; int i; for (i=0 ; i<NUM_LISTS ; i++) { subList[i] = NULL; } while (headPtr != NULL) { elementPtr = headPtr; headPtr = headPtr->nextPtr; elementPtr->nextPtr = 0; for (i=0 ; i<NUM_LISTS && subList[i]!=NULL ; i++) { elementPtr = MergeLists(subList[i], elementPtr, infoPtr); subList[i] = NULL; } if (i >= NUM_LISTS) { i = NUM_LISTS-1; } subList[i] = elementPtr; } elementPtr = NULL; for (i=0 ; i<NUM_LISTS ; i++) { elementPtr = MergeLists(subList[i], elementPtr, infoPtr); } return elementPtr; } /* *---------------------------------------------------------------------- * * MergeLists - * * This procedure combines two sorted lists of SortElement structures * into a single sorted list. * * Results: * The unified list of SortElement structures. * * Side effects: * None, unless a user-defined comparison command does something weird. * *---------------------------------------------------------------------- */ static SortElement * MergeLists(leftPtr, rightPtr, infoPtr) SortElement *leftPtr; /* First list to be merged; may be NULL. */ SortElement *rightPtr; /* Second list to be merged; may be NULL. */ SortInfo *infoPtr; /* Information needed by the comparison * operator. */ { SortElement *headPtr; SortElement *tailPtr; int cmp; if (leftPtr == NULL) { return rightPtr; |
︙ | ︙ | |||
4113 4114 4115 4116 4117 4118 4119 | * * SortCompare -- * * This procedure is invoked by MergeLists to determine the proper * ordering between two elements. * * Results: | | | | | | < | | | | | > | | | < | | | | | | 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 | * * SortCompare -- * * This procedure is invoked by MergeLists to determine the proper * ordering between two elements. * * Results: * A negative results means the the first element comes before the * second, and a positive results means that the second element should * come first. A result of zero means the two elements are equal and it * doesn't matter which comes first. * * Side effects: * None, unless a user-defined comparison command does something weird. * *---------------------------------------------------------------------- */ static int SortCompare(objPtr1, objPtr2, infoPtr) Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */ SortInfo *infoPtr; /* Information passed from the top-level * "lsort" command. */ { int order; order = 0; if (infoPtr->resultCode != TCL_OK) { /* * Once an error has occurred, skip any future comparisons so as to * preserve the error message in sortInterp->result. */ return order; } objPtr1 = SelectObjFromSublist(objPtr1, infoPtr); if (infoPtr->resultCode != TCL_OK) { return order; } objPtr2 = SelectObjFromSublist(objPtr2, infoPtr); if (infoPtr->resultCode != TCL_OK) { return order; } if (infoPtr->sortMode == SORTMODE_ASCII) { order = infoPtr->strCmpFn(TclGetString(objPtr1), TclGetString(objPtr2)); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { order = DictionaryCompare( TclGetString(objPtr1), TclGetString(objPtr2)); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { long a, b; if ((Tcl_GetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK) || (Tcl_GetLongFromObj(infoPtr->interp, objPtr2, &b) != TCL_OK)) { infoPtr->resultCode = TCL_ERROR; return order; } if (a > b) { order = 1; } else if (b > a) { order = -1; } } else if (infoPtr->sortMode == SORTMODE_REAL) { double a, b; if (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK || Tcl_GetDoubleFromObj(infoPtr->interp,objPtr2,&b) != TCL_OK){ infoPtr->resultCode = TCL_ERROR; return order; } if (a > b) { order = 1; } else if (b > a) { order = -1; } } else { Tcl_Obj **objv, *paramObjv[2]; int objc; paramObjv[0] = objPtr1; paramObjv[1] = objPtr2; /* * We made space in the command list for the two things to compare. * Replace them and evaluate the result. */ Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, 2, 2, paramObjv); Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, &objc, &objv); infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); if (infoPtr->resultCode != TCL_OK) { Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)"); return order; } /* * Parse the result of the command. |
︙ | ︙ | |||
4234 4235 4236 4237 4238 4239 4240 | } /* *---------------------------------------------------------------------- * * DictionaryCompare * | | | | | | | | | | | | | | | | < | | | | | | | | | | | | > | > | < | | | | | | | | | | | < | | > > > > > > > > > > > | 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 | } /* *---------------------------------------------------------------------- * * DictionaryCompare * * This function compares two strings as if they were being used in an * index or card catalog. The case of alphabetic characters is ignored, * except to break ties. Thus "B" comes before "b" but after "a". Also, * integers embedded in the strings compare in numerical order. In other * words, "x10y" comes after "x9y", not * before it as it would when * using strcmp(). * * Results: * A negative result means that the first element comes before the * second, and a positive result means that the second element should * come first. A result of zero means the two elements are equal and it * doesn't matter which comes first. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int DictionaryCompare(left, right) char *left, *right; /* The strings to compare. */ { Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower; int diff, zeros; int secondaryDiff = 0; while (1) { if (isdigit(UCHAR(*right)) /* INTL: digit */ && isdigit(UCHAR(*left))) { /* INTL: digit */ /* * There are decimal numbers embedded in the two strings. Compare * them as numbers, rather than strings. If one number has more * leading zeros than the other, the number with more leading * zeros sorts later, but only as a secondary choice. */ zeros = 0; while ((*right == '0') && (isdigit(UCHAR(right[1])))) { right++; zeros--; } while ((*left == '0') && (isdigit(UCHAR(left[1])))) { left++; zeros++; } if (secondaryDiff == 0) { secondaryDiff = zeros; } /* * The code below compares the numbers in the two strings without * ever converting them to integers. It does this by first * comparing the lengths of the numbers and then comparing the * digit values. */ diff = 0; while (1) { if (diff == 0) { diff = UCHAR(*left) - UCHAR(*right); } right++; left++; if (!isdigit(UCHAR(*right))) { /* INTL: digit */ if (isdigit(UCHAR(*left))) { /* INTL: digit */ return 1; } else { /* * The two numbers have the same length. See if their * values are different. */ if (diff != 0) { return diff; } break; } } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ return -1; } } continue; } /* * Convert character to Unicode for comparison purposes. If either * string is at the terminating null, do a byte-wise comparison and * bail out immediately. */ if ((*left != '\0') && (*right != '\0')) { left += Tcl_UtfToUniChar(left, &uniLeft); right += Tcl_UtfToUniChar(right, &uniRight); /* * Convert both chars to lower for the comparison, because * dictionary sorts are case insensitve. Covert to lower, not * upper, so chars between Z and a will sort before A (where most * other interesting punctuations occur) */ uniLeftLower = Tcl_UniCharToLower(uniLeft); uniRightLower = Tcl_UniCharToLower(uniRight); } else { diff = UCHAR(*left) - UCHAR(*right); break; } diff = uniLeftLower - uniRightLower; if (diff) { return diff; } else if (secondaryDiff == 0) { if (Tcl_UniCharIsUpper(uniLeft) && Tcl_UniCharIsLower(uniRight)) { secondaryDiff = -1; } else if (Tcl_UniCharIsUpper(uniRight) && Tcl_UniCharIsLower(uniLeft)) { secondaryDiff = 1; } } } if (diff == 0) { diff = secondaryDiff; } return diff; } /* *---------------------------------------------------------------------- * * SelectObjFromSublist -- * * This procedure is invoked from lsearch and SortCompare. It is used * for implementing the -index option, for the lsort and lsearch * commands. * * Results: * Returns NULL if a failure occurs, and sets the result in the infoPtr. * Otherwise returns the Tcl_Obj* to the item. * * Side effects: * None. * * Note: * No reference counting is done, as the result is only used internally * and never passed directly to user code. * *---------------------------------------------------------------------- */ static Tcl_Obj* SelectObjFromSublist(objPtr, infoPtr) Tcl_Obj *objPtr; /* Obj to select sublist from. */ SortInfo *infoPtr; /* Information passed from the top-level * "lsearch" or "lsort" command. */ { int i; /* * Quick check for case when no "-index" option is there. */ if (infoPtr->indexc == 0) { return objPtr; } /* * Iterate over the indices, traversing through the nested sublists as we * go. */ for (i=0 ; i<infoPtr->indexc ; i++) { int listLen, index; Tcl_Obj *currentObj; if (Tcl_ListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } index = infoPtr->indexv[i]; /* * Adjust for end-based indexing. */ if (index < SORTIDX_NONE) { index += listLen + 1; } if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index, ¤tObj) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } if (currentObj == NULL) { char buffer[TCL_INTEGER_SPACE]; TclFormatInt(buffer, index); Tcl_AppendResult(infoPtr->interp, "element ", buffer, " missing from sublist \"", TclGetString(objPtr), "\"", (char *) NULL); infoPtr->resultCode = TCL_ERROR; return NULL; } objPtr = currentObj; } return objPtr; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclCmdMZ.c.
|
| | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | /* * tclCmdMZ.c -- * * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters M to Z. It * contains only commands in the generic core (i.e. those that don't * depend much upon UNIX facilities). * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Scriptics Corporation. * Copyright (c) 2002 ActiveState Corporation. * Copyright (c) 2003 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclCmdMZ.c,v 1.115.2.13 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" #include "tclRegexp.h" /* *---------------------------------------------------------------------- * * Tcl_PwdObjCmd -- * * This procedure is invoked to process the "pwd" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_PwdObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Obj *retVal; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } |
︙ | ︙ | |||
63 64 65 66 67 68 69 | } /* *---------------------------------------------------------------------- * * Tcl_RegexpObjCmd -- * | | | | | | | | | | | | | | | | | | | | < | | | < | | | < | | | < | | | < | | | < | | > > > | < < < < < | | | < | > | | | | < > | | < > | > > | | | | | < | | | | < | | > | > > < > > > > > > | | | > > > > > > > > > | | > > | | | > | | | | < | | | > | | | > | | | | > | | > | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_RegexpObjCmd -- * * This procedure is invoked to process the "regexp" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_RegexpObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int i, indices, match, about, offset, all, doinline, numMatchesSaved; int cflags, eflags, stringLength; Tcl_RegExp regExpr; Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL; Tcl_RegExpInfo info; static CONST char *options[] = { "-all", "-about", "-indices", "-inline", "-expanded", "-line", "-linestop", "-lineanchor", "-nocase", "-start", "--", (char *) NULL }; enum options { REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, REGEXP_NOCASE, REGEXP_START, REGEXP_LAST }; indices = 0; about = 0; cflags = TCL_REG_ADVANCED; eflags = 0; offset = 0; all = 0; doinline = 0; for (i = 1; i < objc; i++) { char *name; int index; name = TclGetString(objv[i]); if (name[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, &index) != TCL_OK) { goto optionError; } switch ((enum options) index) { case REGEXP_ALL: all = 1; break; case REGEXP_INDICES: indices = 1; break; case REGEXP_INLINE: doinline = 1; break; case REGEXP_NOCASE: cflags |= TCL_REG_NOCASE; break; case REGEXP_ABOUT: about = 1; break; case REGEXP_EXPANDED: cflags |= TCL_REG_EXPANDED; break; case REGEXP_LINE: cflags |= TCL_REG_NEWLINE; break; case REGEXP_LINESTOP: cflags |= TCL_REG_NLSTOP; break; case REGEXP_LINEANCHOR: cflags |= TCL_REG_NLANCH; break; case REGEXP_START: { int temp; if (++i >= objc) { goto endOfForLoop; } if (TclGetIntForIndex(interp, objv[i], 0, &temp) != TCL_OK) { goto optionError; } if (startIndex) { Tcl_DecrRefCount(startIndex); } startIndex = objv[i]; Tcl_IncrRefCount(startIndex); break; } case REGEXP_LAST: i++; goto endOfForLoop; } } endOfForLoop: if ((objc - i) < (2 - about)) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); goto optionError; } objc -= i; objv += i; /* * Check if the user requested -inline, but specified match variables; a * no-no. */ if (doinline && ((objc - 2) != 0)) { Tcl_AppendResult(interp, "regexp match variables not allowed", " when using -inline", (char *) NULL); goto optionError; } /* * Handle the odd about case separately. */ if (about) { regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) { optionError: if (startIndex) { Tcl_DecrRefCount(startIndex); } return TCL_ERROR; } return TCL_OK; } /* * Get the length of the string that we are matching against so we can do * the termination test for -all matches. Do this before getting the * regexp to avoid shimmering problems. */ objPtr = objv[1]; stringLength = Tcl_GetCharLength(objPtr); if (startIndex) { TclGetIntForIndex(NULL, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); if (offset < 0) { offset = 0; } } regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { return TCL_ERROR; } if (offset > 0) { /* * Add flag if using offset (string is part of a larger string), so * that "^" won't match. */ eflags |= TCL_REG_NOTBOL; } objc -= 2; objv += 2; if (doinline) { /* * Save all the subexpressions, as we will return them as a list */ numMatchesSaved = -1; } else { /* * Save only enough subexpressions for matches we want to keep, expect * in the case of -all, where we need to keep at least one to know * where to move the offset. */ numMatchesSaved = (objc == 0) ? all : objc; } /* * The following loop is to handle multiple matches within the same source * string; each iteration handles one match. If "-all" hasn't been * specified then the loop body only gets executed once. We terminate the * loop when the starting offset is past the end of the string. */ while (1) { match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset /* offset */, numMatchesSaved, eflags | ((offset > 0 && (Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n')) ? TCL_REG_NOTBOL : 0)); if (match < 0) { return TCL_ERROR; } if (match == 0) { /* * We want to set the value of the intepreter result only when * this is the first time through the loop. */ if (all <= 1) { /* * If inlining, the interpreter's object result remains an * empty list, otherwise set it to an integer object w/ value * 0. */ if (!doinline) { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } return TCL_OK; } break; } /* * If additional variable names have been specified, return index * information in those variables. */ Tcl_RegExpGetInfo(regExpr, &info); if (doinline) { /* * It's the number of substitutions, plus one for the matchVar at * index 0 */ objc = info.nsubs + 1; if (all <= 1) { resultPtr = Tcl_NewObj(); } } for (i = 0; i < objc; i++) { Tcl_Obj *newPtr; if (indices) { int start, end; Tcl_Obj *objs[2]; /* * Only adjust the match area if there was a match for that * area. (Scriptics Bug 4391/SF Bug #219232) */ if (i <= info.nsubs && info.matches[i].start >= 0) { start = offset + info.matches[i].start; end = offset + info.matches[i].end; /* * Adjust index so it refers to the last character in the * match instead of the first character after the match. */ if (end >= offset) { end--; } } else { start = -1; end = -1; } objs[0] = Tcl_NewLongObj(start); objs[1] = Tcl_NewLongObj(end); newPtr = Tcl_NewListObj(2, objs); } else { |
︙ | ︙ | |||
359 360 361 362 363 364 365 366 | } } } if (all == 0) { break; } /* | > | | | | | | | > | | | | | | | | | | | 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 | } } } if (all == 0) { break; } /* * Adjust the offset to the character just after the last one in the * matchVar and increment all to count how many times we are making a * match. We always increment the offset by at least one to prevent * endless looping (as in the case: regexp -all {a*} a). Otherwise, * when we match the NULL string at the end of the input string, we * will loop indefinately (because the length of the match is 0, so * offset never changes). */ if (info.matches[0].end == 0) { offset++; } offset += info.matches[0].end; all++; eflags |= TCL_REG_NOTBOL; if (offset >= stringLength) { break; } } /* * 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_SetObjResult(interp, resultPtr); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1)); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_RegsubObjCmd -- * * This procedure is invoked to process the "regsub" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_RegsubObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int idx, result, cflags, all, wlen, wsublen, numMatches, offset; int start, end, subStart, subEnd, match; Tcl_RegExp regExpr; Tcl_RegExpInfo info; Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; static CONST char *options[] = { "-all", "-nocase", "-expanded", "-line", "-linestop", "-lineanchor", "-start", "--", NULL }; |
︙ | ︙ | |||
444 445 446 447 448 449 450 | all = 0; offset = 0; resultPtr = NULL; for (idx = 1; idx < objc; idx++) { char *name; int index; | | | | | | < | | | < | | | < | | | < | | | < | | | < | > | | | | | | | | | > > | | | | | | | | | > > > > > > > > > > > > > > | | > < | | | | | | | | | > | | < | | 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 | all = 0; offset = 0; resultPtr = NULL; for (idx = 1; idx < objc; idx++) { char *name; int index; name = TclGetString(objv[idx]); if (name[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { goto optionError; } switch ((enum options) index) { case REGSUB_ALL: all = 1; break; case REGSUB_NOCASE: cflags |= TCL_REG_NOCASE; break; case REGSUB_EXPANDED: cflags |= TCL_REG_EXPANDED; break; case REGSUB_LINE: cflags |= TCL_REG_NEWLINE; break; case REGSUB_LINESTOP: cflags |= TCL_REG_NLSTOP; break; case REGSUB_LINEANCHOR: cflags |= TCL_REG_NLANCH; break; case REGSUB_START: { int temp; if (++idx >= objc) { goto endOfForLoop; } if (TclGetIntForIndex(interp, objv[idx], 0, &temp) != TCL_OK) { goto optionError; } if (startIndex) { Tcl_DecrRefCount(startIndex); } startIndex = objv[idx]; Tcl_IncrRefCount(startIndex); break; } case REGSUB_LAST: idx++; goto endOfForLoop; } } endOfForLoop: if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string subSpec ?varName?"); optionError: if (startIndex) { Tcl_DecrRefCount(startIndex); } return TCL_ERROR; } objc -= idx; objv += idx; if (startIndex) { int stringLength = Tcl_GetCharLength(objv[1]); TclGetIntForIndex(NULL, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); if (offset < 0) { offset = 0; } } if (all && (offset == 0) && (strpbrk(TclGetString(objv[2]), "&\\") == NULL) && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { /* * This is a simple one pair string map situation. We make use of a * slightly modified version of the one pair STR_MAP code. */ int slen, nocase; int (*strCmpFn)(CONST Tcl_UniChar*, CONST Tcl_UniChar*, unsigned long); Tcl_UniChar *p, wsrclc; numMatches = 0; nocase = (cflags & TCL_REG_NOCASE); strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); wend = wstring + wlen - (slen ? slen - 1 : 0); result = TCL_OK; if (slen == 0) { /* * regsub behavior for "" matches between each character. 'string * map' skips the "" case. */ if (wstring < wend) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); for (; wstring < wend; wstring++) { Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); numMatches++; } wlen = 0; } } else { wsrclc = Tcl_UniCharToLower(*wsrc); for (p = wfirstChar = wstring; wstring < wend; wstring++) { if ((*wstring == *wsrc || (nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) && (slen==1 || (strCmpFn(wstring, wsrc, (unsigned long) slen) == 0))) { if (numMatches == 0) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); } if (p != wstring) { Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); |
︙ | ︙ | |||
583 584 585 586 587 588 589 | regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { return TCL_ERROR; } /* | | | | | | | < | | | > | | | | | | > | | 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 | regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { return TCL_ERROR; } /* * Make sure to avoid problems where the objects are shared. This can * cause RegExpObj <> UnicodeObj shimmering that causes data corruption. * [Bug #461322] */ if (objv[1] == objv[0]) { objPtr = Tcl_DuplicateObj(objv[1]); } else { objPtr = objv[1]; } wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); if (objv[2] == objv[0]) { subPtr = Tcl_DuplicateObj(objv[2]); } else { subPtr = objv[2]; } wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); result = TCL_OK; /* * The following loop is to handle multiple matches within the same source * string; each iteration handles one match and its corresponding * substitution. If "-all" hasn't been specified then the loop body only * gets executed once. We must use 'offset <= wlen' in particular for the * case where the regexp pattern can match the empty string - this is * useful when doing, say, 'regsub -- ^ $str ...' when $str might be * empty. */ numMatches = 0; for ( ; offset <= wlen; ) { /* * The flags argument is set if string is part of a larger string, so * that "^" won't match. */ match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, 10 /* matches */, ((offset > 0 && (wstring[offset-1] != (Tcl_UniChar)'\n')) ? TCL_REG_NOTBOL : 0)); if (match < 0) { result = TCL_ERROR; goto done; } if (match == 0) { break; } if (numMatches == 0) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); if (offset > 0) { /* * Copy the initial portion of the string in if an offset was * specified. */ Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); } } numMatches++; /* * Copy the portion of the source string before the match to the * result variable. */ Tcl_RegExpGetInfo(regExpr, &info); start = info.matches[0].start; end = info.matches[0].end; Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); /* * Append the subSpec argument to the variable, making appropriate * substitutions. This code is a bit hairy because of the backslash * conventions and because the code saves up ranges of characters in * subSpec to reduce the number of calls to Tcl_SetVar. */ wsrc = wfirstChar = wsubspec; wend = wsubspec + wsublen; for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) { |
︙ | ︙ | |||
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 | continue; } else { continue; } } else { continue; } if (wfirstChar != wsrc) { Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (idx <= info.nsubs) { subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } if (*wsrc == '\\') { wsrc++; } wfirstChar = wsrc + 1; } if (wfirstChar != wsrc) { Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (end == 0) { /* | > > > > > | | | | < > > | | | > | > | | > > | > > | > > | | | | 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 | continue; } else { continue; } } else { continue; } if (wfirstChar != wsrc) { Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (idx <= info.nsubs) { subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } if (*wsrc == '\\') { wsrc++; } wfirstChar = wsrc + 1; } if (wfirstChar != wsrc) { Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (end == 0) { /* * Always consume at least one character of the input string in * order to prevent infinite loops. */ if (offset < wlen) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } else { offset += end; if (start == end) { /* * We matched an empty string, which means we must go forward * one more step so we don't match again at the same spot. */ if (offset < wlen) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } } if (!all) { break; } } /* * Copy the portion of the source string after the last match to the * result variable. */ regsubDone: if (numMatches == 0) { /* * On zero matches, just ignore the offset, since it shouldn't matter * to us in this case, and the user may have skewed it. */ resultPtr = objv[1]; Tcl_IncrRefCount(resultPtr); } else if (offset < wlen) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", TclGetString(objv[3]), "\"", (char *) NULL); result = TCL_ERROR; } else { /* * Set the interpreter's object result to an integer object * holding the number of matches. */ Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches)); } } else { /* * No varname supplied, so just return the modified string. */ Tcl_SetObjResult(interp, resultPtr); } done: if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); } if (subPtr && (objv[2] == objv[0])) { Tcl_DecrRefCount(subPtr); } if (resultPtr) { Tcl_DecrRefCount(resultPtr); } return result; } /* *---------------------------------------------------------------------- * * Tcl_RenameObjCmd -- * * This procedure is invoked to process the "rename" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_RenameObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Arbitrary value passed to the command. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *oldName, *newName; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); return TCL_ERROR; } oldName = TclGetString(objv[1]); newName = TclGetString(objv[2]); |
︙ | ︙ | |||
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 | int code, level; Tcl_Obj *returnOpts; /* * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ int explicitResult = (0 == (objc % 2)); int numOptionWords = objc - 1 - explicitResult; if (TCL_ERROR == TclMergeReturnOptions(interp, numOptionWords, objv+1, &returnOpts, &code, &level)) { return TCL_ERROR; } code = TclProcessReturn(interp, code, level, returnOpts); if (explicitResult) { Tcl_SetObjResult(interp, objv[objc-1]); } return code; } /* *---------------------------------------------------------------------- * * Tcl_SourceObjCmd -- * | > | | | 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 | int code, level; Tcl_Obj *returnOpts; /* * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ int explicitResult = (0 == (objc % 2)); int numOptionWords = objc - 1 - explicitResult; if (TCL_ERROR == TclMergeReturnOptions(interp, numOptionWords, objv+1, &returnOpts, &code, &level)) { return TCL_ERROR; } code = TclProcessReturn(interp, code, level, returnOpts); if (explicitResult) { Tcl_SetObjResult(interp, objv[objc-1]); } return code; } /* *---------------------------------------------------------------------- * * Tcl_SourceObjCmd -- * * This procedure is invoked to process the "source" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
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 | CONST char *encodingName = NULL; Tcl_Obj *fileName; if (objc != 2 && objc !=4) { Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } fileName = objv[objc-1]; if (objc == 4) { static CONST char *options[] = { "-encoding", (char *) NULL }; int index; if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], options, "option", TCL_EXACT, &index)) { return TCL_ERROR; } encodingName = TclGetString(objv[2]); } return Tcl_FSEvalFileEx(interp, fileName, encodingName); } /* *---------------------------------------------------------------------- * * Tcl_SplitObjCmd -- * | > > > > | | | 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 | CONST char *encodingName = NULL; Tcl_Obj *fileName; if (objc != 2 && objc !=4) { Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } fileName = objv[objc-1]; if (objc == 4) { static CONST char *options[] = { "-encoding", (char *) NULL }; int index; if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], options, "option", TCL_EXACT, &index)) { return TCL_ERROR; } encodingName = TclGetString(objv[2]); } return Tcl_FSEvalFileEx(interp, fileName, encodingName); } /* *---------------------------------------------------------------------- * * Tcl_SplitObjCmd -- * * This procedure is invoked to process the "split" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
952 953 954 955 956 957 958 | Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); return TCL_ERROR; } stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen); end = stringPtr + stringLen; listPtr = Tcl_NewObj(); | | | | | | > > > | > > > > | > > > | | | | | | > | | | < | | | | | 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 | Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); return TCL_ERROR; } stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen); end = stringPtr + stringLen; listPtr = Tcl_NewObj(); if (stringLen == 0) { /* * Do nothing. */ } else if (splitCharLen == 0) { Tcl_HashTable charReuseTable; Tcl_HashEntry *hPtr; int isNew; /* * Handle the special case of splitting on every character. * * Uses a hash table to ensure that each kind of character has only * one Tcl_Obj instance (multiply-referenced) in the final list. This * is a *major* win when splitting on a long string (especially in the * megabyte range!) - DKF */ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; stringPtr < end; stringPtr += len) { len = TclUtfToUniChar(stringPtr, &ch); /* * Assume Tcl_UniChar is an integral type... */ hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew); if (isNew) { objPtr = Tcl_NewStringObj(stringPtr, len); /* * Don't need to fiddle with refcount... */ Tcl_SetHashValue(hPtr, (ClientData) objPtr); } else { objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr); } Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Tcl_DeleteHashTable(&charReuseTable); } else if (splitCharLen == 1) { char *p; /* * Handle the special case of splitting on a single character. This is * only true for the one-char ASCII case, as one unicode char is > 1 * byte in length. */ while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) { objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); stringPtr = p + 1; } objPtr = Tcl_NewStringObj(stringPtr, end - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } else { char *element, *p, *splitEnd; int splitLen; Tcl_UniChar splitChar; /* * Normal case: split on any of a given set of characters. Discard * instances of the split characters. */ splitEnd = splitChars + splitCharLen; for (element = stringPtr; stringPtr < end; stringPtr += len) { len = TclUtfToUniChar(stringPtr, &ch); for (p = splitChars; p < splitEnd; p += splitLen) { splitLen = TclUtfToUniChar(p, &splitChar); if (ch == splitChar) { objPtr = Tcl_NewStringObj(element, stringPtr - element); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); element = stringPtr + len; break; } } } objPtr = Tcl_NewStringObj(element, stringPtr - element); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_StringObjCmd -- * * This procedure is invoked to process the "string" Tcl command. See the * user documentation for details on what it does. Note that this command * only functions correctly on properly formed Tcl UTF strings. * * Note that the primary methods here (equal, compare, match, ...) have * bytecode equivalents. You will find the code for those in * tclExecute.c. The code here will only be used in the non-bc case (like * in an 'eval'). * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
1083 1084 1085 1086 1087 1088 1089 | enum options { STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST, STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, STR_WORDEND, STR_WORDSTART | | | | | | | | | | | | > | | < | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | > | | | | | | | | | | | | | | | | | > | | | | | | | | | | | > | | | | | | | | < | | | > | | | | | | | | | | | | | | | | | | | | | | | > | | > | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | < | > | | | | | | | | | | | | < | > | | | | | | | | | | | < | | | | | | > | | | | > | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | < | | | | | | | | | | > | | | | | | | | | | | | > | | | | | | | | | | | | | | > | | | | | | | | | | > | | | | < < < < < < < < | | | | | | | | | | | > | | < < < < < < < < < < < < < < < | < < < > | < < < < | | < < < | < < < < < < < < | < < < | | | < < < < < | | | | | | | | | | | | | | | | | < | | | | | | | | < | | | < | > | | | | | > | | | | < | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | < | | | > | | | | | | | | | | < | > | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | < | | | | < | | | | | | | | | | | | | | | | < | | | | | > | | | | | | | < | > | | | | | > | | | > | | > | | | | > | | | | | | | | | | | | | | | > | | | | | | > | | | | | | | | < | > | | | | | | | | | | | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | > | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | > | | < > | < | < > > | | > | | | > | | | | | | > | | | | | > | | | | | | | | | | | | | < | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | > | | | | > | | | | | | | > | | | | | | > | | | | | | | > | | | | | | | > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < < < < | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | < | | | < | | | < | | < > | 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 | enum options { STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST, STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, STR_WORDEND, STR_WORDSTART }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { case STR_EQUAL: case STR_COMPARE: { /* * Remember to keep code here in some sync with the byte-compiled * versions in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and * INST_STR_CMP as well as the expr string comparison in * INST_EQ/INST_NEQ/INST_LT/...). */ int i, match, length, nocase = 0, reqlength = -1; typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); strCmpFn_t strCmpFn; if (objc < 4 || objc > 7) { str_cmp_args: Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? ?-length int? string1 string2"); return TCL_ERROR; } for (i = 2; i < objc-2; i++) { string2 = Tcl_GetStringFromObj(objv[i], &length2); if ((length2 > 1) && strncmp(string2, "-nocase", (size_t)length2) == 0) { nocase = 1; } else if ((length2 > 1) && strncmp(string2, "-length", (size_t)length2) == 0) { if (i+1 >= objc-2) { goto str_cmp_args; } if (Tcl_GetIntFromObj(interp, objv[++i], &reqlength) != TCL_OK) { return TCL_ERROR; } } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -nocase or -length", (char *) NULL); return TCL_ERROR; } } /* * From now on, we only access the two objects at the end of the * argument array. */ objv += objc-2; if ((reqlength == 0) || (objv[0] == objv[1])) { /* * Always match at 0 chars of if it is the same obj. */ Tcl_SetObjResult(interp, Tcl_NewBooleanObj((enum options) index == STR_EQUAL)); break; } else if (!nocase && objv[0]->typePtr == &tclByteArrayType && objv[1]->typePtr == &tclByteArrayType) { /* * Use binary versions of comparisons since that won't cause undue * type conversions and it is much faster. Only do this if we're * case-sensitive (which is all that really makes sense with byte * arrays anyway, and we have no memcasecmp() for some * reason... :^) */ string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1); string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2); strCmpFn = (strCmpFn_t) memcmp; } else if ((objv[0]->typePtr == &tclStringType) && (objv[1]->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. */ string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1); string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2); strCmpFn = (strCmpFn_t) (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); } else { /* * As a catch-all we will work with UTF-8. We cannot use memcmp() * as that is unsafe with any string containing NULL (\xC0\x80 in * Tcl's utf rep). We can use the more efficient TclpUtfNcmp2 if * we are case-sensitive and no specific length was requested. */ string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1); string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2); if ((reqlength < 0) && !nocase) { strCmpFn = (strCmpFn_t) TclpUtfNcmp2; } else { length1 = Tcl_NumUtfChars(string1, length1); length2 = Tcl_NumUtfChars(string2, length2); strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); } } if (((enum options) index == STR_EQUAL) && (reqlength < 0) && (length1 != length2)) { match = 1; /* this will be reversed below */ } else { length = (length1 < length2) ? length1 : length2; if (reqlength > 0 && reqlength < length) { length = reqlength; } else if (reqlength < 0) { /* * The requested length is negative, so we ignore it by * setting it to length + 1 so we correct the match var. */ reqlength = length + 1; } match = strCmpFn(string1, string2, (unsigned) length); if ((match == 0) && (reqlength > length)) { match = length1 - length2; } } if ((enum options) index == STR_EQUAL) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj( (match > 0) ? 1 : (match < 0) ? -1 : 0)); } break; } case STR_FIRST: { Tcl_UniChar *ustring1, *ustring2; int match, start; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "subString string ?startIndex?"); return TCL_ERROR; } /* * We are searching string2 for the sequence string1. */ match = -1; start = 0; length2 = -1; ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); if (objc == 5) { /* * If a startIndex is specified, we will need to fast forward to * that point in the string before we think about a match. */ if (TclGetIntForIndex(interp, objv[4], length2 - 1, &start) != TCL_OK) { return TCL_ERROR; } if (start >= length2) { goto str_first_done; } else if (start > 0) { ustring2 += start; length2 -= start; } else if (start < 0) { /* * Invalid start index mapped to string start; Bug #423581 */ start = 0; } } if (length1 > 0) { register Tcl_UniChar *p, *end; end = ustring2 + length2 - length1 + 1; for (p = ustring2; p < end; p++) { /* * Scan forward to find the first character. */ if ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p, (unsigned long) length1) == 0)) { match = p - ustring2; break; } } } /* * Compute the character index of the matching string by counting the * number of characters before the match. */ if ((match != -1) && (objc == 5)) { match += start; } str_first_done: Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); break; } case STR_INDEX: { if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); return TCL_ERROR; } /* * 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 (objv[2]->typePtr == &tclByteArrayType) { string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1); if (TclGetIntForIndex(interp, objv[3], length1 - 1, &index) != TCL_OK) { return TCL_ERROR; } if ((index >= 0) && (index < length1)) { Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( (unsigned char *)(&string1[index]), 1)); } } else { /* * Get Unicode char length to calulate what 'end' means. */ length1 = Tcl_GetCharLength(objv[2]); if (TclGetIntForIndex(interp, objv[3], length1 - 1, &index) != TCL_OK) { return TCL_ERROR; } if ((index >= 0) && (index < length1)) { char buf[TCL_UTF_MAX]; Tcl_UniChar ch; ch = Tcl_GetUniChar(objv[2], index); length1 = Tcl_UniCharToUtf(ch, buf); Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length1)); } } break; } case STR_IS: { char *end; Tcl_UniChar ch; /* * The UniChar comparison function */ int (*chcomp)(int) = NULL; int i, failat = 0, result = 1, strict = 0; Tcl_Obj *objPtr, *failVarObj = NULL; Tcl_WideInt w; static CONST char *isOptions[] = { "alnum", "alpha", "ascii", "control", "boolean", "digit", "double", "false", "graph", "integer", "lower", "print", "punct", "space", "true", "upper", "wideinteger", "wordchar", "xdigit", (char *) NULL }; enum isOptions { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT }; if (objc < 4 || objc > 7) { Tcl_WrongNumArgs(interp, 2, objv, "class ?-strict? ?-failindex var? str"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0, &index) != TCL_OK) { return TCL_ERROR; } if (objc != 4) { for (i = 3; i < objc-1; i++) { string2 = Tcl_GetStringFromObj(objv[i], &length2); if ((length2 > 1) && strncmp(string2, "-strict", (size_t) length2) == 0) { strict = 1; } else if ((length2 > 1) && strncmp(string2, "-failindex", (size_t) length2) == 0){ if (i+1 >= objc-1) { Tcl_WrongNumArgs(interp, 3, objv, "?-strict? ?-failindex var? str"); return TCL_ERROR; } failVarObj = objv[++i]; } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -strict or -failindex", (char *)NULL); return TCL_ERROR; } } } /* * We get the objPtr so that we can short-cut for some classes by * checking the object type (int and double), but we need the string * otherwise, because we don't want any conversion of type occuring * (as, for example, Tcl_Get*FromObj would do */ objPtr = objv[objc-1]; string1 = Tcl_GetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { result = 0; } goto str_is_done; } end = string1 + length1; /* * When entering here, result == 1 and failat == 0 */ switch ((enum isOptions) index) { case STR_IS_ALNUM: chcomp = Tcl_UniCharIsAlnum; break; case STR_IS_ALPHA: chcomp = Tcl_UniCharIsAlpha; break; case STR_IS_ASCII: for (; string1 < end; string1++, failat++) { /* * This is a valid check in unicode, because all bytes less * than 0xC0 are single byte chars (but isascii limits that * def'n to 0x80). */ if (*((unsigned char *)string1) >= 0x80) { result = 0; break; } } break; case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) { result = 0; } else if ((((enum isOptions) index == STR_IS_TRUE) && objPtr->internalRep.longValue == 0) || (((enum isOptions) index == STR_IS_FALSE) && objPtr->internalRep.longValue != 0)) { result = 0; } break; case STR_IS_CONTROL: chcomp = Tcl_UniCharIsControl; break; case STR_IS_DIGIT: chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { char *stop; /* TODO */ if ((objPtr->typePtr == &tclDoubleType) || (objPtr->typePtr == &tclIntType) || #ifndef NO_WIDE_TYPE (objPtr->typePtr == &tclWideIntType) || #endif (objPtr->typePtr == &tclBignumType)) { break; } if (TclParseNumber( NULL, objPtr, NULL, NULL, -1, (CONST char**) &stop, 0 ) != TCL_OK) { result = 0; failat = 0; } else { failat = stop - string1; string1 = stop; chcomp = Tcl_UniCharIsSpace; } break; } case STR_IS_GRAPH: chcomp = Tcl_UniCharIsGraph; break; case STR_IS_INT: { char *stop; long int l = 0; if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) { break; } /* * Like STR_IS_DOUBLE, but we use strtoul. Since Tcl_GetIntFromObj * already failed, we set result to 0. */ result = 0; errno = 0; l = strtol(string1, &stop, 0); /* INTL: Tcl source. */ if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) { /* * if (errno == ERANGE) or the long value won't fit in an int, * then it was an over/underflow problem, but in this method, * we only want to know yes or no, so bad flow returns 0 * (false) and sets the failVarObj to the string length. */ failat = -1; } else if (stop == string1) { /* * In this case, nothing like a number was found */ failat = 0; } else { /* * Assume we sucked up one char per byte and then we go onto * SPACE, since we are allowed trailing whitespace. */ failat = stop - string1; string1 = stop; chcomp = Tcl_UniCharIsSpace; } break; } case STR_IS_LOWER: chcomp = Tcl_UniCharIsLower; break; case STR_IS_PRINT: chcomp = Tcl_UniCharIsPrint; break; case STR_IS_PUNCT: chcomp = Tcl_UniCharIsPunct; break; case STR_IS_SPACE: chcomp = Tcl_UniCharIsSpace; break; case STR_IS_UPPER: chcomp = Tcl_UniCharIsUpper; break; case STR_IS_WIDE: { char *stop; if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { break; } /* * Like STR_IS_DOUBLE, but we use strtoll. Since * Tcl_GetWideIntFromObj already failed, we set result to 0. */ result = 0; errno = 0; w = strtoll(string1, &stop, 0); /* INTL: Tcl source. */ if (errno == ERANGE) { /* * if (errno == ERANGE), then it was an over/underflow * problem, but in this method, we only want to know yes or * no, so bad flow returns 0 (false) and sets the failVarObj * to the string length. */ failat = -1; } else if (stop == string1) { /* * In this case, nothing like a number was found */ failat = 0; } else { /* * Assume we sucked up one char per byte and then we go onto * SPACE, since we are allowed trailing whitespace. */ failat = stop - string1; string1 = stop; chcomp = Tcl_UniCharIsSpace; } break; } case STR_IS_WORD: chcomp = Tcl_UniCharIsWordChar; break; case STR_IS_XDIGIT: for (; string1 < end; string1++, failat++) { /* INTL: We assume unicode is bad for this class */ if ((*((unsigned char *)string1) >= 0xC0) || !isxdigit(*(unsigned char *)string1)) { result = 0; break; } } break; } if (chcomp != NULL) { for (; string1 < end; string1 += length2, failat++) { length2 = TclUtfToUniChar(string1, &ch); if (!chcomp(ch)) { result = 0; break; } } } /* * Only set the failVarObj when we will return 0 and we have indicated * a valid fail index (>= 0). */ str_is_done: if ((result == 0) && (failVarObj != NULL) && Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); break; } case STR_LAST: { Tcl_UniChar *ustring1, *ustring2, *p; int match, start; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "subString string ?startIndex?"); return TCL_ERROR; } /* * We are searching string2 for the sequence string1. */ match = -1; start = 0; length2 = -1; ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); if (objc == 5) { /* * If a startIndex is specified, we will need to restrict the * string range to that char index in the string */ if (TclGetIntForIndex(interp, objv[4], length2 - 1, &start) != TCL_OK) { return TCL_ERROR; } if (start < 0) { goto str_last_done; } else if (start < length2) { p = ustring2 + start + 1 - length1; } else { p = ustring2 + length2 - length1; } } else { p = ustring2 + length2 - length1; } if (length1 > 0) { for (; p >= ustring2; p--) { /* * Scan backwards to find the first character. */ if ((*p == *ustring1) && (memcmp((char *) ustring1, (char *) p, (size_t) (length1 * sizeof(Tcl_UniChar))) == 0)) { match = p - ustring2; break; } } } str_last_done: Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); break; } case STR_BYTELENGTH: case STR_LENGTH: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } if ((enum options) index == STR_BYTELENGTH) { (void) Tcl_GetStringFromObj(objv[2], &length1); } else { /* * If we have a ByteArray object, avoid recomputing the string * since the byte array contains one byte per character. * Otherwise, use the Unicode string rep to calculate the length. */ if (objv[2]->typePtr == &tclByteArrayType) { (void) Tcl_GetByteArrayFromObj(objv[2], &length1); } else { length1 = Tcl_GetCharLength(objv[2]); } } Tcl_SetObjResult(interp, Tcl_NewIntObj(length1)); break; case STR_MAP: { int mapElemc, nocase = 0, mapWithDict = 0, copySource = 0; Tcl_Obj **mapElemv, *sourceObj, *resultPtr; Tcl_UniChar *ustring1, *ustring2, *p, *end; int (*strCmpFn)(CONST Tcl_UniChar*, CONST Tcl_UniChar*, unsigned long); if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string"); return TCL_ERROR; } if (objc == 5) { string2 = Tcl_GetStringFromObj(objv[2], &length2); if ((length2 > 1) && strncmp(string2, "-nocase", (size_t) length2) == 0) { nocase = 1; } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -nocase", (char *) NULL); return TCL_ERROR; } } /* * This test is tricky, but has to be that way or you get other * strange inconsistencies (see test string-10.20 for illustration * why!) */ if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL) { int i, done; Tcl_DictSearch search; /* * We know the type exactly, so all dict operations will succeed * for sure. This shortens this code quite a bit. */ Tcl_DictObjSize(interp, objv[objc-2], &mapElemc); if (mapElemc == 0) { /* * empty charMap, just return whatever string was given */ Tcl_SetObjResult(interp, objv[objc-1]); return TCL_OK; } mapElemc *= 2; mapWithDict = 1; /* * Copy the dictionary out into an array; that's the easiest way * to adapt this code... */ mapElemv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * mapElemc); Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, mapElemv+1, &done); for (i=2 ; i<mapElemc ; i+=2) { Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done); } } else { if (Tcl_ListObjGetElements(interp, objv[objc-2], &mapElemc, &mapElemv) != TCL_OK) { return TCL_ERROR; } if (mapElemc == 0) { /* * empty charMap, just return whatever string was given. */ Tcl_SetObjResult(interp, objv[objc-1]); return TCL_OK; } else if (mapElemc & 1) { /* * The charMap must be an even number of key/value items. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "char map list unbalanced", -1)); return TCL_ERROR; } } /* * Take a copy of the source string object if it is the same as the * map string to cut out nasty sharing crashes. [Bug 1018562] */ if (objv[objc-2] == objv[objc-1]) { sourceObj = Tcl_DuplicateObj(objv[objc-1]); copySource = 1; } else { sourceObj = objv[objc-1]; } ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); if (length1 == 0) { /* * Empty input string, just stop now. */ if (mapWithDict) { ckfree((char *) mapElemv); } if (copySource) { Tcl_DecrRefCount(sourceObj); } break; } end = ustring1 + length1; strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); /* * Force result to be Unicode */ resultPtr = Tcl_NewUnicodeObj(ustring1, 0); if (mapElemc == 2) { /* * Special case for one map pair which avoids the extra for loop * and extra calls to get Unicode data. The algorithm is otherwise * identical to the multi-pair case. This will be >30% faster on * larger strings. */ int mapLen; Tcl_UniChar *mapString, u2lc; ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); p = ustring1; if ((length2 > length1) || (length2 == 0)) { /* * Match string is either longer than input or empty. */ ustring1 = end; } else { mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); for (; ustring1 < end; ustring1++) { if (((*ustring1 == *ustring2) || (nocase && Tcl_UniCharToLower(*ustring1)==u2lc)) && (length2==1 || strCmpFn(ustring1, ustring2, (unsigned long) length2) == 0)) { if (p != ustring1) { Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); } } } } else { Tcl_UniChar **mapStrings, *u2lc = NULL; int *mapLens; /* * Precompute pointers to the unicode string and length. This * saves us repeated function calls later, significantly speeding * up the algorithm. We only need the lowercase first char in the * nocase case. */ mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2) * sizeof(Tcl_UniChar *)); mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int)); if (nocase) { u2lc = (Tcl_UniChar *) ckalloc((mapElemc) * sizeof(Tcl_UniChar)); } for (index = 0; index < mapElemc; index++) { mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], &(mapLens[index])); if (nocase && ((index % 2) == 0)) { u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); } } for (p = ustring1; ustring1 < end; ustring1++) { for (index = 0; index < mapElemc; index += 2) { /* * Get the key string to match on. */ ustring2 = mapStrings[index]; length2 = mapLens[index]; if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase && (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && /* restrict max compare length */ ((end - ustring1) >= length2) && ((length2 == 1) || strCmpFn(ustring2, ustring1, (unsigned long) length2) == 0)) { if (p != ustring1) { /* * Put the skipped chars onto the result first. */ Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); p = ustring1 + length2; } else { p += length2; } /* * Adjust len to be full length of matched string. */ ustring1 = p - 1; /* * Append the map value to the unicode string. */ Tcl_AppendUnicodeToObj(resultPtr, mapStrings[index+1], mapLens[index+1]); break; } } } ckfree((char *) mapStrings); ckfree((char *) mapLens); if (nocase) { ckfree((char *) u2lc); } } if (p != ustring1) { /* * Put the rest of the unmapped chars onto result. */ Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); } if (mapWithDict) { ckfree((char *) mapElemv); } if (copySource) { Tcl_DecrRefCount(sourceObj); } Tcl_SetObjResult(interp, resultPtr); break; } case STR_MATCH: { Tcl_UniChar *ustring1, *ustring2; int nocase = 0; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string"); return TCL_ERROR; } if (objc == 5) { string2 = Tcl_GetStringFromObj(objv[2], &length2); if ((length2 > 1) && strncmp(string2, "-nocase", (size_t) length2) == 0) { nocase = 1; } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -nocase", (char *) NULL); return TCL_ERROR; } } ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1); ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(TclUniCharMatch( ustring1, length1, ustring2, length2, nocase))); break; } case STR_RANGE: { int first, last; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "string first last"); return TCL_ERROR; } /* * 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 range. */ if (objv[2]->typePtr == &tclByteArrayType) { string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); length1--; } else { /* * Get the length in actual characters. */ string1 = NULL; length1 = Tcl_GetCharLength(objv[2]) - 1; } if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK || TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK) { return TCL_ERROR; } if (first < 0) { first = 0; } if (last >= length1) { last = length1; } if (last >= first) { if (string1 != NULL) { int numBytes = last - first + 1; Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( (unsigned char *) &string1[first], numBytes)); } else { Tcl_SetObjResult(interp, Tcl_GetRange(objv[2], first, last)); } } break; } case STR_REPEAT: { int count; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string count"); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) { return TCL_ERROR; } if (count == 1) { Tcl_SetObjResult(interp, objv[2]); } else if (count > 1) { string1 = Tcl_GetStringFromObj(objv[2], &length1); if (length1 > 0) { /* * Only build up a string that has data. Instead of building * it up with repeated appends, we just allocate the necessary * space once and copy the string value in. Check for overflow * with back-division. [Bug #714106] */ Tcl_Obj *resultPtr; length2 = length1 * count; if ((length2 / count) != length1) { resultPtr = Tcl_NewObj(); TclObjPrintf(NULL, resultPtr, "string size overflow, must be less than %d", INT_MAX); Tcl_SetObjResult(interp, resultPtr); return TCL_ERROR; } /* * Include space for the NULL. */ string2 = (char *) ckalloc((size_t) length2+1); for (index = 0; index < count; index++) { memcpy(string2 + (length1 * index), string1, (size_t) length1); } string2[length2] = '\0'; /* * We have to directly assign this instead of using * Tcl_SetStringObj (and indirectly TclInitStringRep) because * that makes another copy of the data. */ TclNewObj(resultPtr); resultPtr->bytes = string2; resultPtr->length = length2; Tcl_SetObjResult(interp, resultPtr); } } break; } case STR_REPLACE: { Tcl_UniChar *ustring1; int first, last; if (objc < 5 || objc > 6) { Tcl_WrongNumArgs(interp, 2, objv, "string first last ?string?"); return TCL_ERROR; } ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); length1--; if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK || TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK) { return TCL_ERROR; } if ((last < first) || (last < 0) || (first > length1)) { Tcl_SetObjResult(interp, objv[2]); } else { Tcl_Obj *resultPtr; if (first < 0) { first = 0; } resultPtr = Tcl_NewUnicodeObj(ustring1, first); if (objc == 6) { Tcl_AppendObjToObj(resultPtr, objv[5]); } if (last < length1) { Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1, length1 - last); } Tcl_SetObjResult(interp, resultPtr); } break; } case STR_TOLOWER: case STR_TOUPPER: case STR_TOTITLE: if (objc < 3 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?"); return TCL_ERROR; } string1 = Tcl_GetStringFromObj(objv[2], &length1); if (objc == 3) { Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); if ((enum options) index == STR_TOLOWER) { length1 = Tcl_UtfToLower(TclGetString(resultPtr)); } else if ((enum options) index == STR_TOUPPER) { length1 = Tcl_UtfToUpper(TclGetString(resultPtr)); } else { length1 = Tcl_UtfToTitle(TclGetString(resultPtr)); } Tcl_SetObjLength(resultPtr, length1); Tcl_SetObjResult(interp, resultPtr); } else { int first, last; CONST char *start, *end; Tcl_Obj *resultPtr; length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK){ return TCL_ERROR; } if (first < 0) { first = 0; } last = first; if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK)) { return TCL_ERROR; } if (last >= length1) { last = length1; } if (last < first) { Tcl_SetObjResult(interp, objv[2]); break; } start = Tcl_UtfAtIndex(string1, first); end = Tcl_UtfAtIndex(start, last - first + 1); length2 = end-start; string2 = ckalloc((size_t) length2+1); memcpy(string2, start, (size_t) length2); string2[length2] = '\0'; if ((enum options) index == STR_TOLOWER) { length2 = Tcl_UtfToLower(string2); } else if ((enum options) index == STR_TOUPPER) { length2 = Tcl_UtfToUpper(string2); } else { length2 = Tcl_UtfToTitle(string2); } resultPtr = Tcl_NewStringObj(string1, start - string1); Tcl_AppendToObj(resultPtr, string2, length2); Tcl_AppendToObj(resultPtr, end, -1); Tcl_SetObjResult(interp, resultPtr); ckfree(string2); } break; case STR_TRIMLEFT: left = 1; right = 0; goto dotrim; case STR_TRIMRIGHT: left = 0; right = 1; goto dotrim; case STR_TRIM: { Tcl_UniChar ch, trim; register CONST char *p, *end; char *check, *checkEnd; int offset; left = 1; right = 1; dotrim: if (objc == 4) { string2 = Tcl_GetStringFromObj(objv[3], &length2); } else if (objc == 3) { string2 = " \t\n\r"; length2 = strlen(string2); } else { Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?"); return TCL_ERROR; } string1 = Tcl_GetStringFromObj(objv[2], &length1); checkEnd = string2 + length2; if (left) { end = string1 + length1; /* * The outer loop iterates over the string. The inner loop * iterates over the trim characters. The loops terminate as soon * as a non-trim character is discovered and string1 is left * pointing at the first non-trim character. */ for (p = string1; p < end; p += offset) { offset = TclUtfToUniChar(p, &ch); for (check = string2; ; ) { if (check >= checkEnd) { p = end; break; } check += TclUtfToUniChar(check, &trim); if (ch == trim) { length1 -= offset; string1 += offset; break; } } } } if (right) { end = string1; /* * The outer loop iterates over the string. The inner loop * iterates over the trim characters. The loops terminate as soon * as a non-trim character is discovered and length1 marks the * last non-trim character. */ for (p = string1 + length1; p > end; ) { p = Tcl_UtfPrev(p, string1); offset = TclUtfToUniChar(p, &ch); for (check = string2; ; ) { if (check >= checkEnd) { p = end; break; } check += TclUtfToUniChar(check, &trim); if (ch == trim) { length1 -= offset; break; } } } } Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); break; } case STR_WORDEND: { int cur; Tcl_UniChar ch; CONST char *p, *end; int numChars; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string index"); return TCL_ERROR; } string1 = Tcl_GetStringFromObj(objv[2], &length1); numChars = Tcl_NumUtfChars(string1, length1); if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) { return TCL_ERROR; } if (index < 0) { index = 0; } if (index < numChars) { p = Tcl_UtfAtIndex(string1, index); end = string1+length1; for (cur = index; p < end; cur++) { p += TclUtfToUniChar(p, &ch); if (!Tcl_UniCharIsWordChar(ch)) { break; } } if (cur == index) { cur++; } } else { cur = numChars; } Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); break; } case STR_WORDSTART: { int cur; Tcl_UniChar ch; CONST char *p; int numChars; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string index"); return TCL_ERROR; } string1 = Tcl_GetStringFromObj(objv[2], &length1); numChars = Tcl_NumUtfChars(string1, length1); if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) { return TCL_ERROR; } if (index >= numChars) { index = numChars - 1; } cur = 0; if (index > 0) { p = Tcl_UtfAtIndex(string1, index); for (cur = index; cur >= 0; cur--) { TclUtfToUniChar(p, &ch); if (!Tcl_UniCharIsWordChar(ch)) { break; } p = Tcl_UtfPrev(p, string1); } if (cur != index) { cur += 1; } } Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); break; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SubstObjCmd -- * * This procedure is invoked to process the "subst" Tcl command. See the * user documentation for details on what it does. This command relies on * Tcl_SubstObj() for its implementation. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SubstObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *substOptions[] = { "-nobackslashes", "-nocommands", "-novariables", (char *) NULL }; enum substOptions { SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS }; Tcl_Obj *resultPtr; int optionIndex, flags, i; /* * Parse command-line options. */ flags = TCL_SUBST_ALL; for (i = 1; i < (objc-1); i++) { if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch (optionIndex) { case SUBST_NOBACKSLASHES: flags &= ~TCL_SUBST_BACKSLASHES; break; case SUBST_NOCOMMANDS: flags &= ~TCL_SUBST_COMMANDS; break; case SUBST_NOVARS: flags &= ~TCL_SUBST_VARIABLES; break; default: Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); } } if (i != (objc-1)) { Tcl_WrongNumArgs(interp, 1, objv, "?-nobackslashes? ?-nocommands? ?-novariables? string"); return TCL_ERROR; } /* * Perform the substitution. */ resultPtr = Tcl_SubstObj(interp, objv[i], flags); if (resultPtr == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; |
︙ | ︙ | |||
2497 2498 2499 2500 2501 2502 2503 | int Tcl_SwitchObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { | | > > > > > > > | | | > > > > > | | | | 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 | int Tcl_SwitchObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved, noCase; int patternLength; char *pattern; Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; Tcl_Obj *CONST *savedObjv = objv; Tcl_RegExp regExpr = NULL; /* * If you add options that make -e and -g not unique prefixes of -exact or * -glob, you *must* fix TclCompileSwitchCmd's option parser as well. */ static CONST char *options[] = { "-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp", "--", NULL }; enum options { OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, OPT_LAST }; typedef int (*strCmpFn_t)(const char *, const char *); strCmpFn_t strCmpFn = strcmp; mode = OPT_EXACT; foundmode = 0; indexVarObj = NULL; matchVarObj = NULL; numMatchesSaved = 0; noCase = 0; for (i = 1; i < objc; i++) { if (TclGetString(objv[i])[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_LAST) { i++; break; } /* * Check for TIP#75 options specifying the variables to write regexp * information into. */ if (index == OPT_INDEXV) { i++; if (i == objc) { Tcl_AppendResult(interp, "missing variable name argument to -indexvar option", |
︙ | ︙ | |||
2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 | Tcl_AppendResult(interp, "missing variable name argument to -matchvar option", (char *) NULL); return TCL_ERROR; } matchVarObj = objv[i]; numMatchesSaved = -1; } else { mode = index; } } if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? string pattern body ... ?default body?"); | > > > > > > > > > > > > > > | 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 | Tcl_AppendResult(interp, "missing variable name argument to -matchvar option", (char *) NULL); return TCL_ERROR; } matchVarObj = objv[i]; numMatchesSaved = -1; } else if (index == OPT_NOCASE) { strCmpFn = strcasecmp; noCase = 1; } else { if (foundmode) { /* * Mode already set via -exact, -glob, or -regexp. */ Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), "\": ", options[mode], " option already found", (char *) NULL); return TCL_ERROR; } foundmode = 1; mode = index; } } if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? string pattern body ... ?default body?"); |
︙ | ︙ | |||
2578 2579 2580 2581 2582 2583 2584 | } stringObj = objv[i]; objc -= i + 1; objv += i + 1; /* | | | | 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 | } stringObj = objv[i]; objc -= i + 1; objv += i + 1; /* * If all of the pattern/command pairs are lumped into a single argument, * split them out again. */ splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { |
︙ | ︙ | |||
2604 2605 2606 2607 2608 2609 2610 | return TCL_ERROR; } objv = listv; splitObjs = 1; } /* | | | | | | | < | | | | | | | | < > | 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 | return TCL_ERROR; } objv = listv; splitObjs = 1; } /* * Complain if there is an odd number of words in the list of patterns and * bodies. */ if (objc % 2) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); /* * Check if this can be due to a badly placed comment in the switch * block. * * The following is an heuristic to detect the infamous "comment in * switch" error: just check if a pattern begins with '#'. */ if (splitObjs) { for (i=0 ; i<objc ; i+=2) { if (TclGetString(objv[i])[0] == '#') { Tcl_AppendResult(interp, ", this may be due to a ", "comment incorrectly placed outside of a ", "switch body - see the \"switch\" ", "documentation", NULL); break; } } } return TCL_ERROR; } /* * Complain if the last body is a continuation. Note that this check * assumes that the list is non-empty! */ if (strcmp(TclGetString(objv[objc-1]), "-") == 0) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "no body specified for pattern \"", TclGetString(objv[objc-2]), "\"", NULL); return TCL_ERROR; } for (i = 0; i < objc; i += 2) { /* * See if the pattern matches the string. */ pattern = Tcl_GetStringFromObj(objv[i], &patternLength); if ((i == objc - 2) && (*pattern == 'd') && (strcmp(pattern, "default") == 0)) { Tcl_Obj *emptyObj = NULL; /* * If either indexVarObj or matchVarObj are non-NULL, we're in * REGEXP mode but have reached the default clause anyway. TIP#75 * specifies that we set the variables to empty lists (== empty * objects) in that case. */ if (indexVarObj != NULL) { TclNewObj(emptyObj); if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, emptyObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(emptyObj); return TCL_ERROR; } |
︙ | ︙ | |||
2690 2691 2692 2693 2694 2695 2696 | return TCL_ERROR; } } goto matchFound; } else { switch (mode) { case OPT_EXACT: | | | > | | | | < > > > > | | | < | | > > | | | > < | | > | | > > < | | | | < < | < < < | > < | | | | | > > > > > > > | > > > > > > > > > > | > | | | | | | | | | | | | | | | | | | | | | | | < < | | < | | | | | > > > > > > > > | 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 | return TCL_ERROR; } } goto matchFound; } else { switch (mode) { case OPT_EXACT: if (strCmpFn(TclGetString(stringObj), pattern) == 0) { goto matchFound; } break; case OPT_GLOB: if (Tcl_StringCaseMatch(TclGetString(stringObj), pattern, noCase)) { goto matchFound; } break; case OPT_REGEXP: regExpr = Tcl_GetRegExpFromObj(interp, objv[i], TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); if (regExpr == NULL) { return TCL_ERROR; } else { int matched = Tcl_RegExpExecObj(interp, regExpr, stringObj, 0, numMatchesSaved, 0); if (matched < 0) { return TCL_ERROR; } else if (matched) { goto matchFoundRegexp; } } break; } } } return TCL_OK; matchFoundRegexp: /* * We are operating in REGEXP mode and we need to store information about * what we matched in some user-nominated arrays. So build the lists of * values and indices to write here. [TIP#75] */ if (numMatchesSaved) { Tcl_RegExpInfo info; Tcl_Obj *matchesObj, *indicesObj = NULL; Tcl_RegExpGetInfo(regExpr, &info); if (matchVarObj != NULL) { TclNewObj(matchesObj); } else { matchesObj = NULL; } if (indexVarObj != NULL) { TclNewObj(indicesObj); } for (j=0 ; j<=info.nsubs ; j++) { if (indexVarObj != NULL) { Tcl_Obj *rangeObjAry[2]; rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end); /* * Never fails; the object is always clean at this point. */ Tcl_ListObjAppendElement(NULL, indicesObj, Tcl_NewListObj(2, rangeObjAry)); } if (matchVarObj != NULL) { Tcl_Obj *substringObj; substringObj = Tcl_GetRange(stringObj, info.matches[j].start, info.matches[j].end-1); /* * Never fails; the object is always clean at this point. */ Tcl_ListObjAppendElement(NULL, matchesObj, substringObj); } } if (indexVarObj != NULL) { if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, indicesObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(indicesObj); /* * Careful! Check to see if we have allocated the list of * matched strings; if so (but there was an error assigning * the indices list) we have a potential memory leak because * the match list has not been written to a variable. Except * that we'll clean that up right now. */ if (matchesObj != NULL) { Tcl_DecrRefCount(matchesObj); } return TCL_ERROR; } } if (matchVarObj != NULL) { if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, matchesObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(matchesObj); /* * Unlike above, if indicesObj is non-NULL at this point, it * will have been written to a variable already and will hence * not be leaked. */ return TCL_ERROR; } } } /* * We've got a match. Find a body to execute, skipping bodies that are * "-". */ matchFound: for (j = i + 1; ; j += 2) { if (j >= objc) { /* * This shouldn't happen since we've checked that the last body is * not a continuation... */ Tcl_Panic("fall-out when searching for body to match pattern"); } if (strcmp(TclGetString(objv[j]), "-") != 0) { break; } } result = Tcl_EvalObjEx(interp, objv[j], 0); /* * Generate an error message if necessary. */ if (result == TCL_ERROR) { int limit = 50; int overflow = (patternLength > limit); TclFormatToErrorInfo(interp, "\n (\"%.*s%s\" arm line %d)", (overflow ? limit : patternLength), pattern, (overflow ? "..." : ""), interp->errorLine); } return result; } /* *---------------------------------------------------------------------- * * Tcl_TimeObjCmd -- * * This object-based procedure is invoked to process the "time" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_TimeObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Tcl_Obj *objPtr; Tcl_Obj *objs[4]; register int i, result; int count; double totalMicroSec; Tcl_Time start, stop; if (objc == 2) { count = 1; } else if (objc == 3) { result = Tcl_GetIntFromObj(interp, objv[2], &count); if (result != TCL_OK) { return result; } } else { Tcl_WrongNumArgs(interp, 1, objv, "command ?count?"); return TCL_ERROR; } objPtr = objv[1]; i = count; Tcl_GetTime(&start); while (i-- > 0) { result = Tcl_EvalObjEx(interp, objPtr, 0); if (result != TCL_OK) { return result; } } Tcl_GetTime(&stop); totalMicroSec = (((double) (stop.sec - start.sec))*1.0e6 + (stop.usec - start.usec)); if (count <= 1) { /* * Use int obj since we know time is not fractional. [Bug 1202178] */ objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec); } else { objs[0] = Tcl_NewDoubleObj(totalMicroSec/count); } /* * Construct the result as a list because many programs have always parsed * at such (extracting the first element, typically). */ objs[1] = Tcl_NewStringObj("microseconds", -1); objs[2] = Tcl_NewStringObj("per", -1); objs[3] = Tcl_NewStringObj("iteration", -1); Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs)); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_WhileObjCmd -- * * This procedure is invoked to process the "while" Tcl command. See the * user documentation for details on what it does. * * With the bytecode compiler, this procedure is only called when a * command name is computed at runtime, and is "while" or the name to * which "while" was renamed: e.g., "set z while; $z {$i<100} {}" * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_WhileObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "test command"); return TCL_ERROR; } while (1) { result = Tcl_ExprBooleanObj(interp, objv[1], &value); if (result != TCL_OK) { return result; } if (!value) { break; } result = Tcl_EvalObjEx(interp, objv[2], 0); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { TclFormatToErrorInfo(interp, "\n (\"while\" body line %d)", interp->errorLine); } break; } } if (result == TCL_BREAK) { result = TCL_OK; } if (result == TCL_OK) { Tcl_ResetResult(interp); } return result; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclCompCmds.c.
|
| | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 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 | /* * 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. * Copyright (c) 2004-2005 by Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclCompCmds.c,v 1.59.2.7 2005/08/15 20:46:02 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * Macro that encapsulates an efficiency trick that avoids a function call for * the simplest of compiles. The ANSI C "prototype" for this macro is: * * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, * Tcl_Interp *interp); */ #define CompileWord(envPtr, tokenPtr, interp) \ if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ (tokenPtr)[1].size), (envPtr)); \ } else { \ TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ (envPtr)); \ } /* * Convenience macro for use when compiling bodies of commands. The ANSI C * "prototype" for this macro is: * * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr, * Tcl_Interp *interp); */ #define CompileBody(envPtr, tokenPtr, interp) \ TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ (envPtr)) /* * Convenience macro for use when pushing literals. The ANSI C "prototype" for * this macro is: * * static void PushLiteral(CompileEnv *envPtr, * const char *string, int length); */ #define PushLiteral(envPtr, string, length) \ TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) /* * Macro to advance to the next token; it is more mnemonic than the address * arithmetic that it replaces. The ANSI C "prototype" for this macro is: * * static Tcl_Token * TokenAfter(Tcl_Token *tokenPtr); */ #define TokenAfter(tokenPtr) \ ((tokenPtr) + ((tokenPtr)->numComponents + 1)) /* * Macro to get the offset to the next instruction to be issued. The ANSI C * "prototype" for this macro is: * * static int CurrentOffset(CompileEnv *envPtr); */ #define CurrentOffset(envPtr) \ ((envPtr)->codeNext - (envPtr)->codeStart) /* * static int DeclareExceptionRange(CompileEnv *envPtr, int type); * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); */ #define DeclareExceptionRange(envPtr, type) \ (((envPtr)->exceptDepth++), \ ((envPtr)->maxExceptDepth = \ TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ (TclCreateExceptRange((type), (envPtr)))) #define ExceptionRangeStarts(envPtr, index) \ ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr)) #define ExceptionRangeEnds(envPtr, index) \ ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset) #define ExceptionRangeTarget(envPtr, index, targetType) \ ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) /* * Prototypes for procedures defined later in this file: */ static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); static void FreeForeachInfo _ANSI_ARGS_((ClientData clientData)); static int PushVarName _ANSI_ARGS_((Tcl_Interp *interp, |
︙ | ︙ | |||
35 36 37 38 39 40 41 | #define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */ /* * The structures below define the AuxData types defined in this file. */ AuxDataType tclForeachInfoType = { | | | | | | | | | | | | | | | | | | | < | | | | < < < < | < < | > | | | | | | > | < < < | | | | < < < | | | | | | | | | | | | | | | | | | | < | | | | | | < | | > | > > > > > > > > > > > > > > > > > | | | | | | < < | | < < < | | | | | < | | | | > | | > < < < | | > > > > > | > > > > > > > > > > | | | | > > | | > > | | | > > > > > > > > > | | | | | | > < | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | < | | | | | | | < | | | | | | | | | < < < | | < | | | < < < < < > | | < < < | | | > | | < | | | | | | 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 | #define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */ /* * The structures below define the AuxData types defined in this file. */ AuxDataType tclForeachInfoType = { "ForeachInfo", /* name */ DupForeachInfo, /* dupProc */ FreeForeachInfo /* freeProc */ }; /* *---------------------------------------------------------------------- * * TclCompileAppendCmd -- * * Procedure called to compile the "append" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "append" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileAppendCmd(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, *valueTokenPtr; int simpleVarName, isScalar, localIndex, numWords; numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; } else if (numWords == 2) { /* * append varName == set varName */ return TclCompileSetCmd(interp, parsePtr, envPtr); } else if (numWords > 3) { /* * APPEND instructions currently only handle one value */ return TCL_ERROR; } /* * Decide if we can use a frame slot for the var/array name or if we need * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); /* * We are doing an assignment, otherwise TclCompileSetCmd was called, so * push the new value. This will need to be extended to push a value for * each argument. */ if (numWords > 2) { valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp); } /* * Emit instructions to set/get the variable. */ if (simpleVarName) { if (isScalar) { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_STK, envPtr); } else if (localIndex <= 255) { TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr); } else { TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); } else if (localIndex <= 255) { TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr); } else { TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); } } } else { TclEmitOpcode(INST_APPEND_STK, envPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileBreakCmd -- * * Procedure called to compile the "break" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "break" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileBreakCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Parse *parsePtr; /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { if (parsePtr->numWords != 1) { return TCL_ERROR; } /* * Emit a break instruction. */ TclEmitOpcode(INST_BREAK, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileCatchCmd -- * * Procedure called to compile the "catch" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "catch" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileCatchCmd(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. */ { JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; CONST char *name; int resultIndex, optsIndex, nameChars, range; int savedStackDepth = envPtr->currStackDepth; /* * If syntax does not match what we expect for [catch], do not compile. * Let runtime checks determine if syntax has changed. */ if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) { return TCL_ERROR; } /* * If variables were specified and the catch command is at global level * (not in a procedure), don't compile it inline: the payoff is too small. */ if ((parsePtr->numWords >= 3) && (envPtr->procPtr == NULL)) { return TCL_ERROR; } /* * Make sure the variable names, if any, have no substitutions and just * refer to local scalars. */ resultIndex = optsIndex = -1; cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); if (parsePtr->numWords >= 3) { resultNameTokenPtr = TokenAfter(cmdTokenPtr); /* DGP */ if (resultNameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { name = resultNameTokenPtr[1].start; nameChars = resultNameTokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { return TCL_ERROR; } resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start, resultNameTokenPtr[1].size, /*create*/ 1, VAR_SCALAR, envPtr->procPtr); } else { return TCL_ERROR; } /* DKF */ if (parsePtr->numWords == 4) { optsNameTokenPtr = TokenAfter(resultNameTokenPtr); if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } name = optsNameTokenPtr[1].start; nameChars = optsNameTokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { return TCL_ERROR; } optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start, optsNameTokenPtr[1].size, /*create*/ 1, VAR_SCALAR, envPtr->procPtr); } } /* * We will compile the catch command. Emit a beginCatch instruction at the * start of the catch body: the subcommand it controls. */ range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); /* * If the body is a simple word, compile the instructions to eval it. * Otherwise, compile instructions to substitute its text without * catching, a catch instruction that resets the stack to what it was * before substituting the body, and then an instruction to eval the body. * Care has to be taken to register the correct startOffset for the catch * range so that errors in the substitution are not catched [Bug 219184] */ if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, cmdTokenPtr, interp); ExceptionRangeEnds(envPtr, range); } else { TclCompileTokens(interp, cmdTokenPtr+1, cmdTokenPtr->numComponents, envPtr); ExceptionRangeStarts(envPtr, range); TclEmitOpcode(INST_EVAL_STK, envPtr); ExceptionRangeEnds(envPtr, range); } /* * 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. Note that we issue the push of * the return options first so that if alterations happen to the current * interpreter state during the writing of the variable, we won't see * them; this results in a slightly complex instruction issuing flow * (can't exchange, only duplicate and pop). */ if (resultIndex != -1) { if (optsIndex != -1) { TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); } if (resultIndex <= 255) { TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr); } else { TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); } if (optsIndex != -1) { TclEmitOpcode(INST_POP, envPtr); if (optsIndex <= 255) { TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr); } else { TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr); } TclEmitOpcode(INST_POP, envPtr); } } TclEmitOpcode(INST_POP, envPtr); PushLiteral(envPtr, "0", 1); 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. Note that if we are saving the return * options, we do that first so the preservation cannot get affected by * any intermediate result handling. */ envPtr->currStackDepth = savedStackDepth; ExceptionRangeTarget(envPtr, range, catchOffset); if (resultIndex != -1) { if (optsIndex != -1) { TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); } TclEmitOpcode(INST_PUSH_RESULT, envPtr); if (resultIndex <= 255) { TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr); } else { TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); } TclEmitOpcode(INST_POP, envPtr); if (optsIndex != -1) { if (optsIndex <= 255) { TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr); } else { TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr); } TclEmitOpcode(INST_POP, envPtr); } } TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); /* * Update the target of the jump after the "no errors" code, then emit an * endCatch instruction at the end of the catch command. */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d\n", CurrentOffset(envPtr) - jumpFixup.codeOffset); } TclEmitOpcode(INST_END_CATCH, envPtr); envPtr->currStackDepth = savedStackDepth + 1; envPtr->exceptDepth--; return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileContinueCmd -- * * Procedure called to compile the "continue" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "continue" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileContinueCmd(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. */ { /* * There should be no argument after the "continue". */ if (parsePtr->numWords != 1) { return TCL_ERROR; } /* * Emit a continue instruction. */ TclEmitOpcode(INST_CONTINUE, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileDictCmd -- * * Procedure called to compile the "dict" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "dict" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileDictCmd(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 *tokenPtr; int numWords, size, i; const char *cmd; Proc *procPtr = envPtr->procPtr; /* * There must be at least one argument after the command. */ if (parsePtr->numWords < 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); numWords = parsePtr->numWords-2; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } /* * The following commands are in fairly common use and are possibly worth * bytecoding: * dict append * dict create [*] * dict exists [*] * dict for * dict get [*] * dict incr * dict keys [*] * dict lappend * dict set * dict unset * In practice, those that are pure-value operators (marked with [*]) can * probably be left alone (except perhaps [dict get] which is very very * common) and [dict update] should be considered instead (really big * win!) */ size = tokenPtr[1].size; cmd = tokenPtr[1].start; if (size==3 && strncmp(cmd, "set", 3)==0) { Tcl_Token *varTokenPtr; int dictVarIndex, nameChars; const char *name; if (numWords < 3 || procPtr == NULL) { return TCL_ERROR; } varTokenPtr = TokenAfter(tokenPtr); tokenPtr = TokenAfter(varTokenPtr); if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } name = varTokenPtr[1].start; nameChars = varTokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { return TCL_ERROR; } dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR, procPtr); for (i=1 ; i<numWords ; i++) { CompileWord(envPtr, tokenPtr, interp); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; } else if (size==4 && strncmp(cmd, "incr", 4)==0) { Tcl_Token *varTokenPtr, *keyTokenPtr, *incrTokenPtr = NULL; int dictVarIndex, nameChars, incrAmount = 1; const char *name; if (numWords < 2 || numWords > 3 || procPtr == NULL) { return TCL_ERROR; } varTokenPtr = TokenAfter(tokenPtr); keyTokenPtr = TokenAfter(varTokenPtr); if (numWords == 3) { const char *word; int numBytes, code; Tcl_Obj *intObj; incrTokenPtr = TokenAfter(keyTokenPtr); if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } word = incrTokenPtr[1].start; numBytes = incrTokenPtr[1].size; #if 0 /* * Note there is a danger that modifying the string could have * undesirable side effects. In this case, TclLooksLikeInt has no * dependencies on shared strings so we should be safe. */ if (!TclLooksLikeInt(word, numBytes)) { return TCL_ERROR; } #endif /* * Now try to really parse the number. */ intObj = Tcl_NewStringObj(word, numBytes); Tcl_IncrRefCount(intObj); code = Tcl_GetIntFromObj(NULL, intObj, &incrAmount); Tcl_DecrRefCount(intObj); if (code != TCL_OK) { return TCL_ERROR; } } if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } name = varTokenPtr[1].start; nameChars = varTokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { return TCL_ERROR; } dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR, procPtr); CompileWord(envPtr, keyTokenPtr, interp); TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; } else if (size==3 && strncmp(cmd, "get", 3)==0) { /* * Only compile this because we need INST_DICT_GET anyway. */ if (numWords < 2) { return TCL_ERROR; } for (i=0 ; i<numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp); } TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr); return TCL_OK; } else if (size==3 && strncmp(cmd, "for", 3)==0) { Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; int infoIndex, jumpDisplacement, bodyTargetOffset, doneTargetOffset; int endTargetOffset; const char **argv; Tcl_DString buffer; int savedStackDepth = envPtr->currStackDepth; if (numWords != 3 || procPtr == NULL) { return TCL_ERROR; } varsTokenPtr = TokenAfter(tokenPtr); dictTokenPtr = TokenAfter(varsTokenPtr); bodyTokenPtr = TokenAfter(dictTokenPtr); if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD || bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } /* * Check we've got a pair of variables and that they are local * variables. Then extract their indices in the LVT. */ Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, varsTokenPtr[1].start, varsTokenPtr[1].size); if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numWords, &argv) != TCL_OK) { Tcl_DStringFree(&buffer); return TCL_ERROR; } Tcl_DStringFree(&buffer); if (numWords != 2) { ckfree((char *) argv); return TCL_ERROR; } nameChars = strlen(argv[0]); if (!TclIsLocalScalar(argv[0], nameChars)) { ckfree((char *) argv); return TCL_ERROR; } keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, VAR_SCALAR, procPtr); nameChars = strlen(argv[1]); if (!TclIsLocalScalar(argv[1], nameChars)) { ckfree((char *) argv); return TCL_ERROR; } valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, VAR_SCALAR, procPtr); ckfree((char *) argv); /* * Allocate a temporary variable to store the iterator reference. The * variable will contain a Tcl_DictSearch reference which will be * allocated by INST_DICT_FIRST and disposed when the variable is * unset (at which point it should also have been finished with). */ infoIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR, procPtr); /* * Preparation complete; issue instructions. Note that this code * issues fixed-sized jumps. That simplifies things a lot! * * First up, get the dictionary and start the iteration. No catching * of errors at this point. */ CompileWord(envPtr, dictTokenPtr, interp); TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); doneTargetOffset = CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); /* * Now we catch errors from here on so that we can finalize the search * started by Tcl_DictObjFirst above. */ catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); ExceptionRangeStarts(envPtr, catchRange); /* * Inside the iteration, write the loop variables. */ bodyTargetOffset = CurrentOffset(envPtr); TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); /* * Set up the loop exception targets. */ loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); ExceptionRangeStarts(envPtr, loopRange); /* * Compile the loop body itself. It should be stack-neutral. */ CompileBody(envPtr, bodyTokenPtr, interp); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode( INST_POP, envPtr); envPtr->currStackDepth = savedStackDepth; /* * Both exception target ranges (error and loop) end here. */ ExceptionRangeEnds(envPtr, loopRange); ExceptionRangeEnds(envPtr, catchRange); /* * Continue (or just normally process) by getting the next pair of * items from the dictionary and jumping back to the code to write * them into variables if there is another pair. */ ExceptionRangeTarget(envPtr, loopRange, continueOffset); TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); /* * Otherwise we're done (the jump after the DICT_FIRST points here) * and we need to pop the bogus key/value pair (pushed to keep stack * calculations easy!) */ jumpDisplacement = CurrentOffset(envPtr) - doneTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, envPtr->codeStart + doneTargetOffset); TclEmitOpcode( INST_POP, envPtr); TclEmitOpcode( INST_POP, envPtr); /* * Now do the final cleanup for the no-error case (this is where we * break out of the loop to) by force-terminating the iteration (if * not already terminated), ditching the exception info and jumping to * the last instruction for this command. In theory, this could be * done using the "finally" clause (next generated) but this is * faster. */ ExceptionRangeTarget(envPtr, loopRange, breakOffset); TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); endTargetOffset = CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP4, 0, envPtr); /* * Error handler "finally" clause, which force-terminates the * iteration and rethrows the error. */ ExceptionRangeTarget(envPtr, catchRange, catchOffset); TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); TclEmitOpcode( INST_RETURN_STK, envPtr); /* * Final stage of the command (normal case) is that we push an empty * object. This is done last to promote peephole optimization when * it's dropped immediately. */ jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, envPtr->codeStart + endTargetOffset); PushLiteral(envPtr, "", 0); envPtr->exceptDepth -= 2; return TCL_OK; } else if (size==6 && strncmp(cmd, "update", 6)==0) { const char *name; int nameChars, dictIndex, keyTmpIndex, numVars, range; Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr; Tcl_DString localVarsLiteral; /* * Parse the command. Expect the following: * dict update <lit(eral)> <any> <lit> ?<any> <lit> ...? <lit> */ if (numWords < 4 || numWords & 1 || procPtr == NULL) { return TCL_ERROR; } numVars = numWords/2 - 1; dictVarTokenPtr = TokenAfter(tokenPtr); if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } name = dictVarTokenPtr[1].start; nameChars = dictVarTokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { return TCL_ERROR; } dictIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR, procPtr); Tcl_DStringInit(&localVarsLiteral); keyTokenPtrs = (Tcl_Token **) ckalloc(sizeof(Tcl_Token*) * numVars); tokenPtr = TokenAfter(dictVarTokenPtr); for (i=0 ; i<numVars ; i++) { keyTokenPtrs[i] = tokenPtr; tokenPtr = TokenAfter(tokenPtr); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { Tcl_DStringFree(&localVarsLiteral); ckfree((char *) keyTokenPtrs); return TCL_ERROR; } name = tokenPtr[1].start; nameChars = tokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { Tcl_DStringFree(&localVarsLiteral); ckfree((char *) keyTokenPtrs); return TCL_ERROR; } else { int localVar = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR, procPtr); char buf[12]; sprintf(buf, "%d", localVar); Tcl_DStringAppendElement(&localVarsLiteral, buf); } tokenPtr = TokenAfter(tokenPtr); } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { Tcl_DStringFree(&localVarsLiteral); ckfree((char *) keyTokenPtrs); return TCL_ERROR; } bodyTokenPtr = tokenPtr; keyTmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR, procPtr); for (i=0 ; i<numVars ; i++) { CompileWord(envPtr, keyTokenPtrs[i], interp); } TclEmitInstInt4( INST_LIST, numVars, envPtr); TclEmitInstInt4( INST_STORE_SCALAR4, keyTmpIndex, envPtr); PushLiteral(envPtr, Tcl_DStringValue(&localVarsLiteral), Tcl_DStringLength(&localVarsLiteral)); TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); ExceptionRangeTarget(envPtr, range, catchOffset); TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); envPtr->exceptDepth--; TclEmitInstInt4( INST_LOAD_SCALAR4, keyTmpIndex, envPtr); PushLiteral(envPtr, Tcl_DStringValue(&localVarsLiteral), Tcl_DStringLength(&localVarsLiteral)); /* * Any literal would do, but this one is handy... */ TclEmitInstInt4( INST_STORE_SCALAR4, keyTmpIndex, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); TclEmitOpcode( INST_RETURN_STK, envPtr); Tcl_DStringFree(&localVarsLiteral); ckfree((char *) keyTokenPtrs); return TCL_OK; } else if (size==6 && strncmp(cmd, "append", 6) == 0) { Tcl_Token *varTokenPtr; int dictVarIndex, nameChars; const char *name; /* * Arbirary safe limit; anyone exceeding it should stop worrying about * speed quite so much. ;-) */ if (numWords < 3 || numWords > 100 || procPtr == NULL) { return TCL_ERROR; } varTokenPtr = TokenAfter(tokenPtr); tokenPtr = TokenAfter(varTokenPtr); if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } name = varTokenPtr[1].start; nameChars = varTokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { return TCL_ERROR; } dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR, procPtr); for (i=1 ; i<numWords ; i++) { CompileWord(envPtr, tokenPtr, interp); tokenPtr = TokenAfter(tokenPtr); } if (numWords > 3) { TclEmitInstInt1( INST_CONCAT1, numWords-2, envPtr); } TclEmitInstInt4( INST_DICT_APPEND, dictVarIndex, envPtr); return TCL_OK; } else if (size==7 && strncmp(cmd, "lappend", 7) == 0) { Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr; int dictVarIndex, nameChars; const char *name; if (numWords != 3 || procPtr == NULL) { return TCL_ERROR; } varTokenPtr = TokenAfter(tokenPtr); keyTokenPtr = TokenAfter(varTokenPtr); valueTokenPtr = TokenAfter(keyTokenPtr); if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } name = varTokenPtr[1].start; nameChars = varTokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { return TCL_ERROR; } dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR, procPtr); CompileWord(envPtr, keyTokenPtr, interp); CompileWord(envPtr, valueTokenPtr, interp); TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } /* * Something we do not know how to compile. */ return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclCompileExprCmd -- * * Procedure called to compile the "expr" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "expr" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileExprCmd(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 *firstWordPtr; if (parsePtr->numWords == 1) { return TCL_ERROR; } firstWordPtr = TokenAfter(parsePtr->tokenPtr); TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords-1, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileForCmd -- * * Procedure called to compile the "for" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "for" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileForCmd(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 *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; int savedStackDepth = envPtr->currStackDepth; if (parsePtr->numWords != 5) { return TCL_ERROR; } /* * If the test expression requires substitutions, don't compile the for * command inline. E.g., the expression might cause the loop to never * execute or execute forever, as in "for {} "$x > 5" {incr x} {}". */ startTokenPtr = TokenAfter(parsePtr->tokenPtr); testTokenPtr = TokenAfter(startTokenPtr); if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } /* * Bail out also if the body or the next expression require substitutions * in order to insure correct behaviour [Bug 219166] */ nextTokenPtr = TokenAfter(testTokenPtr); bodyTokenPtr = TokenAfter(nextTokenPtr); if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { return TCL_ERROR; } /* * Create ExceptionRange records for the body and the "next" command. The * "next" command's ExceptionRange supports break but not continue (and * has a -1 continueOffset). */ bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); /* * Inline compile the initial command. */ CompileBody(envPtr, startTokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); /* * Jump to the evaluation of the condition. This code uses the "loop * rotation" optimisation (which eliminates one branch from the loop). * "for start cond next body" produces then: * start * goto A * B: body : bodyCodeOffset * next : nextCodeOffset, continueOffset * A: cond -> result : testCodeOffset * if (result) goto B */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); /* * Compile the loop body. */ bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); /* * Compile the "next" subcommand. */ envPtr->currStackDepth = savedStackDepth; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); envPtr->currStackDepth = savedStackDepth; /* * Compile the test expression then emit the conditional jump that * terminates the for. */ testCodeOffset = CurrentOffset(envPtr); jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; testCodeOffset += 3; } envPtr->currStackDepth = savedStackDepth; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); } /* * Fix the starting points of the exception ranges (may have moved due to * jump type modification) and set where the exceptions target. */ envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset; envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset; envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset; ExceptionRangeTarget(envPtr, bodyRange, breakOffset); ExceptionRangeTarget(envPtr, nextRange, breakOffset); /* * The for command's result is an empty string. */ envPtr->currStackDepth = savedStackDepth; PushLiteral(envPtr, "", 0); envPtr->exceptDepth--; return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileForeachCmd -- * * Procedure called to compile the "foreach" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to 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. */ |
︙ | ︙ | |||
653 654 655 656 657 658 659 | /* * If the foreach command isn't in a procedure, don't compile it inline: * the payoff is too small. */ if (procPtr == NULL) { | | | | | | < | | | | | | < < < < < < < < | | | > > | | > > | | | > | > | | | < | | < | | | | | | | | | | | | | | | < | | | < | | > | | | | | > > > > > > < < | | 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 | /* * If the foreach command isn't in a procedure, don't compile it inline: * the payoff is too small. */ if (procPtr == NULL) { return TCL_ERROR; } numWords = parsePtr->numWords; if ((numWords < 4) || (numWords%2 != 0)) { return TCL_ERROR; } /* * Bail out if the body requires substitutions in order to insure correct * behaviour [Bug 219166] */ for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++) { tokenPtr = TokenAfter(tokenPtr); } bodyTokenPtr = tokenPtr; if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } /* * 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; } /* * Break up each var list and set the varcList and varvList arrays. Don't * compile the foreach inline if any var name needs substitutions or isn't * a scalar, or if any var list needs substitutions. */ loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { Tcl_DString varList; if (i%2 != 1) { continue; } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { code = TCL_ERROR; goto done; } /* * Lots of copying going on here. Need a ListObj wizard to show a * better way. */ 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) { code = TCL_ERROR; 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_ERROR; goto done; } } loopIndex++; } /* * We will compile the foreach command. Reserve (numLists + 1) temporary * variables: * - numLists temps to hold each value list * - 1 temp for the loop counter (index of next element in each list) * * At this time we don't try to reuse temporaries; if there are two * nonoverlapping foreach loops, they don't share any temps. */ code = TCL_OK; firstValueTemp = -1; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, VAR_SCALAR, procPtr); if (loopIndex == 0) { firstValueTemp = tempVar; } } loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, VAR_SCALAR, procPtr); /* * Create and initialize the ForeachInfo and ForeachVarList data * structures describing this command. Then create a AuxData record * pointing to the ForeachInfo structure. */ infoPtr = (ForeachInfo *) ckalloc((unsigned) sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *)); infoPtr->numLists = numLists; infoPtr->firstValueTemp = firstValueTemp; infoPtr->loopCtTemp = loopCtTemp; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { ForeachVarList *varListPtr; numVars = varcList[loopIndex]; varListPtr = (ForeachVarList *) ckalloc((unsigned) sizeof(ForeachVarList) + numVars*sizeof(int)); varListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { CONST char *varName = varvList[loopIndex][j]; int nameChars = strlen(varName); varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, nameChars, /*create*/ 1, VAR_SCALAR, procPtr); } infoPtr->varLists[loopIndex] = varListPtr; } infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr); /* * Create an exception record to handle [break] and [continue]. */ range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); /* * Evaluate then store each value list in the associated temporary. */ loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); tempVar = (firstValueTemp + loopIndex); if (tempVar <= 255) { TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr); |
︙ | ︙ | |||
823 824 825 826 827 828 829 | TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); /* * Top of loop code: assign each loop variable and check whether * to terminate the loop. */ | | < < | | | < < < | | < | | | 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 | TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); /* * Top of loop code: assign each loop variable and check whether * to terminate the loop. */ ExceptionRangeTarget(envPtr, range, continueOffset); TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); /* * Inline compile the loop body. */ ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); /* * Jump back to the test at the top of the loop. Generate a 4 byte jump if * the distance to the test is > 120 bytes. This is conservative and * ensures that we won't have to replace this jump if we later need to * replace the ifFalse jump with a 4 byte jump. */ jumpBackOffset = CurrentOffset(envPtr); jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset; if (jumpBackDist > 120) { TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); } else { TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); } /* |
︙ | ︙ | |||
888 889 890 891 892 893 894 | } } /* * Set the loop's break target. */ | | < | | | | | | | | | | | 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 | } } /* * Set the loop's break target. */ ExceptionRangeTarget(envPtr, range, breakOffset); /* * The foreach command's result is an empty string. */ envPtr->currStackDepth = savedStackDepth; PushLiteral(envPtr, "", 0); 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; } /* *---------------------------------------------------------------------- * * DupForeachInfo -- * * This procedure duplicates a ForeachInfo structure created as auxiliary * data during the compilation of a foreach command. * * Results: * A pointer to a newly allocated copy of the existing ForeachInfo * structure is returned. * * Side effects: * Storage for the copied ForeachInfo record is allocated. If the * original ForeachInfo structure pointed to any ForeachVarList records, * these structures are also copied and pointers to them are stored in * the new ForeachInfo record. * *---------------------------------------------------------------------- */ static ClientData DupForeachInfo(clientData) ClientData clientData; /* The foreach command's compilation * auxiliary data to duplicate. */ { register ForeachInfo *srcPtr = (ForeachInfo *) clientData; ForeachInfo *dupPtr; register ForeachVarList *srcListPtr, *dupListPtr; int numLists = srcPtr->numLists; int numVars, i, j; dupPtr = (ForeachInfo *) ckalloc((unsigned) sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *)); dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; dupPtr->loopCtTemp = srcPtr->loopCtTemp; for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; numVars = srcListPtr->numVars; dupListPtr = (ForeachVarList *) ckalloc((unsigned) sizeof(ForeachVarList) + numVars*sizeof(int)); dupListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; } dupPtr->varLists[i] = dupListPtr; } return (ClientData) dupPtr; |
︙ | ︙ | |||
1009 1010 1011 1012 1013 1014 1015 | *---------------------------------------------------------------------- * * TclCompileIfCmd -- * * Procedure called to compile the "if" command. * * Results: | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | *---------------------------------------------------------------------- * * TclCompileIfCmd -- * * Procedure called to compile the "if" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "if" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileIfCmd(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. */ { JumpFixupArray jumpFalseFixupArray; /* Used to fix the ifFalse jump after each * test when its target PC is determined. */ JumpFixupArray jumpEndFixupArray; /* 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 jumpFalseDist; int jumpIndex = 0; /* avoid compiler warning. */ int numWords, wordIdx, numBytes, j, code; CONST char *word; 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] */ tokenPtr = parsePtr->tokenPtr; wordIdx = 0; numWords = parsePtr->numWords; for (wordIdx = 0; wordIdx < numWords; wordIdx++) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); } TclInitJumpFixupArray(&jumpFalseFixupArray); TclInitJumpFixupArray(&jumpEndFixupArray); code = TCL_OK; /* * Each iteration of this loop compiles one "if expr ?then? body" or * "elseif expr ?then? body" clause. */ tokenPtr = parsePtr->tokenPtr; wordIdx = 0; while (wordIdx < numWords) { /* * Stop looping if the token isn't "if" or "elseif". */ word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((tokenPtr == parsePtr->tokenPtr) || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { tokenPtr = TokenAfter(tokenPtr); wordIdx++; } else { break; } if (wordIdx >= numWords) { code = TCL_ERROR; goto done; } /* * Compile the test expression then emit the conditional jump around * the "then" part. */ envPtr->currStackDepth = savedStackDepth; testTokenPtr = tokenPtr; 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); |
︙ | ︙ | |||
1128 1129 1130 1131 1132 1133 1134 | TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { TclExpandJumpFixupArray(&jumpFalseFixupArray); } jumpIndex = jumpFalseFixupArray.next; jumpFalseFixupArray.next++; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, | | | | | | | < | | | | | | | | | | | < | | | | | | | | | < | | | | < | | | | | | | | | | | | | | < | < | | < < | | | < | > | | | | | > < > > < | | | < | 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 | TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { TclExpandJumpFixupArray(&jumpFalseFixupArray); } jumpIndex = jumpFalseFixupArray.next; jumpFalseFixupArray.next++; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, jumpFalseFixupArray.fixup+jumpIndex); } code = TCL_OK; } /* * Skip over the optional "then" before the then clause. */ tokenPtr = TokenAfter(testTokenPtr); wordIdx++; if (wordIdx >= numWords) { code = TCL_ERROR; goto done; } if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { tokenPtr = TokenAfter(tokenPtr); wordIdx++; if (wordIdx >= numWords) { code = TCL_ERROR; goto done; } } } /* * Compile the "then" command body. */ if (compileScripts) { envPtr->currStackDepth = savedStackDepth; CompileBody(envPtr, tokenPtr, interp); } if (realCond) { /* * Jump to the end of the "if" command. Both jumpFalseFixupArray * and jumpEndFixupArray are indexed by "jumpIndex". */ if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { TclExpandJumpFixupArray(&jumpEndFixupArray); } jumpEndFixupArray.next++; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, jumpEndFixupArray.fixup+jumpIndex); /* * Fix the target of the jumpFalse after the test. Generate a 4 * byte jump if the distance is > 120 bytes. This is conservative, * and ensures that we won't have to replace this jump if we later * also need to replace the proceeding jump to the end of the "if" * with a 4 byte jump. */ if (TclFixupForwardJumpToHere(envPtr, jumpFalseFixupArray.fixup+jumpIndex, 120)) { /* * Adjust the code offset for the proceeding jump to the end * of the "if" command. */ jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; } } else if (boolVal) { /* * We were processing an "if 1 {...}"; stop compiling scripts. */ compileScripts = 0; } else { /* * We were processing an "if 0 {...}"; reset so that the rest * (elseif, else) is compiled correctly. */ realCond = 1; compileScripts = 1; } tokenPtr = TokenAfter(tokenPtr); wordIdx++; } /* * Restore the current stack depth in the environment; the "else" clause * (or its default) will add 1 to this. */ envPtr->currStackDepth = savedStackDepth; /* * Check for the optional else clause. Do not compile anything if this was * an "if 1 {...}" case. */ if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { /* * There is an else clause. Skip over the optional "else" word. */ word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { tokenPtr = TokenAfter(tokenPtr); wordIdx++; if (wordIdx >= numWords) { code = TCL_ERROR; goto done; } } if (compileScripts) { /* * Compile the else command body. */ CompileBody(envPtr, tokenPtr, interp); } /* * Make sure there are no words after the else clause. */ wordIdx++; if (wordIdx < numWords) { code = TCL_ERROR; goto done; } } else { /* * No else clause: the "if" command's result is an empty string. */ if (compileScripts) { PushLiteral(envPtr, "", 0); } } /* * Fix the unconditional jumps to the end of the "if" command. */ for (j = jumpEndFixupArray.next; j > 0; j--) { jumpIndex = (j - 1); /* i.e. process the closest jump first */ if (TclFixupForwardJumpToHere(envPtr, jumpEndFixupArray.fixup+jumpIndex, 127)) { /* * Adjust the immediately preceeding "ifFalse" jump. We moved it's * target (just after this jump) down three bytes. */ unsigned char *ifFalsePc = envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; unsigned char opCode = *ifFalsePc; if (opCode == INST_JUMP_FALSE1) { jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); jumpFalseDist += 3; TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else if (opCode == INST_JUMP_FALSE4) { jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); jumpFalseDist += 3; TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else { Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); } } } /* * Free the jumpFixupArray array if malloc'ed storage was used. */ done: envPtr->currStackDepth = savedStackDepth + 1; TclFreeJumpFixupArray(&jumpFalseFixupArray); TclFreeJumpFixupArray(&jumpEndFixupArray); return code; } /* *---------------------------------------------------------------------- * * TclCompileIncrCmd -- * * Procedure called to compile the "incr" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "incr" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileIncrCmd(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, *incrTokenPtr; int simpleVarName, isScalar, localIndex, haveImmValue, immValue; if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); /* * If an increment is given, push it, but see first if it's a small * integer. */ haveImmValue = 0; immValue = 1; if (parsePtr->numWords == 3) { incrTokenPtr = TokenAfter(varTokenPtr); if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { CONST char *word = incrTokenPtr[1].start; int numBytes = incrTokenPtr[1].size; #if 0 /* * Note there is a danger that modifying the string could have * undesirable side effects. In this case, TclLooksLikeInt has * no dependencies on shared strings so we should be safe. */ if (TclLooksLikeInt(word, numBytes)) { #endif int code; Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); Tcl_IncrRefCount(intObj); code = Tcl_GetIntFromObj(NULL, intObj, &immValue); Tcl_DecrRefCount(intObj); if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { haveImmValue = 1; } #if 0 } #endif if (!haveImmValue) { PushLiteral(envPtr, word, numBytes); } } else { TclCompileTokens(interp, incrTokenPtr+1, incrTokenPtr->numComponents, envPtr); } } else { /* no incr amount given so use 1 */ haveImmValue = 1; } /* * Emit the instruction to increment the variable. */ if (simpleVarName) { |
︙ | ︙ | |||
1456 1457 1458 1459 1460 1461 1462 | *---------------------------------------------------------------------- * * TclCompileLappendCmd -- * * Procedure called to compile the "lappend" command. * * Results: | | | | | | | | | | | < | | | < < < < | < < | > | | | | | | > | < < < | | | | < < < | | | | | | < < | < < < | | | | 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 | *---------------------------------------------------------------------- * * TclCompileLappendCmd -- * * Procedure called to compile the "lappend" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lappend" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileLappendCmd(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 simpleVarName, isScalar, localIndex, numWords; /* * If we're not in a procedure, don't compile. */ if (envPtr->procPtr == NULL) { return TCL_ERROR; } numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; } if (numWords != 3) { /* * LAPPEND instructions currently only handle one value appends */ return TCL_ERROR; } /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a * frame slot (entry in the array of local vars) if we are compiling a * procedure body and if the name is simple text that does not include * namespace qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); /* * If we are doing an assignment, push the new value. In the no values * case, create an empty object. */ if (numWords > 2) { Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp); } /* * Emit instructions to set/get the variable. */ /* * The *_STK opcodes should be refactored to make better use of existing * LOAD/STORE instructions. */ if (simpleVarName) { if (isScalar) { if (localIndex < 0) { TclEmitOpcode(INST_LAPPEND_STK, envPtr); } else if (localIndex <= 255) { TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr); } else { TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr); } else if (localIndex <= 255) { TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr); } else { TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr); } } } else { TclEmitOpcode(INST_LAPPEND_STK, envPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileLassignCmd -- * * Procedure called to compile the "lassign" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lassign" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileLassignCmd(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 *tokenPtr; int simpleVarName, isScalar, localIndex, numWords, idx; numWords = parsePtr->numWords; /* * Check for command syntax error, but we'll punt that to runtime */ if (numWords < 3) { return TCL_ERROR; } /* * Generate code to push list being taken apart by [lassign]. */ tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp); /* * Generate code to assign values from the list to variables */ for (idx=0 ; idx<numWords-2 ; idx++) { tokenPtr = TokenAfter(tokenPtr); /* * Generate the next variable name */ PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); /* * Emit instructions to get the idx'th item out of the list value on * the stack and assign it to the variable. */ if (simpleVarName) { if (isScalar) { if (localIndex >= 0) { TclEmitOpcode(INST_DUP, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); if (localIndex <= 255) { |
︙ | ︙ | |||
1679 1680 1681 1682 1683 1684 1685 | *---------------------------------------------------------------------- * * TclCompileLindexCmd -- * * Procedure called to compile the "lindex" command. * * Results: | | | | | | | < | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < | | < < < < < | | | | | | | | | | | | < < < < < | | < < | | | | | | | | < < < < < < | < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | > < | < < < < < | < < < < < | | 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 | *---------------------------------------------------------------------- * * TclCompileLindexCmd -- * * Procedure called to compile the "lindex" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lindex" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileLindexCmd(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 = parsePtr->numWords; /* * Quit if too few args */ if (numWords <= 1) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); if ((numWords == 3) && (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) #if 0 && TclLooksLikeInt(varTokenPtr[1].start, varTokenPtr[1].size) #endif ) { Tcl_Obj *tmpObj; int idx, result; tmpObj = Tcl_NewStringObj(varTokenPtr[1].start, varTokenPtr[1].size); result = Tcl_GetIntFromObj(NULL, tmpObj, &idx); TclDecrRefCount(tmpObj); if (result == TCL_OK && idx >= 0) { /* * All checks have been completed, and we have exactly this * construct: * lindex <posInt> <arbitraryValue> * This is best compiled as a push of the arbitrary value followed * by an "immediate lindex" which is the most efficient variety. */ varTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, varTokenPtr, interp); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); return TCL_OK; } /* * If the conversion failed or the value was negative, we just keep on * going with the more complex compilation. */ } /* * Push the operands onto the stack. */ for (i=1 ; i<numWords ; i++) { CompileWord(envPtr, varTokenPtr, interp); varTokenPtr = TokenAfter(varTokenPtr); } /* * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are * multiple index args. */ if (numWords == 3) { TclEmitOpcode(INST_LIST_INDEX, envPtr); } else { TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileListCmd -- * * Procedure called to compile the "list" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "list" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileListCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Parse *parsePtr; /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { /* * If we're not in a procedure, don't compile. */ if (envPtr->procPtr == NULL) { return TCL_ERROR; } if (parsePtr->numWords == 1) { /* * [list] without arguments just pushes an empty object. */ PushLiteral(envPtr, "", 0); } else { /* * Push the all values onto the stack. */ Tcl_Token *valueTokenPtr; int i, numWords; numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i++) { CompileWord(envPtr, valueTokenPtr, interp); valueTokenPtr = TokenAfter(valueTokenPtr); } TclEmitInstInt4(INST_LIST, numWords - 1, envPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileLlengthCmd -- * * Procedure called to compile the "llength" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "llength" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileLlengthCmd(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; if (parsePtr->numWords != 2) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, varTokenPtr, interp); TclEmitOpcode(INST_LIST_LENGTH, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileLsetCmd -- * * Procedure called to compile the "lset" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "lset" command at * runtime. * * The general template for execution of the "lset" command is: * (1) Instructions to push the variable name, unless the variable is * local to the stack frame. * (2) If the variable is an array element, instructions to push the * array element name. * (3) Instructions to push each of zero or more "index" arguments to the * stack, followed with the "newValue" element. * (4) Instructions to duplicate the variable name and/or array element * name onto the top of the stack, if either was pushed at steps (1) * and (2). * (5) The appropriate INST_LOAD_* instruction to place the original * value of the list variable at top of stack. * (6) At this point, the stack contains: * varName? arrayElementName? index1 index2 ... newValue oldList * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST * according as whether there is exactly one index element (LIST) or * either zero or else two or more (FLAT). This instruction removes * everything from the stack except for the two names and pushes the * new value of the variable. * (7) Finally, INST_STORE_* stores the new value in the variable and * cleans up the stack. * *---------------------------------------------------------------------- */ int TclCompileLsetCmd(interp, parsePtr, envPtr) Tcl_Interp* interp; /* Tcl interpreter for error reporting */ Tcl_Parse* parsePtr; /* Points to a parse structure for the * command */ CompileEnv* envPtr; /* Holds the resulting instructions */ { int tempDepth; /* Depth used for emitting one part of the * code burst. */ Tcl_Token* varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the variable name */ int localIndex; /* Index of var in local var table */ int simpleVarName; /* Flag == 1 if var name is simple */ int isScalar; /* Flag == 1 if scalar, 0 if array */ int i; /* Check argument count */ if (parsePtr->numWords < 3) { /* Fail at run time, not in compilation */ return TCL_ERROR; } /* * Decide if we can use a frame slot for the var/array name or if we need * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); /* * Push the "index" args and the new element value. */ for (i=2 ; i<parsePtr->numWords ; ++i) { varTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, varTokenPtr, interp); } /* * Duplicate the variable name if it's been pushed. */ if (!simpleVarName || localIndex < 0) { if (!simpleVarName || isScalar) { tempDepth = parsePtr->numWords - 2; } else { tempDepth = parsePtr->numWords - 1; |
︙ | ︙ | |||
2005 2006 2007 2008 2009 2010 2011 | /* * Emit the correct variety of 'lset' instruction */ if (parsePtr->numWords == 4) { TclEmitOpcode(INST_LSET_LIST, envPtr); } else { | | | 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 | /* * Emit the correct variety of 'lset' instruction */ if (parsePtr->numWords == 4) { TclEmitOpcode(INST_LSET_LIST, envPtr); } else { TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr); } /* * Emit code to put the value back in the variable */ if (!simpleVarName) { |
︙ | ︙ | |||
2043 2044 2045 2046 2047 2048 2049 | *---------------------------------------------------------------------- * * TclCompileRegexpCmd -- * * Procedure called to compile the "regexp" command. * * Results: | | | | | | | | | | | | | | | | | | < | | | | | | 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 | *---------------------------------------------------------------------- * * TclCompileRegexpCmd -- * * Procedure called to compile the "regexp" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "regexp" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileRegexpCmd(interp, parsePtr, envPtr) Tcl_Interp* interp; /* Tcl interpreter for error reporting */ 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, nocase, anchorLeft, anchorRight, start; char *str; /* * We are only interested in compiling simple regexp cases. Currently * supported compile cases are: * regexp ?-nocase? ?--? staticString $var * regexp ?-nocase? ?--? {^staticString$} $var */ if (parsePtr->numWords < 3) { return TCL_ERROR; } nocase = 0; varTokenPtr = parsePtr->tokenPtr; /* * We only look for -nocase and -- as options. Everything else gets * pushed to runtime execution. This is different than regexp's runtime * option handling, but satisfies our stricter needs. */ for (i = 1; i < parsePtr->numWords - 2; i++) { varTokenPtr = TokenAfter(varTokenPtr); if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* Not a simple string - punt to runtime. */ return TCL_ERROR; } str = (char *) varTokenPtr[1].start; len = varTokenPtr[1].size; if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { i++; break; } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) { nocase = 1; } else { /* Not an option we recognize. */ return TCL_ERROR; } } if ((parsePtr->numWords - i) != 2) { /* We don't support capturing to variables */ return TCL_ERROR; } /* * Get the regexp string. If it is not a simple string, punt to runtime. * If it has a '-', it could be an incorrectly formed regexp command. */ varTokenPtr = TokenAfter(varTokenPtr); str = (char *) varTokenPtr[1].start; len = varTokenPtr[1].size; if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (*str == '-')) { return TCL_ERROR; } if (len == 0) { /* * The semantics of regexp are always match on re == "". */ PushLiteral(envPtr, "1", 1); return TCL_OK; } /* * Make a copy of the string that is null-terminated for checks which * require such. */ |
︙ | ︙ | |||
2157 2158 2159 2160 2161 2162 2163 | anchorRight = 0; } /* * 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'. */ | | | | | | | | < | | | > | < < < < < < < | > > | | | | | < > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | < < | < | | < < < < | > | | | | | | > | > | < < > | | | | | | | | | | | | > | > > | | | | | | < | < | | | | | | | | | | | | | | | < < | < | < < < < < | > > | | | | | | | | | | > | < < < | | | | | | | | < < < < | > > > | | | | | | | | | | < | | < < < < < < < < < < < < < < < < < < < < < | | < | | | | | > > > > > > > > > > > > > > | > > > > > | | | | | < < < < | | | < | | < < | < | < | < < < < | < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | < < | < | | < | | | | < | | < | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > | | > > > > | | > > < < < < < < < > > | | | | | | | | | > | > > > > > > > | | < | < > > > > | < < < < | > > | > > > > > > | | | | > > > | > | < > > > | > | > > | < < < < < < > > | > > > > > > > | | > > | < > > > > > | < | | | | > < > > | > | | < < | < < < < < < < < | < < < | < | | < < > | > > > | | > | < | | > | | > > > | < > > | < < | > | < | | < < | > | > > > | > < < < > > > > > > > | > > > > > > > > | > | | < > | | > > > > | > > > > > > > > > > | < > > | | > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > | > > > | | < < < < < < | | < > | | | | | > > | | > | > | < < < < < < < | | > | > > | > | > | < | | | < > | | | > | > | > | | | < > | | > > | | | < | > | | > | | > | | | | | | | | | | | > | > | | | | | > | | | | < > > > | > > > | | > > > > | > > > | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | > | | | | < < < | | | | | < < | | | | | < | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > | 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 | anchorRight = 0; } /* * 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'. */ if ((len > 1+start) && (str[start] == '.') && (str[start+1] == '*')) { start += 2; anchorLeft = 0; } if ((len > 2+start) && (str[len-3] != '\\') && (str[len-2] == '.') && (str[len-1] == '*')) { len -= 2; str[len] = '\0'; anchorRight = 0; } /* * Don't do anything with REs with other special chars. Also check if this * is a bad RE (do this at the end because it can be expensive). If so, * let it complain at runtime. */ if ((strpbrk(str + start, "*+?{}()[].\\|^$") != NULL) || (Tcl_RegExpCompile(NULL, str) == NULL)) { ckfree((char *) str); return TCL_ERROR; } if (anchorLeft && anchorRight) { PushLiteral(envPtr, str+start, len-start); } else { /* * This needs to find the substring anywhere in the string, so use * [string match] and *foo*, with appropriate anchoring. */ char *newStr = ckalloc((unsigned) len + 3); len -= start; if (anchorLeft) { strncpy(newStr, str + start, (size_t) len); } else { newStr[0] = '*'; strncpy(newStr + 1, str + start, (size_t) len++); } if (!anchorRight) { newStr[len++] = '*'; } newStr[len] = '\0'; PushLiteral(envPtr, newStr, len); ckfree((char *) newStr); } ckfree((char *) str); /* * Push the string arg */ varTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, varTokenPtr, interp); if (anchorLeft && anchorRight && !nocase) { TclEmitOpcode(INST_STR_EQ, envPtr); } else { TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileReturnCmd -- * * Procedure called to compile the "return" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "return" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileReturnCmd(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. */ { /* * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ int level, code, status = TCL_OK; int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; Tcl_Obj *returnOpts; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); #define NUM_STATIC_OBJS 20 int objc; Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; /* * Check for special case which can always be compiled: * return -options <opts> <msg> * Unlike the normal [return] compilation, this version does everything at * runtime so it can handle arbitrary words and not just literals. Note * that if INST_RETURN_STK wasn't already needed for something else * ('finally' clause processing) this piece of code would not be present. */ if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && (wordTokenPtr[1].size == 8) && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); CompileWord(envPtr, optsTokenPtr, interp); CompileWord(envPtr, msgTokenPtr, interp); TclEmitOpcode(INST_RETURN_STK, envPtr); return TCL_OK; } /* * Allocate some working space if needed */ if (numOptionWords > NUM_STATIC_OBJS) { objv = (Tcl_Obj **) ckalloc(numOptionWords * sizeof(Tcl_Obj *)); } else { objv = staticObjArray; } /* * Scan through the return options. If any are unknown at compile time, * there is no value in bytecompiling. Save the option values known in an * objv array for merging into a return options dictionary. */ for (objc = 0; objc < numOptionWords; objc++) { objv[objc] = Tcl_NewObj(); Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { objc++; status = TCL_ERROR; goto cleanup; } wordTokenPtr = TokenAfter(wordTokenPtr); } status = TclMergeReturnOptions(interp, objc, objv, &returnOpts, &code, &level); cleanup: while (--objc >= 0) { Tcl_DecrRefCount(objv[objc]); } if (numOptionWords > NUM_STATIC_OBJS) { ckfree((char *)objv); } if (TCL_ERROR == status) { /* * Something was bogus in the return options. Clear the error message, * and report back to the compiler that this must be interpreted at * runtime. */ Tcl_ResetResult(interp); return TCL_ERROR; } /* * All options are known at compile time, so we're going to bytecompile. * Emit instructions to push the result on the stack */ if (explicitResult) { CompileWord(envPtr, wordTokenPtr, interp); } else { /* * No explict result argument, so default result is empty string. */ PushLiteral(envPtr, "", 0); } /* * Check for optimization: When [return] is in a proc, and there's no * enclosing [catch], and there are no return options, then the INST_DONE * instruction is equivalent, and may be more efficient. */ if (numOptionWords == 0 && envPtr->procPtr != NULL) { /* * We have default return options and we're in a proc ... */ int index = envPtr->exceptArrayNext - 1; int enclosingCatch = 0; while (index >= 0) { ExceptionRange range = envPtr->exceptArrayPtr[index]; if ((range.type == CATCH_EXCEPTION_RANGE) && (range.catchOffset == -1)) { enclosingCatch = 1; break; } index--; } if (!enclosingCatch) { /* * ... and there is no enclosing catch. Issue the maximally * efficient exit instruction. */ Tcl_DecrRefCount(returnOpts); TclEmitOpcode(INST_DONE, envPtr); return TCL_OK; } } /* * Could not use the optimization, so we push the return options dict, and * emit the INST_RETURN_IMM instruction with code and level as operands. */ TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); TclEmitInstInt4(INST_RETURN_IMM, code, envPtr); TclEmitInt4(level, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileSetCmd -- * * Procedure called to compile the "set" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "set" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileSetCmd(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, *valueTokenPtr; int isAssignment, isScalar, simpleVarName, localIndex, numWords; numWords = parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { return TCL_ERROR; } isAssignment = (numWords == 3); /* * Decide if we can use a frame slot for the var/array name or if we need * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar); /* * If we are doing an assignment, push the new value. */ if (isAssignment) { valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp); } /* * Emit instructions to set/get the variable. */ if (simpleVarName) { if (isScalar) { if (localIndex < 0) { TclEmitOpcode((isAssignment? INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr); } else if (localIndex <= 255) { TclEmitInstInt1((isAssignment? INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), localIndex, envPtr); } else { TclEmitInstInt4((isAssignment? INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode((isAssignment? INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); } else if (localIndex <= 255) { TclEmitInstInt1((isAssignment? INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), localIndex, envPtr); } else { TclEmitInstInt4((isAssignment? INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), localIndex, envPtr); } } } else { TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileStringCmd -- * * Procedure called to compile the "string" command. Generally speaking, * these are mostly various kinds of peephole optimizations; most string * operations are handled by executing the interpreted version of the * command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "string" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileStringCmd(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 *opTokenPtr, *varTokenPtr; Tcl_Obj *opObj; int i, index; static CONST char *options[] = { "bytelength", "compare", "equal", "first", "index", "is", "last", "length", "map", "match", "range", "repeat", "replace", "tolower", "toupper", "totitle", "trim", "trimleft", "trimright", "wordend", "wordstart", (char *) NULL }; enum options { STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST, STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, STR_WORDEND, STR_WORDSTART }; if (parsePtr->numWords < 2) { /* Fail at run time, not in compilation */ return TCL_ERROR; } opTokenPtr = TokenAfter(parsePtr->tokenPtr); opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size); if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0, &index) != TCL_OK) { Tcl_DecrRefCount(opObj); Tcl_ResetResult(interp); return TCL_ERROR; } Tcl_DecrRefCount(opObj); varTokenPtr = TokenAfter(opTokenPtr); switch ((enum options) index) { case STR_COMPARE: case STR_EQUAL: /* * If there are any flags to the command, we can't byte compile it * because the INST_STR_EQ bytecode doesn't support flags. */ if (parsePtr->numWords != 4) { return TCL_ERROR; } /* * Push the two operands onto the stack. */ for (i = 0; i < 2; i++) { CompileWord(envPtr, varTokenPtr, interp); varTokenPtr = TokenAfter(varTokenPtr); } TclEmitOpcode(((((enum options) index) == STR_COMPARE) ? INST_STR_CMP : INST_STR_EQ), envPtr); return TCL_OK; case STR_INDEX: if (parsePtr->numWords != 4) { /* Fail at run time, not in compilation */ return TCL_ERROR; } /* * Push the two operands onto the stack. */ for (i = 0; i < 2; i++) { CompileWord(envPtr, varTokenPtr, interp); varTokenPtr = TokenAfter(varTokenPtr); } TclEmitOpcode(INST_STR_INDEX, envPtr); return TCL_OK; case STR_MATCH: { int length, exactMatch = 0, nocase = 0; CONST char *str; if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { /* Fail at run time, not in compilation */ return TCL_ERROR; } if (parsePtr->numWords == 5) { if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } str = varTokenPtr[1].start; length = varTokenPtr[1].size; if ((length > 1) && strncmp(str, "-nocase", (size_t) length) == 0) { nocase = 1; } else { /* Fail at run time, not in compilation */ return TCL_ERROR; } varTokenPtr = TokenAfter(varTokenPtr); } for (i = 0; i < 2; i++) { if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { str = varTokenPtr[1].start; length = varTokenPtr[1].size; if (!nocase && (i == 0)) { /* * Trivial matches can be done by 'string equal'. 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 = TclMatchIsTrivial(Tcl_GetString(copy)); Tcl_DecrRefCount(copy); } PushLiteral(envPtr, str, length); } else { TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); } varTokenPtr = TokenAfter(varTokenPtr); } if (exactMatch) { TclEmitOpcode(INST_STR_EQ, envPtr); } else { TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); } return TCL_OK; } case STR_LENGTH: if (parsePtr->numWords != 3) { /* Fail at run time, not in compilation */ return TCL_ERROR; } if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { /* * 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); PushLiteral(envPtr, buf, len); return TCL_OK; } else { TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); } TclEmitOpcode(INST_STR_LEN, envPtr); return TCL_OK; default: /* * All other cases: compile out of line. */ return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileSwitchCmd -- * * Procedure called to compile the "switch" command. * * Results: * Returns TCL_OK for successful compile, or TCL_ERROR to defer * evaluation to runtime (either when it is too complex to get the * semantics right, or when we know for sure that it is an error but need * the error to happen at the right time). * * Side effects: * Instructions are added to envPtr to execute the "switch" command at * runtime. * * FIXME: * Stack depths are probably not calculated correctly. * *---------------------------------------------------------------------- */ int TclCompileSwitchCmd(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 *tokenPtr; /* Pointer to tokens in command */ int numWords; /* Number of words in command */ Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */ enum {Switch_Exact, Switch_Glob} mode; /* What kind of switch are we doing? */ Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */ int foundDefault; /* Flag to indicate whether a "default" clause * is present. */ JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ int *fixupTargetArray; /* Array of places for fixups to point at. */ int fixupCount; /* Number of places to fix up. */ int contFixIndex; /* Where the first of the jumps due to a group * of continuation bodies starts, or -1 if * there aren't any. */ int contFixCount; /* Number of continuation bodies pointing to * the current (or next) real body. */ int savedStackDepth = envPtr->currStackDepth; int noCase; /* Has the -nocase flag been given? */ int foundMode = 0; /* Have we seen a mode flag yet? */ int i; /* * Only handle the following versions: * switch -- word {pattern body ...} * switch -exact -- word {pattern body ...} * switch -glob -- word {pattern body ...} * switch -- word simpleWordPattern simpleWordBody ... * switch -exact -- word simpleWordPattern simpleWordBody ... * switch -glob -- word simpleWordPattern simpleWordBody ... * When the mode is -glob, can also handle a -nocase flag. * * First off, we don't care how the command's word was generated; we're * compiling it anyway! So skip it... */ tokenPtr = TokenAfter(parsePtr->tokenPtr); numWords = parsePtr->numWords-1; /* * Check for options. There must be at least one, --, because without that * there is no way to statically avoid the problems you get from strings- * -to-be-matched that start with a - (the interpreted code falls apart if * it encounters them, so we punt if we *might* encounter them as that is * the easiest way of emulating the behaviour). */ noCase = 0; mode = Switch_Exact; for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) { register unsigned size = tokenPtr[1].size; register CONST char *chrs = tokenPtr[1].start; /* * We only process literal options, and we assume that -e, -g and -n * are unique prefixes of -exact, -glob and -nocase respectively (true * at time of writing). Note that -exact and -glob may only be given * at most once or we bail out (error case). */ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) { return TCL_ERROR; } if ((size <= 6) && !memcmp(chrs, "-exact", size)) { if (foundMode) { return TCL_ERROR; } mode = Switch_Exact; foundMode = 1; continue; } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) { if (foundMode) { return TCL_ERROR; } mode = Switch_Glob; foundMode = 1; continue; } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) { noCase = 1; continue; } else if ((size == 2) && !memcmp(chrs, "--", 2)) { break; } /* * The switch command has many flags we cannot compile at all (e.g. * all the RE-related ones) which we must have encountered. Either * that or we have run off the end. The action here is the same: punt * to interpreted version. */ return TCL_ERROR; } if (numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); numWords--; if (noCase && (mode == Switch_Exact)) { /* * Can't compile this case; no opcode for case-insensitive equality! */ return TCL_ERROR; } /* * The value to test against is going to always get pushed on the stack. * But not yet; we need to verify that the rest of the command is * compilable too. */ valueTokenPtr = tokenPtr; tokenPtr = TokenAfter(tokenPtr); numWords--; /* * Build an array of tokens for the matcher terms and script bodies. Note * that in the case of the quoted bodies, this is tricky as we cannot use * copies of the string from the input token for the generated tokens (it * causes a crash during exception handling). When multiple tokens are * available at this point, this is pretty easy. */ if (numWords == 1) { Tcl_DString bodyList; CONST char **argv = NULL; int isTokenBraced; CONST char *tokenStartPtr; /* * Test that we've got a suitable body list as a simple (i.e. braced) * word, and that the elements of the body are simple words too. This * is really rather nasty indeed. */ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } Tcl_DStringInit(&bodyList); Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size); if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &numWords, &argv) != TCL_OK) { Tcl_DStringFree(&bodyList); return TCL_ERROR; } Tcl_DStringFree(&bodyList); /* * Now we know what the switch arms are, we've got to see whether we * can synthesize tokens for the arms. First check whether we've got a * valid number of arms since we can do that now. */ if (numWords == 0 || numWords % 2) { ckfree((char *) argv); return TCL_ERROR; } bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords); bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); /* * Locate the start of the arms within the overall word. */ tokenStartPtr = tokenPtr[1].start; while (isspace(UCHAR(*tokenStartPtr))) { tokenStartPtr++; } if (*tokenStartPtr == '{') { tokenStartPtr++; isTokenBraced = 1; } else { isTokenBraced = 0; } for (i=0 ; i<numWords ; i++) { bodyTokenArray[i].type = TCL_TOKEN_TEXT; bodyTokenArray[i].start = tokenStartPtr; bodyTokenArray[i].size = strlen(argv[i]); bodyTokenArray[i].numComponents = 0; bodyToken[i] = bodyTokenArray+i; tokenStartPtr += bodyTokenArray[i].size; /* * Test to see if we have guessed the end of the word correctly; * if not, we can't feed the real string to the sub-compilation * engine, and we're then stuck and so have to punt out to doing * everything at runtime. */ if ((isTokenBraced && *(tokenStartPtr++) != '}') || (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size && !isspace(UCHAR(*tokenStartPtr)))) { ckfree((char *) argv); ckfree((char *) bodyToken); ckfree((char *) bodyTokenArray); return TCL_ERROR; } while (isspace(UCHAR(*tokenStartPtr))) { tokenStartPtr++; if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) { break; } } if (*tokenStartPtr == '{') { tokenStartPtr++; isTokenBraced = 1; } else { isTokenBraced = 0; } } ckfree((char *)argv); /* * Check that we've parsed everything we thought we were going to * parse. If not, something odd is going on (I believe it is possible * to defeat the code above) and we should bail out. */ if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) { ckfree((char *) bodyToken); ckfree((char *) bodyTokenArray); return TCL_ERROR; } } else if (numWords % 2 || numWords == 0) { /* * Odd number of words (>1) available, or no words at all available. * Both are error cases, so punt and let the interpreted-version * generate the error message. Note that the second case probably * should get caught earlier, but it's easy to check here again anyway * because it'd cause a nasty crash otherwise. */ return TCL_ERROR; } else { bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); bodyTokenArray = NULL; for (i=0 ; i<numWords ; i++) { /* * We only handle the very simplest case. Anything more complex is * a good reason to go to the interpreted case anyway due to * traces, etc. */ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr->numComponents != 1) { ckfree((char *) bodyToken); return TCL_ERROR; } bodyToken[i] = tokenPtr+1; tokenPtr = TokenAfter(tokenPtr); } } /* * Fall back to interpreted if the last body is a continuation (it's * illegal, but this makes the error happen at the right time). */ if (bodyToken[numWords-1]->size == 1 && bodyToken[numWords-1]->start[0] == '-') { ckfree((char *) bodyToken); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } return TCL_ERROR; } /* * Now we commit to generating code; the parsing stage per se is done. * First, we push the value we're matching against on the stack. */ TclCompileTokens(interp, valueTokenPtr+1, valueTokenPtr->numComponents, envPtr); /* * Generate a test for each arm. */ contFixIndex = -1; contFixCount = 0; fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * numWords); fixupTargetArray = (int *) ckalloc(sizeof(int) * numWords); memset(fixupTargetArray, 0, numWords * sizeof(int)); fixupCount = 0; foundDefault = 0; for (i=0 ; i<numWords ; i+=2) { int nextArmFixupIndex = -1; envPtr->currStackDepth = savedStackDepth + 1; if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 || memcmp(bodyToken[numWords-2]->start, "default", 7)) { /* * Generate the test for the arm. This code is slightly * inefficient, but much simpler than the first version. */ TclCompileTokens(interp, bodyToken[i], 1, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); switch (mode) { case Switch_Exact: TclEmitOpcode(INST_STR_EQ, envPtr); break; case Switch_Glob: TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); break; default: Tcl_Panic("unknown switch mode: %d", mode); } /* * In a fall-through case, we will jump on _true_ to the place * where the body starts (generated later, with guarantee of this * ensured earlier; the final body is never a fall-through). */ if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') { if (contFixIndex == -1) { contFixIndex = fixupCount; contFixCount = 0; } TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, fixupArray+contFixIndex+contFixCount); fixupCount++; contFixCount++; continue; } TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, fixupArray+fixupCount); nextArmFixupIndex = fixupCount; fixupCount++; } else { /* * Got a default clause; set a flag to inhibit the generation of * the jump after the body and the cleanup of the intermediate * value that we are switching against. * * Note that default clauses (which are always terminal clauses) * cannot be fall-through clauses as well, since the last clause * is never a fall-through clause (which we have already * verified). */ foundDefault = 1; } /* * Generate the body for the arm. This is guaranteed not to be a * fall-through case, but it might have preceding fall-through cases, * so we must process those first. */ if (contFixIndex != -1) { int j; for (j=0 ; j<contFixCount ; j++) { fixupTargetArray[contFixIndex+j] = CurrentOffset(envPtr); } contFixIndex = -1; } /* * Now do the actual compilation. Note that we do not use CompileBody * because we may have synthesized the tokens in a non-standard * pattern. */ TclEmitOpcode(INST_POP, envPtr); envPtr->currStackDepth = savedStackDepth + 1; TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); if (!foundDefault) { TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, fixupArray+fixupCount); fixupCount++; fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr); } } ckfree((char *) bodyToken); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } /* * Discard the value we are matching against unless we've had a default * clause (in which case it will already be gone due to the code at the * start of processing an arm, guaranteed) and make the result of the * command an empty string. */ if (!foundDefault) { TclEmitOpcode(INST_POP, envPtr); PushLiteral(envPtr, "", 0); } /* * Do jump fixups for arms that were executed. First, fill in the jumps * of all jumps that don't point elsewhere to point to here. */ for (i=0 ; i<fixupCount ; i++) { if (fixupTargetArray[i] == 0) { fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart; } } /* * Now scan backwards over all the jumps (all of which are forward jumps) * doing each one. When we do one and there is a size changes, we must * scan back over all the previous ones and see if they need adjusting * before proceeding with further jump fixups (the interleaved nature of * all the jumps makes this impossible to do without nested loops). */ for (i=fixupCount-1 ; i>=0 ; i--) { if (TclFixupForwardJump(envPtr, &fixupArray[i], fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) { int j; for (j=i-1 ; j>=0 ; j--) { if (fixupTargetArray[j] > fixupArray[i].codeOffset) { fixupTargetArray[j] += 3; } } } } ckfree((char *) fixupArray); ckfree((char *) fixupTargetArray); envPtr->currStackDepth = savedStackDepth + 1; 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_ERROR. * * 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_ERROR; } numWords = parsePtr->numWords; varTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i += 2) { /* * Skip non-literals. */ if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { continue; } varName = varTokenPtr[1].start; tail = varName + varTokenPtr[1].size - 1; /* * Skip if it looks like it might be an array or an empty string. */ 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 = TokenAfter(varTokenPtr); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclCompileWhileCmd -- * * Procedure called to compile the "while" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "while" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileWhileCmd(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 *testTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; int testCodeOffset, bodyCodeOffset, jumpDist; int range, code; 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) { return TCL_ERROR; } /* * If the test expression requires substitutions, don't compile the while * command inline. E.g., the expression might cause the loop to never * execute or execute forever, as in "while "$x < 5" {}". * * Bail out also if the body expression requires substitutions in order to * insure correct behaviour [Bug 219166] */ testTokenPtr = TokenAfter(parsePtr->tokenPtr); bodyTokenPtr = TokenAfter(testTokenPtr); if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { return TCL_ERROR; } /* * 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; flag it so that we generate a more * efficient body. */ 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. */ range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); /* * Jump to the evaluation of the condition. This code uses the "loop * rotation" optimisation (which eliminates one branch from the loop). * "while cond body" produces then: * goto A * B: body : bodyCodeOffset * A: cond -> result : testCodeOffset, continueOffset * if (result) goto B * * The infinite loop "while 1 body" produces: * B: body : all three offsets here * goto B */ if (loopMayEnd) { TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); testCodeOffset = 0; /* avoid compiler warning */ } else { testCodeOffset = CurrentOffset(envPtr); } /* * Compile the loop body. */ bodyCodeOffset = ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); /* * Compile the test expression then emit the conditional jump that * terminates the while. We already know it's a simple word. */ if (loopMayEnd) { testCodeOffset = CurrentOffset(envPtr); jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { bodyCodeOffset += 3; testCodeOffset += 3; } envPtr->currStackDepth = savedStackDepth; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); } } else { jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); } else { TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr); } } /* * Set the loop's body, continue and break offsets. */ envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; ExceptionRangeTarget(envPtr, range, breakOffset); /* * The while command's result is an empty string. */ pushResult: envPtr->currStackDepth = savedStackDepth; PushLiteral(envPtr, "", 0); envPtr->exceptDepth--; return TCL_OK; } /* *---------------------------------------------------------------------- * * PushVarName -- * * Procedure used in the compiling where pushing a variable name is * necessary (append, lappend, set). * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "set" command at * runtime. * *---------------------------------------------------------------------- */ static int PushVarName(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; /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX */ int *localIndexPtr; /* must not be NULL */ int *simpleVarNamePtr; /* must not be NULL */ int *isScalarPtr; /* must not be NULL */ { register CONST char *p; CONST char *name, *elName; register int i, n; int nameChars, elNameChars, simpleVarName, localIndex; Tcl_Token *elemTokenPtr = NULL; int elemTokenCount = 0; int allocedTokens = 0; int removedParen = 0; /* * 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. */ simpleVarName = 0; name = elName = NULL; nameChars = elNameChars = 0; localIndex = -1; /* * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether * curly braces surround the variable name. This really matters for array * elements to handle things like * set {x($foo)} 5 * which raises an undefined var error if we are not careful here. */ if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && (varTokenPtr->start[0] != '{')) { /* * A simple variable name. Divide it up into "name" and "elName" * strings. If it is not a local variable, look it up at runtime. */ simpleVarName = 1; name = varTokenPtr[1].start; nameChars = varTokenPtr[1].size; if (name[nameChars-1] == ')') { /* * last char is ')' => potential array reference. */ for (i=0,p=name ; i<nameChars ; i++,p++) { if (*p == '(') { elName = p + 1; elNameChars = nameChars - i - 2; nameChars = i; break; } } if ((elName != NULL) && elNameChars) { /* * An array element, the element name is a simple string: * assemble the corresponding token. */ elemTokenPtr = (Tcl_Token *) ckalloc(sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; elemTokenPtr->size = elNameChars; elemTokenPtr->numComponents = 0; elemTokenCount = 1; } } } else if (((n = varTokenPtr->numComponents) > 1) && (varTokenPtr[1].type == TCL_TOKEN_TEXT) && (varTokenPtr[n].type == TCL_TOKEN_TEXT) && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { /* * Check for parentheses inside first token */ simpleVarName = 0; for (i = 0, p = varTokenPtr[1].start; i < varTokenPtr[1].size; i++, p++) { if (*p == '(') { simpleVarName = 1; break; } } if (simpleVarName) { int remainingChars; /* * Check the last token: if it is just ')', do not count it. * Otherwise, remove the ')' and flag so that it is restored at * the end. */ if (varTokenPtr[n].size == 1) { --n; } else { --varTokenPtr[n].size; removedParen = n; } name = varTokenPtr[1].start; nameChars = p - varTokenPtr[1].start; elName = p + 1; remainingChars = (varTokenPtr[2].start - p) - 1; elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2; if (remainingChars) { /* * Make a first token with the extra characters in the first * token. */ elemTokenPtr = (Tcl_Token *) ckalloc(n * sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; elemTokenPtr->size = remainingChars; elemTokenPtr->numComponents = 0; elemTokenCount = n; /* * Copy the remaining tokens. */ memcpy((void *) (elemTokenPtr+1), (void *) (&varTokenPtr[2]), (n-1) * sizeof(Tcl_Token)); } else { /* * Use the already available tokens. */ elemTokenPtr = &varTokenPtr[2]; elemTokenCount = n - 1; } } } if (simpleVarName) { /* * See whether name has any namespace separators (::'s). */ int hasNsQualifiers = 0; for (i = 0, p = name; i < nameChars; i++, p++) { if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { hasNsQualifiers = 1; break; } } /* * Look up the var name's index in the array of local vars in the proc * frame. If retrieving the var's value and it doesn't already exist, * push its name and look it up at runtime. */ if ((envPtr->procPtr != NULL) && !hasNsQualifiers) { localIndex = TclFindCompiledLocal(name, nameChars, /*create*/ flags & TCL_CREATE_VAR, /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY), envPtr->procPtr); if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { /* we'll push the name */ localIndex = -1; } } if (localIndex < 0) { PushLiteral(envPtr, name, nameChars); } /* * Compile the element script, if any. */ if (elName != NULL) { if (elNameChars) { TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { PushLiteral(envPtr, "", 0); } } } else { /* * The var name isn't simple: compile and push it. */ TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); } if (removedParen) { ++varTokenPtr[removedParen].size; } if (allocedTokens) { ckfree((char *) elemTokenPtr); } *localIndexPtr = localIndex; *simpleVarNamePtr = simpleVarName; *isScalarPtr = (elName == NULL); return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclCompExpr.c.
|
| | | | | < < < < < < < < < < < < < < < | | | | < | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 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 | /* * 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.25.2.4 2005/08/22 03:49:39 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * Boolean variable that controls whether expression compilation tracing is * enabled. */ #ifdef TCL_COMPILE_DEBUG static int traceExprComp = 0; #endif /* TCL_COMPILE_DEBUG */ /* * The ExprInfo structure describes the state of compiling an expression. A * pointer to an ExprInfo record is passed among the routines in 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; /* * Definitions of numeric codes representing each expression operator. The * order of these must match the entries in the operatorTable below. Also the * codes for the relational operators (OP_LESS, OP_GREATER, OP_LE, OP_GE, * OP_EQ, and OP_NE) must be consecutive and in that order. Note that OP_PLUS * and OP_MINUS represent both unary and binary operators. */ #define OP_MULT 0 #define OP_DIVIDE 1 #define OP_MOD 2 #define OP_PLUS 3 #define OP_MINUS 4 |
︙ | ︙ | |||
111 112 113 114 115 116 117 | * Ignored if numOperands is 0. */ } OperatorDesc; static OperatorDesc operatorTable[] = { {"*", 2, INST_MULT}, {"/", 2, INST_DIV}, {"%", 2, INST_MOD}, | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | * 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}, {"<", 2, INST_LT}, {">", 2, INST_GT}, {"<=", 2, INST_LE}, {">=", 2, INST_GE}, |
︙ | ︙ | |||
138 139 140 141 142 143 144 | {"**", 2, INST_EXPON}, {"in", 2, INST_LIST_IN}, {"ni", 2, INST_LIST_NOT_IN}, {NULL} }; /* | | | | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | {"**", 2, INST_EXPON}, {"in", 2, INST_LIST_IN}, {"ni", 2, INST_LIST_NOT_IN}, {NULL} }; /* * Hashtable used to map the names of expression operators to the index of * their OperatorDesc description. */ static Tcl_HashTable opHashTable; /* * Declarations for local procedures to this file: */ |
︙ | ︙ | |||
172 173 174 175 176 177 178 | * Macro used to debug the execution of the expression compiler. */ #ifdef TCL_COMPILE_DEBUG #define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \ if (traceExprComp) { \ fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \ | | | | | | | | 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 | * Macro used to debug the execution of the expression compiler. */ #ifdef TCL_COMPILE_DEBUG #define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \ if (traceExprComp) { \ fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \ (exprLength), (exprBytes), (tokenLength), (tokenBytes)); \ } #else #define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) #endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- * * TclCompileExpr -- * * This procedure compiles a string containing a Tcl expression into Tcl * bytecodes. This procedure is the top-level interface to the the * expression compilation module, and is used by such public procedures * as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong, Tcl_ExprDouble, * Tcl_ExprBoolean, and Tcl_ExprBooleanObj. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR * on failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: |
︙ | ︙ | |||
215 216 217 218 219 220 221 | { ExprInfo info; Tcl_Parse parse; Tcl_HashEntry *hPtr; int new, i, code; /* | | | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | { ExprInfo info; Tcl_Parse parse; Tcl_HashEntry *hPtr; int new, i, code; /* * If this is the first time we've been called, initialize the table of * expression operators. */ if (numBytes < 0) { numBytes = (script? strlen(script) : 0); } if (!opTableInitialized) { Tcl_MutexLock(&opMutex); |
︙ | ︙ | |||
239 240 241 242 243 244 245 | } opTableInitialized = 1; } Tcl_MutexUnlock(&opMutex); } /* | | | | | | | | < | | | | < < | | | | | 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 | } opTableInitialized = 1; } Tcl_MutexUnlock(&opMutex); } /* * Initialize the structure containing information abvout this expression * compilation. */ info.interp = interp; info.parsePtr = &parse; info.expr = script; info.lastChar = (script + numBytes); info.hasOperators = 0; /* * Parse the expression then compile it. */ code = Tcl_ParseExpr(interp, script, numBytes, &parse); if (code != TCL_OK) { goto done; } code = CompileSubExpr(parse.tokenPtr, &info, envPtr); if (code != TCL_OK) { Tcl_FreeParse(&parse); goto done; } if (!info.hasOperators) { /* * Attempt to convert the primary's object to an int or double. This * is done in order to support Tcl's policy of interpreting operands * if at all possible as first integers, else floating-point numbers. */ TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } Tcl_FreeParse(&parse); done: return code; } /* *---------------------------------------------------------------------- * * TclFinalizeCompilation -- * * Clean up the compilation environment so it can later be properly * reinitialized. This procedure is called by Tcl_Finalize(). * * Results: * None. * * Side effects: * Cleans up the compilation environment. At the moment, just the table * of expression operators is freed. * *---------------------------------------------------------------------- */ void TclFinalizeCompilation() { Tcl_MutexLock(&opMutex); if (opTableInitialized) { Tcl_DeleteHashTable(&opHashTable); opTableInitialized = 0; } Tcl_MutexUnlock(&opMutex); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
333 334 335 336 337 338 339 | * Adds instructions to envPtr to evaluate the subexpression. * *---------------------------------------------------------------------- */ static int CompileSubExpr(exprTokenPtr, infoPtr, envPtr) | | | | | | | < | | | | | | | | | | | | | | | | < | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | < | | | | | | | | | | | | | | < | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | 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 | * Adds instructions to envPtr to evaluate the subexpression. * *---------------------------------------------------------------------- */ static int CompileSubExpr(exprTokenPtr, infoPtr, envPtr) Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token to * compile. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Interp *interp = infoPtr->interp; Tcl_Token *tokenPtr, *endPtr, *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) { Tcl_Panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n", exprTokenPtr->type); } code = TCL_OK; /* * Switch on the type of the first token after the subexpression token. * After processing it, advance tokenPtr to point just after the * subexpression's last token. */ tokenPtr = exprTokenPtr+1; TRACE(exprTokenPtr->start, exprTokenPtr->size, tokenPtr->start, tokenPtr->size); switch (tokenPtr->type) { case TCL_TOKEN_WORD: TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); 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: TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); tokenPtr += 1; break; case TCL_TOKEN_VARIABLE: TclCompileTokens(interp, tokenPtr, 1, envPtr); tokenPtr += (tokenPtr->numComponents + 1); break; case TCL_TOKEN_SUB_EXPR: code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { 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. */ if (opDescPtr->numOperands > 0) { tokenPtr++; code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } tokenPtr += (tokenPtr->numComponents + 1); if (opDescPtr->numOperands == 2) { code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } tokenPtr += (tokenPtr->numComponents + 1); } TclEmitOpcode(opDescPtr->instruction, envPtr); infoPtr->hasOperators = 1; break; } /* * The operator requires special treatment, and is either "+" or "-", * or one of "&&", "||" or "?". */ switch (opIndex) { case OP_PLUS: case OP_MINUS: tokenPtr++; code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } tokenPtr += (tokenPtr->numComponents + 1); /* * Check whether the "+" or "-" is unary. */ afterSubexprPtr = exprTokenPtr + exprTokenPtr->numComponents+1; if (tokenPtr == afterSubexprPtr) { TclEmitOpcode(((opIndex==OP_PLUS)? INST_UPLUS : INST_UMINUS), envPtr); break; } /* * The "+" or "-" is binary. */ code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } tokenPtr += (tokenPtr->numComponents + 1); TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB), envPtr); break; case OP_LAND: case OP_LOR: code = CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, &endPtr); if (code != TCL_OK) { goto done; } tokenPtr = endPtr; break; case OP_QUESTY: code = CompileCondExpr(exprTokenPtr, infoPtr, envPtr, &endPtr); if (code != TCL_OK) { goto done; } tokenPtr = endPtr; break; default: Tcl_Panic("CompileSubExpr: unexpected operator %d requiring special treatment\n", opIndex); } /* end switch on operator requiring special treatment */ infoPtr->hasOperators = 1; break; default: Tcl_Panic("CompileSubExpr: unexpected token type %d\n", tokenPtr->type); } /* * Verify that the subexpression token had the required number of * subtokens: that we've advanced tokenPtr just beyond the subexpression's * last token. For example, a "*" subexpression must contain the tokens * for exactly two operands. */ if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) { LogSyntaxError(infoPtr); code = TCL_ERROR; } done: return code; } /* *---------------------------------------------------------------------- * * CompileLandOrLorExpr -- * * This procedure compiles a Tcl logical and ("&&") or logical or ("||") * subexpression. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR * on failure. If TCL_OK is returned, a pointer to the token just after * the last one in the subexpression is stored at the address in * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. * *---------------------------------------------------------------------- */ static int CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token * containing the "&&" or "||" operator. */ int opIndex; /* A code describing the expression operator: * either OP_LAND or OP_LOR. */ 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. */ { JumpFixup shortCircuitFixup;/* Used to fix up the short circuit jump after * the first subexpression. */ JumpFixup shortCircuitFixup2; /* Used to fix up the second jump to the * short-circuit target. */ JumpFixup endFixup; /* Used to fix up jump to the end. */ Tcl_Token *tokenPtr; int code; int savedStackDepth = envPtr->currStackDepth; /* * Emit code for the first operand. */ |
︙ | ︙ | |||
619 620 621 622 623 624 625 | */ code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } tokenPtr += (tokenPtr->numComponents + 1); | | | | | | | | | | 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 | */ code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } tokenPtr += (tokenPtr->numComponents + 1); /* * The result is the boolean value of the second operand. We code this in * a somewhat contorted manner to be able to reuse the shortCircuit value * and save one INST_JUMP. */ TclEmitForwardJump(envPtr, ((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP), &shortCircuitFixup2); if (opIndex == OP_LAND) { TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr); } else { TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr); } TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); /* * Fixup the short-circuit jumps and push the shortCircuit value. Note * that shortCircuitFixup2 is always a short jump. */ TclFixupForwardJumpToHere(envPtr, &shortCircuitFixup2, 127); if (TclFixupForwardJumpToHere(envPtr, &shortCircuitFixup, 127)) { /* * shortCircuit jump grown by 3 bytes: update endFixup. */ endFixup.codeOffset += 3; } if (opIndex == OP_LAND) { TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr); } else { TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr); } TclFixupForwardJumpToHere(envPtr, &endFixup, 127); *endPtrPtr = tokenPtr; done: envPtr->currStackDepth = savedStackDepth + 1; return code; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
693 694 695 696 697 698 699 | static int CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token * containing the "?" operator. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ CompileEnv *envPtr; /* Holds resulting instructions. */ | | | | | | | | | | | | < | 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 | static int CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token * containing the "?" operator. */ 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. */ { JumpFixup jumpAroundThenFixup, jumpAroundElseFixup; /* Used to update or replace one-byte jumps * around the then and else expressions when * their target PCs are determined. */ Tcl_Token *tokenPtr; int elseCodeOffset, dist, code; int savedStackDepth = envPtr->currStackDepth; /* * Emit code for the test. */ tokenPtr = exprTokenPtr+2; code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } tokenPtr += (tokenPtr->numComponents + 1); /* * Emit the jump to the "else" expression if the test was false. */ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup); /* * Compile the "then" expression. Note that if a subexpression is only a * primary, we need to try to convert it to numeric. We do this to support * Tcl's policy of interpreting operands if at all possible as first * integers, else floating-point numbers. */ infoPtr->hasOperators = 0; code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } tokenPtr += (tokenPtr->numComponents + 1); if (!infoPtr->hasOperators) { TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } /* * Emit an unconditional jump around the "else" condExpr. */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpAroundElseFixup); /* * Compile the "else" expression. */ envPtr->currStackDepth = savedStackDepth; elseCodeOffset = (envPtr->codeNext - envPtr->codeStart); |
︙ | ︙ | |||
770 771 772 773 774 775 776 | * Fix up the second jump around the "else" expression. */ dist = (envPtr->codeNext - envPtr->codeStart) - jumpAroundElseFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) { /* | | | | | | | | 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 | * Fix up the second jump around the "else" expression. */ dist = (envPtr->codeNext - envPtr->codeStart) - jumpAroundElseFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) { /* * Update the else expression's starting code offset since it moved * down 3 bytes too. */ elseCodeOffset += 3; } /* * Fix up the first jump to the "else" expression if the test was false. */ dist = (elseCodeOffset - jumpAroundThenFixup.codeOffset); TclFixupForwardJump(envPtr, &jumpAroundThenFixup, dist, 127); *endPtrPtr = tokenPtr; done: envPtr->currStackDepth = savedStackDepth + 1; return code; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
820 821 822 823 824 825 826 | 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. */ | | | | | | < < > | > | > > < | < > | < < < < < | < < < | < | > | < > < < | < | < < < | | < > | | | < < < < < | < < < < < < < < < < | < < < < < < < < | < < < | < < | < < > | | 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 | 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. */ { Tcl_DString cmdName; int objIndex; Tcl_Token *tokenPtr, *afterSubexprPtr; int argCount; int code = TCL_OK; /* * Prepend "tcl::mathfunc::" to the function name, to produce the name of * a command that evaluates the function. Push that command name on the * stack, in a literal registered to the namespace so that resolution can * be cached. */ Tcl_DStringInit(&cmdName); Tcl_DStringAppend(&cmdName, "tcl::mathfunc::", -1); Tcl_DStringAppend(&cmdName, funcName, -1); objIndex = TclRegisterNewNSLiteral(envPtr, Tcl_DStringValue(&cmdName), Tcl_DStringLength(&cmdName)); TclEmitPush(objIndex, envPtr); Tcl_DStringFree(&cmdName); /* * Compile any arguments for the function. */ argCount = 1; tokenPtr = exprTokenPtr+2; afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1); while (tokenPtr != afterSubexprPtr) { ++argCount; code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { return code; } tokenPtr += (tokenPtr->numComponents + 1); } /* Invoke the function */ if (argCount < 255) { TclEmitInstInt1(INST_INVOKE_STK1, argCount, envPtr); } else { TclEmitInstInt4(INST_INVOKE_STK4, argCount, envPtr); } *endPtrPtr = afterSubexprPtr; return TCL_OK; } /* *---------------------------------------------------------------------- * * LogSyntaxError -- * |
︙ | ︙ | |||
940 941 942 943 944 945 946 | static void LogSyntaxError(infoPtr) ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ { Tcl_Obj *result = | | | > > > > > > > > | 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 | static void LogSyntaxError(infoPtr) ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ { Tcl_Obj *result = Tcl_NewStringObj("syntax error in expression \"", -1); TclAppendLimitedToObj(result, infoPtr->expr, (int)(infoPtr->lastChar - infoPtr->expr), 60, ""); Tcl_AppendToObj(result, "\"", -1); Tcl_SetObjResult(infoPtr->interp, result); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclCompile.c.
|
| | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | /* * 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.78.2.7 2005/08/02 18:15:19 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * Table of all AuxData types. */ static Tcl_HashTable auxDataTypeTable; static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(tableMutex) /* * Variable that controls whether compilation tracing is enabled and, if so, |
︙ | ︙ | |||
38 39 40 41 42 43 44 | #ifdef TCL_COMPILE_DEBUG int tclTraceCompile = 0; static int traceInitialized = 0; #endif /* * A table describing the Tcl bytecode instructions. Entries in this table | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | > | | | > | | | | | | | | | | | | > | | | | | | | | | | | | | > | > | | | | | | | | | | | | | | > | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | | < | | < | | < | < | | | | | < | | | | | | | | | | | | | | | | | 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 | #ifdef TCL_COMPILE_DEBUG int tclTraceCompile = 0; static int traceInitialized = 0; #endif /* * A table describing the Tcl bytecode instructions. Entries in this table * must correspond to the instruction opcode definitions in tclCompile.h. The * names "op1" and "op4" refer to an instruction's one or four byte first * operand. Similarly, "stktop" and "stknext" refer to the topmost 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 */ {"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] */ {"pop", 1, -1, 0, {OPERAND_NONE}}, /* Pop the topmost stack object */ {"dup", 1, +1, 0, {OPERAND_NONE}}, /* Duplicate the topmost stack object and push the result */ {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Concatenate the top op1 items and push result */ {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */ {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */ {"evalStk", 1, 0, 0, {OPERAND_NONE}}, /* Evaluate command in stktop using Tcl_EvalObj. */ {"exprStk", 1, 0, 0, {OPERAND_NONE}}, /* Execute expression in stktop using Tcl_ExprStringObj. */ {"loadScalar1", 2, 1, 1, {OPERAND_LVT1}}, /* Load scalar variable at index op1 <= 255 in call frame */ {"loadScalar4", 5, 1, 1, {OPERAND_LVT4}}, /* Load scalar variable at index op1 >= 256 in call frame */ {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}}, /* Load scalar variable; scalar's name is stktop */ {"loadArray1", 2, 0, 1, {OPERAND_LVT1}}, /* Load array element; array at slot op1<=255, element is stktop */ {"loadArray4", 5, 0, 1, {OPERAND_LVT4}}, /* Load array element; array at slot op1 > 255, element is stktop */ {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}}, /* Load array element; element is stktop, array name is stknext */ {"loadStk", 1, 0, 0, {OPERAND_NONE}}, /* Load general variable; unparsed variable name is stktop */ {"storeScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Store scalar variable at op1<=255 in frame; value is stktop */ {"storeScalar4", 5, 0, 1, {OPERAND_LVT4}}, /* Store scalar variable at op1 > 255 in frame; value is stktop */ {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}}, /* Store scalar; value is stktop, scalar name is stknext */ {"storeArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Store array element; array at op1<=255, value is top then elem */ {"storeArray4", 5, -1, 1, {OPERAND_LVT4}}, /* Store array element; array at op1>=256, value is top then elem */ {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Store array element; value is stktop, then elem, array names */ {"storeStk", 1, -1, 0, {OPERAND_NONE}}, /* Store general variable; value is stktop, then unparsed name */ {"incrScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}}, /* Incr scalar; incr amount is stktop, scalar's name is stknext */ {"incrArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Incr array elem; arr at slot op1<=255, amount is top then elem */ {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Incr array element; amount is top then elem then array names */ {"incrStk", 1, -1, 0, {OPERAND_NONE}}, /* Incr general variable; amount is stktop then unparsed var name */ {"incrScalar1Imm", 3, +1, 2, {OPERAND_LVT1, OPERAND_INT1}}, /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */ {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}}, /* Incr scalar; scalar name is stktop; incr amount is op1 */ {"incrArray1Imm", 3, 0, 2, {OPERAND_LVT1, OPERAND_INT1}}, /* Incr array elem; array at slot op1 <= 255, elem is stktop, * amount is 2nd operand byte */ {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}}, /* Incr array element; elem is top then array name, amount is op1 */ {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, /* Incr general variable; unparsed name is top, amount is op1 */ {"jump1", 2, 0, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) */ {"jump4", 5, 0, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) */ {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) if stktop expr object is true */ {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) if stktop expr object is true */ {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) if stktop expr object is false */ {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ {"lor", 1, -1, 0, {OPERAND_NONE}}, /* Logical or: push (stknext || stktop) */ {"land", 1, -1, 0, {OPERAND_NONE}}, /* Logical and: push (stknext && stktop) */ {"bitor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise or: push (stknext | stktop) */ {"bitxor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise xor push (stknext ^ stktop) */ {"bitand", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise and: push (stknext & stktop) */ {"eq", 1, -1, 0, {OPERAND_NONE}}, /* Equal: push (stknext == stktop) */ {"neq", 1, -1, 0, {OPERAND_NONE}}, /* Not equal: push (stknext != stktop) */ {"lt", 1, -1, 0, {OPERAND_NONE}}, /* Less: push (stknext < stktop) */ {"gt", 1, -1, 0, {OPERAND_NONE}}, /* Greater: push (stknext || stktop) */ {"le", 1, -1, 0, {OPERAND_NONE}}, /* Logical or: push (stknext || stktop) */ {"ge", 1, -1, 0, {OPERAND_NONE}}, /* Logical or: push (stknext || stktop) */ {"lshift", 1, -1, 0, {OPERAND_NONE}}, /* Left shift: push (stknext << stktop) */ {"rshift", 1, -1, 0, {OPERAND_NONE}}, /* Right shift: push (stknext >> stktop) */ {"add", 1, -1, 0, {OPERAND_NONE}}, /* Add: push (stknext + stktop) */ {"sub", 1, -1, 0, {OPERAND_NONE}}, /* Sub: push (stkext - stktop) */ {"mult", 1, -1, 0, {OPERAND_NONE}}, /* Multiply: push (stknext * stktop) */ {"div", 1, -1, 0, {OPERAND_NONE}}, /* Divide: push (stknext / stktop) */ {"mod", 1, -1, 0, {OPERAND_NONE}}, /* Mod: push (stknext % stktop) */ {"uplus", 1, 0, 0, {OPERAND_NONE}}, /* Unary plus: push +stktop */ {"uminus", 1, 0, 0, {OPERAND_NONE}}, /* Unary minus: push -stktop */ {"bitnot", 1, 0, 0, {OPERAND_NONE}}, /* Bitwise not: push ~stktop */ {"not", 1, 0, 0, {OPERAND_NONE}}, /* Logical not: push !stktop */ {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}}, /* Call builtin math function with index op1; any args are on stk */ {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */ {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, /* Try converting stktop to first int then double if possible. */ {"break", 1, 0, 0, {OPERAND_NONE}}, /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ {"continue", 1, 0, 0, {OPERAND_NONE}}, /* Skip to next iteration of closest enclosing loop; if none, return * TCL_CONTINUE code. */ {"foreach_start4", 5, 0, 1, {OPERAND_UINT4}}, /* Initialize execution of a foreach loop. Operand is aux data index * of the ForeachInfo structure for the foreach command. */ {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}}, /* "Step" or begin next iteration of foreach loop. Push 0 if to * terminate loop, else push 1. */ {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, /* Record start of catch with the operand's exception index. Push the * current stack depth onto a special catch stack. */ {"endCatch", 1, 0, 0, {OPERAND_NONE}}, /* End of last catch. Pop the bytecode interpreter's catch stack. */ {"pushResult", 1, +1, 0, {OPERAND_NONE}}, /* Push the interpreter's object result onto the stack. */ {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}}, /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as a new * object onto the stack. */ {"streq", 1, -1, 0, {OPERAND_NONE}}, /* Str Equal: push (stknext eq stktop) */ {"strneq", 1, -1, 0, {OPERAND_NONE}}, /* Str !Equal: push (stknext neq stktop) */ {"strcmp", 1, -1, 0, {OPERAND_NONE}}, /* Str Compare: push (stknext cmp stktop) */ {"strlen", 1, 0, 0, {OPERAND_NONE}}, /* Str Length: push (strlen stktop) */ {"strindex", 1, -1, 0, {OPERAND_NONE}}, /* Str Index: push (strindex stknext stktop) */ {"strmatch", 2, -1, 1, {OPERAND_INT1}}, /* Str Match: push (strmatch stknext stktop) opnd == nocase */ {"list", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* List: push (stk1 stk2 ... stktop) */ {"listIndex", 1, -1, 0, {OPERAND_NONE}}, /* List Index: push (listindex stknext stktop) */ {"listLength", 1, 0, 0, {OPERAND_NONE}}, /* List Len: push (listlength stktop) */ {"appendScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Append scalar variable at op1<=255 in frame; value is stktop */ {"appendScalar4", 5, 0, 1, {OPERAND_LVT4}}, /* Append scalar variable at op1 > 255 in frame; value is stktop */ {"appendArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Append array element; array at op1<=255, value is top then elem */ {"appendArray4", 5, -1, 1, {OPERAND_LVT4}}, /* Append array element; array at op1>=256, value is top then elem */ {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Append array element; value is stktop, then elem, array names */ {"appendStk", 1, -1, 0, {OPERAND_NONE}}, /* Append general variable; value is stktop, then unparsed name */ {"lappendScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Lappend scalar variable at op1<=255 in frame; value is stktop */ {"lappendScalar4", 5, 0, 1, {OPERAND_LVT4}}, /* Lappend scalar variable at op1 > 255 in frame; value is stktop */ {"lappendArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Lappend array element; array at op1<=255, value is top then elem */ {"lappendArray4", 5, -1, 1, {OPERAND_LVT4}}, /* Lappend array element; array at op1>=256, value is top then elem */ {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Lappend array element; value is stktop, then elem, array names */ {"lappendStk", 1, -1, 0, {OPERAND_NONE}}, /* Lappend general variable; value is stktop, then unparsed name */ {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* Lindex with generalized args, operand is number of stacked objs * used: (operand-1) entries from stktop are the indices; then list to * process. */ {"over", 5, +1, 1, {OPERAND_UINT4}}, /* Duplicate the arg-th element from top of stack (TOS=0) */ {"lsetList", 1, -2, 0, {OPERAND_NONE}}, /* Four-arg version of 'lset'. stktop is old value; next is new * element value, next is the index list; pushes new value */ {"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* Three- or >=5-arg version of 'lset', operand is number of stacked * objs: stktop is old value, next is new element value, next come * (operand-2) indices; pushes the new value. */ {"returnImm", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, /* Compiled [return], code, level are operands; options and result * are on the stack. */ {"expon", 1, -1, 0, {OPERAND_NONE}}, /* Binary exponentiation operator: push (stknext ** stktop) */ /* * NOTE: the stack effects of expandStkTop and invokeExpanded are wrong - * but it cannot be done right at compile time, the stack effect is only * known at run time. The value for invokeExpanded is estimated better at * compile time. * See the comments further down in this file, where INST_INVOKE_EXPANDED * is emitted. */ {"expandStart", 1, 0, 0, {OPERAND_NONE}}, /* Start of command with {expand}ed arguments */ {"expandStkTop", 5, 0, 1, {OPERAND_INT4}}, /* Expand the list at stacktop: push its elements on the stack */ {"invokeExpanded", 1, 0, 0, {OPERAND_NONE}}, /* Invoke the command marked by the last 'expandStart' */ {"listIndexImm", 5, 0, 1, {OPERAND_IDX4}}, /* List Index: push (lindex stktop op4) */ {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, /* List Range: push (lrange stktop op4 op4) */ {"startCommand", 5, 0, 1, {OPERAND_UINT4}}, /* Start of bytecoded command: op is the length of the cmd's code */ {"listIn", 1, -1, 0, {OPERAND_NONE}}, /* List containment: push [lsearch stktop stknext]>=0) */ {"listNotIn", 1, -1, 0, {OPERAND_NONE}}, /* List negated containment: push [lsearch stktop stknext]<0) */ {"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}}, /* Push the interpreter's return option dictionary as an object on the * stack. */ {"returnStk", 1, -2, 0, {OPERAND_NONE}}, /* Compiled [return]; options and result are on the stack, code and * level are in the options. */ {"dictGet", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* The top op4 words (min 1) are a key path into the dictionary just * below the keys on the stack, and all those values are replaced by * the value read out of that key-path (like [dict get]). * Stack: ... dict key1 ... keyN => ... value */ {"dictSet", 5, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, /* Update a dictionary value such that the keys are a path pointing to * the value. op4#1 = numKeys, op4#2 = LVTindex * Stack: ... key1 ... keyN value => ... newDict */ {"dictUnset", 5, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, /* Update a dictionary value such that the keys are not a path pointing * to any value. op4#1 = numKeys, op4#2 = LVTindex * Stack: ... key1 ... keyN => ... newDict */ {"dictIncrImm", 5, 0, 2, {OPERAND_INT4, OPERAND_LVT4}}, /* Update a dictionary value such that the value pointed to by key is * incremented by some value (or set to it if the key isn't in the * dictionary at all). op4#1 = incrAmount, op4#2 = LVTindex * Stack: ... key => ... newDict */ {"dictAppend", 5, -1, 1, {OPERAND_LVT4}}, /* Update a dictionary value such that the value pointed to by key has * some value string-concatenated onto it. op4 = LVTindex * Stack: ... key valueToAppend => ... newDict */ {"dictLappend", 5, -1, 1, {OPERAND_LVT4}}, /* Update a dictionary value such that the value pointed to by key has * some value list-appended onto it. op4 = LVTindex * Stack: ... key valueToAppend => ... newDict */ {"dictFirst", 5, +2, 1, {OPERAND_LVT4}}, /* Begin iterating over the dictionary, using the local scalar * indicated by op4 to hold the iterator state. If doneBool is true, * dictDone *must* be called later on. * Stack: ... dict => ... value key doneBool */ {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, /* Get the next iteration from the iterator in op4's local scalar. * Stack: ... => ... value key doneBool */ {"dictDone", 5, 0, 1, {OPERAND_LVT4}}, /* Terminate the iterator in op4's local scalar. */ {"dictUpdateStart", 5, -2, 1, {OPERAND_LVT4}}, /* Create the variables to mirror the state of the dictionary in the * variable referred to by the immediate argument. * Stack: ... keyList LVTindexList => ... * Note that the list of LVT indices is assumed to be the same length * as the keyList, and the indices should be only ever generated by the * compiler. */ {"dictUpdateEnd", 5, -2, 1, {OPERAND_LVT4}}, /* Reflect the state of local variables back to the state of the * dictionary in the variable referred to by the immediate argument. * Stack: ... keyList LVTindexList => ... * Same notes as in "dictUpdateStart" apply here. */ {0} }; /* * Prototypes for procedures defined later in this file: */ static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); static unsigned char * EncodeCmdLocMap _ANSI_ARGS_((CompileEnv *envPtr, ByteCode *codePtr, unsigned char *startPtr)); static void EnterCmdExtentData _ANSI_ARGS_((CompileEnv *envPtr, int cmdNumber, int numSrcBytes, int numCodeBytes)); static void EnterCmdStartData _ANSI_ARGS_((CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset)); static void FreeByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int GetCmdLocEncodingSize _ANSI_ARGS_(( CompileEnv *envPtr)); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats _ANSI_ARGS_((ByteCode *codePtr)); #endif /* TCL_COMPILE_STATS */ static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* * The structure below defines the bytecode Tcl object type by means of * procedures that can be invoked by generic object code. */ Tcl_ObjType tclByteCodeType = { "bytecode", /* name */ FreeByteCodeInternalRep, /* freeIntRepProc */ DupByteCodeInternalRep, /* dupIntRepProc */ (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ SetByteCodeFromAny /* setFromAnyProc */ }; /* *---------------------------------------------------------------------- * * TclSetByteCodeFromAny -- * * Part of the bytecode Tcl object type implementation. Attempts to * generate an byte code internal form for the Tcl object "objPtr" by * compiling its string representation. This function also takes a hook * procedure that will be invoked to perform any needed post processing * on the compilation results before generating byte codes. * * Results: * The return value is a standard Tcl object result. If an error occurs * during compilation, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * Frees the old internal representation. If no error occurs, then the * compiled code is stored as "objPtr"s bytecode representation. Also, if * debugging, initializes the "tcl_traceCompile" Tcl variable used to * trace compilations. * *---------------------------------------------------------------------- */ int TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) Tcl_Interp *interp; /* The interpreter for which the code is being * compiled. Must not be NULL. */ Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ CompileHookProc *hookProc; /* Procedure to invoke after compilation. */ ClientData clientData; /* Hook procedure private data. */ { #ifdef TCL_COMPILE_DEBUG Interp *iPtr = (Interp *) interp; #endif /*TCL_COMPILE_DEBUG*/ CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ LiteralTable *localTablePtr = &(compEnv.localLitTable); register AuxData *auxDataPtr; LiteralEntry *entryPtr; register int i; int length, result = TCL_OK; char *stringPtr; #ifdef TCL_COMPILE_DEBUG if (!traceInitialized) { if (Tcl_LinkVar(interp, "tcl_traceCompile", (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); } traceInitialized = 1; } #endif stringPtr = Tcl_GetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, stringPtr, length); TclCompileScript(interp, stringPtr, length, &compEnv); /* * Successful compilation. Add a "done" instruction at the end. */ TclEmitOpcode(INST_DONE, &compEnv); /* * Invoke the compilation hook procedure if one exists. */ if (hookProc) { result = (*hookProc)(interp, &compEnv, clientData); } /* * Change the object into a ByteCode object. Ownership of the literal * objects and aux data items is given to the ByteCode object. */ #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(&compEnv); #endif /*TCL_COMPILE_DEBUG*/ TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 2) { TclPrintByteCodeObj(interp, objPtr); } #endif /* TCL_COMPILE_DEBUG */ if (result != TCL_OK) { /* * Handle any error from the hookProc */ entryPtr = compEnv.literalArrayPtr; for (i = 0; i < compEnv.literalArrayNext; i++) { |
︙ | ︙ | |||
451 452 453 454 455 456 457 | if (auxDataPtr->type->freeProc != NULL) { auxDataPtr->type->freeProc(auxDataPtr->clientData); } auxDataPtr++; } } | < | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 | if (auxDataPtr->type->freeProc != NULL) { auxDataPtr->type->freeProc(auxDataPtr->clientData); } auxDataPtr++; } } /* * Free storage allocated during compilation. */ if (localTablePtr->buckets != localTablePtr->staticBuckets) { ckfree((char *) localTablePtr->buckets); } TclFreeCompileEnv(&compEnv); return result; } |
︙ | ︙ | |||
479 480 481 482 483 484 485 | * Results: * The return value is a standard Tcl object result. If an error occurs * during compilation, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * Frees the old internal representation. If no error occurs, then the | | | | | | | | | 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 | * Results: * The return value is a standard Tcl object result. If an error occurs * during compilation, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * Frees the old internal representation. If no error occurs, then the * compiled code is stored as "objPtr"s bytecode representation. Also, * if debugging, initializes the "tcl_traceCompile" Tcl variable used to * trace compilations. * *---------------------------------------------------------------------- */ static int SetByteCodeFromAny(interp, objPtr) Tcl_Interp *interp; /* The interpreter for which the code is being * compiled. Must not be NULL. */ Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ { return TclSetByteCodeFromAny(interp, objPtr, (CompileHookProc *) NULL, (ClientData) NULL); } /* *---------------------------------------------------------------------- * * DupByteCodeInternalRep -- * * Part of the bytecode Tcl object type implementation. However, it does * not copy the internal representation of a bytecode Tcl_Obj, but * instead leaves the new object untyped (with a NULL type pointer). * Code will be compiled for the new object only if necessary. * * Results: * None. * * Side effects: |
︙ | ︙ | |||
528 529 530 531 532 533 534 | } /* *---------------------------------------------------------------------- * * FreeByteCodeInternalRep -- * | | | | | | | < | | | 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 | } /* *---------------------------------------------------------------------- * * FreeByteCodeInternalRep -- * * Part of the bytecode Tcl object type implementation. Frees the storage * associated with a bytecode object's internal representation unless its * code is actively being executed. * * Results: * None. * * Side effects: * The bytecode object's internal rep is marked invalid and its code gets * freed unless the code is actively being executed. In that case the * cleanup is delayed until the last execution of the code completes. * *---------------------------------------------------------------------- */ static void FreeByteCodeInternalRep(objPtr) register Tcl_Obj *objPtr; /* Object whose internal rep to free. */ { register ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } objPtr->typePtr = NULL; objPtr->internalRep.otherValuePtr = NULL; |
︙ | ︙ | |||
572 573 574 575 576 577 578 | * object's ByteCode structure. It's called only when the structure's * reference count becomes zero. * * Results: * None. * * Side effects: | | | | | 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 | * object's ByteCode structure. It's called only when the structure's * reference count becomes zero. * * Results: * None. * * Side effects: * Frees objPtr's bytecode internal representation and sets its type and * objPtr->internalRep.otherValuePtr NULL. Also releases its literals and * frees its auxiliary data items. * *---------------------------------------------------------------------- */ void TclCleanupByteCode(codePtr) register ByteCode *codePtr; /* Points to the ByteCode to free. */ |
︙ | ︙ | |||
602 603 604 605 606 607 608 | statsPtr = &((Interp *) interp)->stats; statsPtr->numByteCodesFreed++; statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes; statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | 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 | statsPtr = &((Interp *) interp)->stats; statsPtr->numByteCodesFreed++; statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes; statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; statsPtr->currentLitBytes -= (double) codePtr->numLitObjects * sizeof(Tcl_Obj *); statsPtr->currentExceptBytes -= (double) codePtr->numExceptRanges * sizeof(ExceptionRange); statsPtr->currentAuxBytes -= (double) codePtr->numAuxDataItems * sizeof(AuxData); statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes; Tcl_GetTime(&destroyTime); lifetimeSec = destroyTime.sec - codePtr->createTime.sec; if (lifetimeSec > 2000) { /* avoid overflow */ lifetimeSec = 2000; } lifetimeMicroSec = 1000000 * lifetimeSec + (destroyTime.usec - codePtr->createTime.usec); log2 = TclLog2(lifetimeMicroSec); if (log2 > 31) { log2 = 31; } statsPtr->lifetimeCount[log2]++; } #endif /* TCL_COMPILE_STATS */ /* * A single heap object holds the ByteCode structure and its code, object, * command location, and auxiliary data arrays. This means we only need to * 1) decrement the ref counts of the LiteralEntry's in its literal array, * 2) call the free procs for the auxiliary data items, and 3) free the * ByteCode structure's heap object. * * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like * those generated from tbcload) is special, as they doesn't make use of * the global literal table. They instead maintain private references to * their literals which must be decremented. * * In order to insure a proper and efficient cleanup of the literal array * when it contains non-shared literals [Bug 983660], we also distinguish * the case of an interpreter being deleted (signaled by interp == NULL). * Also, as the interp deletion will remove the global literal table * anyway, we avoid the extra cost of updating it for each literal being * released. */ if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) || (interp == NULL)) { objArrayPtr = codePtr->objArrayPtr; for (i = 0; i < numLitObjects; i++) { objPtr = *objArrayPtr; if (objPtr) { Tcl_DecrRefCount(objPtr); } objArrayPtr++; } codePtr->numLitObjects = 0; } else { objArrayPtr = codePtr->objArrayPtr; for (i = 0; i < numLitObjects; i++) { /* * TclReleaseLiteral sets a ByteCode's object array entry NULL to * indicate that it has already freed the literal. */ objPtr = *objArrayPtr; if (objPtr != NULL) { TclReleaseLiteral(interp, objPtr); } objArrayPtr++; } } auxDataPtr = codePtr->auxDataArrayPtr; for (i = 0; i < numAuxDataItems; i++) { if (auxDataPtr->type->freeProc != NULL) { (auxDataPtr->type->freeProc)(auxDataPtr->clientData); } auxDataPtr++; } TclHandleRelease(codePtr->interpHandle); ckfree((char *) codePtr); } |
︙ | ︙ | |||
714 715 716 717 718 719 720 | * structure is initialized. */ register CompileEnv *envPtr; /* Points to the CompileEnv structure to * initialize. */ char *stringPtr; /* The source string to be compiled. */ int numBytes; /* Number of bytes in source string. */ { Interp *iPtr = (Interp *) interp; | | | | | | | | | | | | | 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 | * structure is initialized. */ register CompileEnv *envPtr; /* Points to the CompileEnv structure to * initialize. */ char *stringPtr; /* The source string to be compiled. */ int numBytes; /* Number of bytes in source string. */ { Interp *iPtr = (Interp *) interp; envPtr->iPtr = iPtr; envPtr->source = stringPtr; envPtr->numSrcBytes = numBytes; envPtr->procPtr = iPtr->compiledProcPtr; envPtr->numCommands = 0; envPtr->exceptDepth = 0; envPtr->maxExceptDepth = 0; envPtr->maxStackDepth = 0; envPtr->currStackDepth = 0; TclInitLiteralTable(&(envPtr->localLitTable)); envPtr->codeStart = envPtr->staticCodeSpace; envPtr->codeNext = envPtr->codeStart; envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES); envPtr->mallocedCodeArray = 0; envPtr->literalArrayPtr = envPtr->staticLiteralSpace; envPtr->literalArrayNext = 0; envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; envPtr->mallocedLiteralArray = 0; envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; envPtr->exceptArrayNext = 0; envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; envPtr->mallocedExceptArray = 0; envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; envPtr->mallocedCmdMap = 0; envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; envPtr->auxDataArrayNext = 0; envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; envPtr->mallocedAuxDataArray = 0; } /* *---------------------------------------------------------------------- * * TclFreeCompileEnv -- * * Free the storage allocated in a CompileEnv compilation environment * structure. * * Results: * None. * * Side effects: * Allocated storage in the CompileEnv structure is freed. Note that its * local literal table is not deleted and its literal objects are not * released. In addition, storage referenced by its auxiliary data items * is not freed. This is done so that, when compilation is successful, * "ownership" of these objects and aux data items is handed over to the * corresponding ByteCode structure. * *---------------------------------------------------------------------- */ void TclFreeCompileEnv(envPtr) register CompileEnv *envPtr; /* Points to the CompileEnv structure. */ |
︙ | ︙ | |||
799 800 801 802 803 804 805 | } /* *---------------------------------------------------------------------- * * TclWordKnownAtCompileTime -- * | | < | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TclWordKnownAtCompileTime -- * * Test whether the value of a token is completely known at compile time. * * Results: * Returns true if the tokenPtr argument points to a word value that is * completely known at compile time. Generally, values that are known at * compile time can be compiled to their values, while values that cannot * be known until substitution at runtime must be compiled to bytecode * instructions that perform that substitution. For several commands, * whether or not arguments are known at compile time determine whether * it is worthwhile to compile at all. * * Side effects: * When returning true, appends the known value of the word to the * unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL. * *---------------------------------------------------------------------- */ int TclWordKnownAtCompileTime(tokenPtr, valuePtr) Tcl_Token *tokenPtr; /* Points to Tcl_Token we should check */ |
︙ | ︙ | |||
844 845 846 847 848 849 850 | tokenPtr++; if (valuePtr != NULL) { tempPtr = Tcl_NewObj(); Tcl_IncrRefCount(tempPtr); } while (numComponents--) { switch (tokenPtr->type) { | | | | | | | | | < | | | | | | | | | | | 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 | tokenPtr++; if (valuePtr != NULL) { tempPtr = Tcl_NewObj(); Tcl_IncrRefCount(tempPtr); } while (numComponents--) { switch (tokenPtr->type) { case TCL_TOKEN_TEXT: if (tempPtr != NULL) { Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size); } break; case TCL_TOKEN_BS: if (tempPtr != NULL) { char utfBuf[TCL_UTF_MAX]; int length = Tcl_UtfBackslash(tokenPtr->start, NULL, utfBuf); Tcl_AppendToObj(tempPtr, utfBuf, length); } break; default: if (tempPtr != NULL) { Tcl_DecrRefCount(tempPtr); } return 0; } tokenPtr++; } if (valuePtr != NULL) { Tcl_AppendObjToObj(valuePtr, tempPtr); Tcl_DecrRefCount(tempPtr); } |
︙ | ︙ | |||
894 895 896 897 898 899 900 | * Adds instructions to envPtr to evaluate the script at runtime. * *---------------------------------------------------------------------- */ void TclCompileScript(interp, script, numBytes, envPtr) | | | | | | | | | | | 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 | * Adds instructions to envPtr to evaluate the script at runtime. * *---------------------------------------------------------------------- */ void TclCompileScript(interp, script, numBytes, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. Also * serves as context for finding and compiling * commands. May not be NULL. */ 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. */ 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; Tcl_DString ds; Tcl_DStringInit(&ds); if (numBytes < 0) { numBytes = strlen(script); } Tcl_ResetResult(interp); isFirstCmd = 1; if (envPtr->procPtr != NULL) { cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; } else { cmdNsPtr = NULL; /* use current NS */ } /* * Each iteration through the following loop compiles the next command * from the script. */ p = script; bytesLeft = numBytes; gotParse = 0; do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) { |
︙ | ︙ | |||
958 959 960 961 962 963 964 | Tcl_Parse subParse; int errorLine = 1; Tcl_IncrRefCount(returnCmd); Tcl_IncrRefCount(errInfo); Tcl_AppendToObj(errInfo, "\n while executing\n\"", -1); TclAppendLimitedToObj(errInfo, parse.commandStart, | | | | | 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 | Tcl_Parse subParse; int errorLine = 1; Tcl_IncrRefCount(returnCmd); Tcl_IncrRefCount(errInfo); Tcl_AppendToObj(errInfo, "\n while executing\n\"", -1); TclAppendLimitedToObj(errInfo, parse.commandStart, /* Drop the command terminator (";","]") if appropriate */ (parse.term == parse.commandStart + parse.commandSize - 1)? parse.commandSize - 1 : parse.commandSize, 153, NULL); Tcl_AppendToObj(errInfo, "\"", -1); Tcl_ListObjAppendElement(NULL, returnCmd, errInfo); for (p = envPtr->source; p != parse.commandStart; p++) { if (*p == '\n') { errorLine++; |
︙ | ︙ | |||
1009 1010 1011 1012 1013 1014 1015 | /* * Determine the actual length of the command. */ commandLength = parse.commandSize; if (parse.term == parse.commandStart + commandLength - 1) { /* | | | | | | | | | < | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | < > | | | < > | | | | | | | | | | | | | | | | | | < | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | < | | | | | | | | < | | < | | | | | | | | | | | | < | | | | | | | | | | | | 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 | /* * Determine the actual length of the command. */ commandLength = parse.commandSize; if (parse.term == parse.commandStart + commandLength - 1) { /* * The command terminator character (such as ; or ]) is the * last character in the parsed command. Reduce the length by * one so that the trace message doesn't include the * terminator character. */ commandLength -= 1; } #ifdef TCL_COMPILE_DEBUG /* * If tracing, print a line for each top level command compiled. */ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { fprintf(stdout, " Compiling: "); TclPrintSource(stdout, parse.commandStart, TclMin(commandLength, 55)); fprintf(stdout, "\n"); } #endif /* * Check whether expansion has been requested for any of the words */ for (wordIdx = 0, tokenPtr = parse.tokenPtr; wordIdx < parse.numWords; wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { expand = 1; TclEmitOpcode(INST_EXPAND_START, envPtr); break; } } envPtr->numCommands++; currCmdIndex = (envPtr->numCommands - 1); lastTopLevelCmdIndex = currCmdIndex; startCodeOffset = (envPtr->codeNext - envPtr->codeStart); EnterCmdStartData(envPtr, currCmdIndex, (parse.commandStart - envPtr->source), startCodeOffset); /* * Each iteration of the following loop compiles one word from the * command. */ for (wordIdx = 0, tokenPtr = parse.tokenPtr; wordIdx < parse.numWords; wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* * The word is not a simple string of characters. */ TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { TclEmitInstInt4(INST_EXPAND_STKTOP, envPtr->currStackDepth, envPtr); } continue; } /* * This is a simple string of literal characters (i.e. we know * it absolutely and can use it directly). If this is the * first word and the command has a compile procedure, let it * compile the command. */ if ((wordIdx == 0) && !expand) { /* * We copy the string before trying to find the command by * name. We used to modify the string in place, but this * is not safe because the name resolution handlers could * have side effects that rely on the unmodified string. */ Tcl_DStringSetLength(&ds, 0); Tcl_DStringAppend(&ds, tokenPtr[1].start,tokenPtr[1].size); 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)) { int savedNumCmds = envPtr->numCommands; unsigned int savedCodeNext = envPtr->codeNext - envPtr->codeStart; /* * Mark the start of the command; the proper bytecode * length will be updated later. There is no need to * do this for the first command in the compile env, * as the check is done before calling * TclExecuteByteCode(). Remark that we are compiling * the first cmd in the environment exactly when * (savedCodeNext == 0) */ if (savedCodeNext != 0) { TclEmitInstInt4(INST_START_CMD, 0, envPtr); } code = (cmdPtr->compileProc)(interp, &parse, envPtr); if (code == TCL_OK) { if (savedCodeNext != 0) { /* * Fix the bytecode length. */ unsigned char *fixPtr = envPtr->codeStart + savedCodeNext + 1; unsigned int fixLen = envPtr->codeNext - envPtr->codeStart - savedCodeNext; TclStoreInt4AtPtr(fixLen, fixPtr); } goto finishCommand; } else { /* * Restore numCommands and codeNext to their * correct values, removing any commands compiled * before the failure to produce bytecode got * reported. [Bugs 705406 and 735055] */ envPtr->numCommands = savedNumCmds; envPtr->codeNext = envPtr->codeStart+savedCodeNext; } } /* * No compile procedure so push the word. If the command * was found, push a CmdName object to reduce runtime * lookups. Avoid sharing this literal among different * namespaces to reduce shimmering. */ objIndex = TclRegisterNewNSLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); if (cmdPtr != NULL) { TclSetCmdNameObj(interp, envPtr->literalArrayPtr[objIndex].objPtr,cmdPtr); } if ((wordIdx == 0) && (parse.numWords == 1)) { /* * Single word script: unshare the command name to * avoid shimmering between bytecode and cmdName * representations [Bug 458361] */ TclHideLiteral(interp, envPtr, objIndex); } } else { objIndex = TclRegisterNewLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); } TclEmitPush(objIndex, envPtr); } /* * Emit an invoke instruction for the command. We skip this if a * compile procedure was found for the command. */ if (expand) { /* * The stack depth during argument expansion can only be * managed at runtime, as the number of elements in the * expanded lists is not known at compile time. We adjust * here the stack depth estimate so that it is correct after * the command with expanded arguments returns. * * The end effect of this command's invocation is that all the * words of the command are popped from the stack, and the * result is pushed: the stack top changes by (1-wordIdx). * * Note that the estimates are not correct while the command * is being prepared and run, INST_EXPAND_STKTOP is not * stack-neutral in general. */ TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); TclAdjustStackDepth((1-wordIdx), envPtr); } else if (wordIdx > 0) { if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); } else { TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); } } /* * Update the compilation environment structure and record the * offsets of the source and code for the command. */ finishCommand: EnterCmdExtentData(envPtr, currCmdIndex, commandLength, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); isFirstCmd = 0; } /* end if parse.numWords > 0 */ /* * Advance to the next command in the script. */ next = parse.commandStart + parse.commandSize; bytesLeft -= (next - p); p = next; Tcl_FreeParse(&parse); gotParse = 0; } while (bytesLeft > 0); /* * If the source script yielded no instructions (e.g., if it was empty), * push an empty string as the command's result. * * WARNING: push an unshared object! If the script being compiled is a * shared empty string, it will otherwise be self-referential and cause * difficulties with literal management [Bugs 467523, 983660]. We used to * have special code in TclReleaseLiteral to handle this particular * self-reference, but now opt for avoiding its creation altogether. */ if (envPtr->codeNext == entryCodeNext) { TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr); } envPtr->numSrcBytes = (p - script); Tcl_DStringFree(&ds); } /* *---------------------------------------------------------------------- * * TclCompileTokens -- * * Given an array of tokens parsed from a Tcl command (e.g., the tokens * that make up a word) this procedure emits instructions to evaluate the * tokens and concatenate their values to form a single result value on * the interpreter's runtime evaluation stack. * * Results: * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. * * Side effects: * Instructions are added to envPtr to push and evaluate the tokens at * runtime. * *---------------------------------------------------------------------- */ void TclCompileTokens(interp, tokenPtr, count, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens to * compile. */ 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; unsigned char *entryCodeNext = envPtr->codeNext; Tcl_DStringInit(&textBuffer); numObjsToConcat = 0; for ( ; count > 0; count--, tokenPtr++) { switch (tokenPtr->type) { case TCL_TOKEN_TEXT: Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size); break; case TCL_TOKEN_BS: length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, buffer); Tcl_DStringAppend(&textBuffer, buffer, length); break; case TCL_TOKEN_COMMAND: /* * Push any accumulated chars appearing before the command. */ if (Tcl_DStringLength(&textBuffer) > 0) { int literal; literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); } TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); numObjsToConcat++; break; case TCL_TOKEN_VARIABLE: /* * Push any accumulated chars appearing before the $<var>. */ if (Tcl_DStringLength(&textBuffer) > 0) { int literal; literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), Tcl_DStringLength(&textBuffer)); 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) { if (localVar < 0) { TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); } else if (localVar <= 255) { TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); } else { TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); } } else { TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr); if (localVar < 0) { TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); } else if (localVar <= 255) { TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr); } else { TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); } } numObjsToConcat++; count -= tokenPtr->numComponents; tokenPtr += tokenPtr->numComponents; break; default: Tcl_Panic("Unexpected token type in TclCompileTokens"); } } /* * Push any accumulated characters appearing at the end. */ if (Tcl_DStringLength(&textBuffer) > 0) { int literal; literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; } /* * If necessary, concatenate the parts of the word. */ while (numObjsToConcat > 255) { TclEmitInstInt1(INST_CONCAT1, 255, envPtr); numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ } if (numObjsToConcat > 1) { TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr); } /* * If the tokens yielded no instructions, push an empty string. */ if (envPtr->codeNext == entryCodeNext) { TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); } Tcl_DStringFree(&textBuffer); } /* *---------------------------------------------------------------------- * * TclCompileCmdWord -- * * Given an array of parse tokens for a word containing one or more Tcl * commands, emit inline instructions to execute them. This procedure * differs from TclCompileTokens in that a simple word such as a loop * body enclosed in braces is not just pushed as a string, but is itself * parsed into tokens and compiled. * * Results: * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. * * Side effects: * Instructions are added to envPtr to execute the tokens at runtime. * *---------------------------------------------------------------------- */ void TclCompileCmdWord(interp, tokenPtr, count, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens for * a command word to compile inline. */ int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr; /* Holds the resulting instructions. */ { if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { /* * Handle the common case: if there is a single text token, compile it * into an inline sequence of instructions. */ TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); } else { /* * Multiple tokens or the single token involves substitutions. Emit * instructions to invoke the eval command procedure at runtime on the * result of evaluating the tokens. */ TclCompileTokens(interp, tokenPtr, count, envPtr); TclEmitOpcode(INST_EVAL_STK, envPtr); } } |
︙ | ︙ | |||
1521 1522 1523 1524 1525 1526 1527 | * expression. This procedure differs from TclCompileExpr in that it * supports Tcl's two-level substitution semantics for expressions that * appear as command words. * * Results: * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. | | | | | | | | | | | | < | | | | | | | | | | | | 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 | * expression. This procedure differs from TclCompileExpr in that it * supports Tcl's two-level substitution semantics for expressions that * appear as command words. * * Results: * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. * * Side effects: * Instructions are added to envPtr to execute the expression. * *---------------------------------------------------------------------- */ void TclCompileExprWords(interp, tokenPtr, numWords, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ Tcl_Token *tokenPtr; /* Points to first in an array of word tokens * tokens for the expression to compile * inline. */ 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 i, concatItems; /* * If the expression is a single word that doesn't require substitutions, * just compile its string into inline instructions. */ if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { CONST char *script = tokenPtr[1].start; int numBytes = tokenPtr[1].size; int savedNumCmds = envPtr->numCommands; unsigned int savedCodeNext = envPtr->codeNext - envPtr->codeStart; if (TclCompileExpr(interp, script, numBytes, envPtr) == TCL_OK) { return; } envPtr->numCommands = savedNumCmds; envPtr->codeNext = envPtr->codeStart + savedCodeNext; } /* * Emit code to call the expr command proc at runtime. Concatenate the * (already substituted once) expr tokens with a space between each. */ wordPtr = tokenPtr; for (i = 0; i < numWords; i++) { TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); if (i < (numWords - 1)) { TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr); } wordPtr += (wordPtr->numComponents + 1); } concatItems = 2*numWords - 1; while (concatItems > 255) { TclEmitInstInt1(INST_CONCAT1, 255, envPtr); concatItems -= 254; } if (concatItems > 1) { TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); } TclEmitOpcode(INST_EXPR_STK, envPtr); } /* *---------------------------------------------------------------------- * * TclInitByteCodeObj -- * * Create a ByteCode structure and initialize it from a CompileEnv * compilation environment structure. The ByteCode structure is smaller * and contains just that information needed to execute the bytecode * instructions resulting from compiling a Tcl script. The resulting * structure is placed in the specified object. * * Results: * A newly constructed ByteCode object is stored in the internal * representation of the objPtr. * * Side effects: * A single heap object is allocated to hold the new ByteCode structure * and its code, object, command location, and aux data arrays. Note that * "ownership" (i.e., the pointers to) the Tcl objects and aux data items * will be handed over to the new ByteCode structure from the CompileEnv * structure. * *---------------------------------------------------------------------- */ void TclInitByteCodeObj(objPtr, envPtr) Tcl_Obj *objPtr; /* Points object that should be initialized, * and whose string rep contains the source * code. */ register CompileEnv *envPtr; /* Points to the CompileEnv structure from * which to create a ByteCode structure. */ { register ByteCode *codePtr; size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; size_t auxDataArrayBytes, structureSize; register unsigned char *p; |
︙ | ︙ | |||
1637 1638 1639 1640 1641 1642 1643 | iPtr = envPtr->iPtr; codeBytes = (envPtr->codeNext - envPtr->codeStart); objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *)); exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange)); auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); cmdLocBytes = GetCmdLocEncodingSize(envPtr); | | | | | | | > > > | > | | | | | | | | | | | | | < | | | | < | | | | | | | | | | | | | | < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | < | > | | | | | | | | | | | | | | | | | | | | | | 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 | iPtr = envPtr->iPtr; codeBytes = (envPtr->codeNext - envPtr->codeStart); objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *)); exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange)); auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); cmdLocBytes = GetCmdLocEncodingSize(envPtr); /* * Compute the total number of bytes needed for this bytecode. */ structureSize = sizeof(ByteCode); structureSize += TCL_ALIGN(codeBytes); /* align object array */ structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */ structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ structureSize += auxDataArrayBytes; structureSize += cmdLocBytes; if (envPtr->iPtr->varFramePtr != NULL) { namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; } else { namespacePtr = envPtr->iPtr->globalNsPtr; } p = (unsigned char *) ckalloc((size_t) structureSize); codePtr = (ByteCode *) p; codePtr->interpHandle = TclHandlePreserve(iPtr->handle); codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = namespacePtr; codePtr->nsEpoch = namespacePtr->resolverEpoch; codePtr->refCount = 1; if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) { codePtr->flags = TCL_BYTECODE_RESOLVE_VARS; } else { codePtr->flags = 0; } codePtr->source = envPtr->source; codePtr->procPtr = envPtr->procPtr; codePtr->numCommands = envPtr->numCommands; codePtr->numSrcBytes = envPtr->numSrcBytes; codePtr->numCodeBytes = codeBytes; codePtr->numLitObjects = numLitObjects; codePtr->numExceptRanges = envPtr->exceptArrayNext; codePtr->numAuxDataItems = envPtr->auxDataArrayNext; codePtr->numCmdLocBytes = cmdLocBytes; codePtr->maxExceptDepth = envPtr->maxExceptDepth; codePtr->maxStackDepth = envPtr->maxStackDepth; p += sizeof(ByteCode); codePtr->codeStart = p; memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes); p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; i++) { codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; } p += TCL_ALIGN(objArrayBytes); /* align exception range array */ if (exceptArrayBytes > 0) { codePtr->exceptArrayPtr = (ExceptionRange *) p; memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr, (size_t) exceptArrayBytes); } else { codePtr->exceptArrayPtr = NULL; } p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ if (auxDataArrayBytes > 0) { codePtr->auxDataArrayPtr = (AuxData *) p; memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, (size_t) auxDataArrayBytes); } else { codePtr->auxDataArrayPtr = NULL; } p += auxDataArrayBytes; #ifndef TCL_COMPILE_DEBUG EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); #else nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); if (((size_t)(nextPtr - p)) != cmdLocBytes) { Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes); } #endif /* * Record various compilation-related statistics about the new ByteCode * structure. Don't include overhead for statistics-related fields. */ #ifdef TCL_COMPILE_STATS codePtr->structureSize = structureSize - (sizeof(size_t) + sizeof(Tcl_Time)); Tcl_GetTime(&(codePtr->createTime)); RecordByteCodeStats(codePtr); #endif /* TCL_COMPILE_STATS */ /* * Free the old internal rep then convert the object to a bytecode object * by making its internal rep point to the just compiled ByteCode. */ TclFreeIntRep(objPtr); objPtr->internalRep.otherValuePtr = (VOID *) codePtr; objPtr->typePtr = &tclByteCodeType; } /* *---------------------------------------------------------------------- * * TclFindCompiledLocal -- * * This procedure is called at compile time to look up and optionally * allocate an entry ("slot") for a variable in a procedure's array of * local variables. If the variable's name is NULL, a new temporary * variable is always created. (Such temporary variables can only be * referenced using their slot index.) * * Results: * If create is 0 and the name is non-NULL, then if the variable is * found, the index of its entry in the procedure's array of local * variables is returned; otherwise -1 is returned. If name is NULL, the * index of a new temporary variable is returned. Finally, if create is 1 * and name is non-NULL, the index of a new entry is returned. * * Side effects: * Creates and registers a new local variable if create is 1 and the * variable is unknown, or if the name is NULL. * *---------------------------------------------------------------------- */ int TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) register CONST char *name; /* Points to first character of the name of a * scalar or array variable. If NULL, a * temporary var should be created. */ int nameBytes; /* Number of bytes in the name. */ int create; /* If 1, allocate a local frame entry for the * variable if it is new. */ int flags; /* Flag bits for the compiled local if * created. Only VAR_SCALAR, VAR_ARRAY, and * VAR_LINK make sense. */ register Proc *procPtr; /* Points to structure describing procedure * containing the variable reference. */ { register CompiledLocal *localPtr; int localVar = -1; register int i; /* * If not creating a temporary, does a local variable of the specified * name already exist? */ if (name != NULL) { int localCt = procPtr->numCompiledLocals; localPtr = procPtr->firstLocalPtr; for (i = 0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { char *localName = localPtr->name; if ((nameBytes == localPtr->nameLength) && (strncmp(name,localName,(unsigned)nameBytes) == 0)) { return i; } } localPtr = localPtr->nextPtr; } } /* * Create a new variable if appropriate. */ if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; localPtr = (CompiledLocal *) ckalloc((unsigned) (sizeof(CompiledLocal) - sizeof(localPtr->name) + nameBytes + 1)); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } 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) { memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameBytes); } localPtr->name[nameBytes] = '\0'; procPtr->numCompiledLocals++; } return localVar; } /* *---------------------------------------------------------------------- * * TclExpandCodeArray -- * * Procedure that uses malloc to allocate more storage for a CompileEnv's * code array. * * Results: * None. * * Side effects: * The byte code array in *envPtr is reallocated to a new array of double * the size, and if envPtr->mallocedCodeArray is non-zero the old array * is freed. Byte codes are copied from the old array to the new one. * *---------------------------------------------------------------------- */ void TclExpandCodeArray(envArgPtr) void *envArgPtr; /* Points to the CompileEnv whose code array * must be enlarged. */ { CompileEnv *envPtr = (CompileEnv*) envArgPtr; /* The CompileEnv containing the code array to * be doubled in size. */ /* * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined * code bytes are stored between envPtr->codeStart and envPtr->codeNext-1 * [inclusive]. */ size_t currBytes = (envPtr->codeNext - envPtr->codeStart); size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); /* * Copy from old code array to new, free old code array if needed, and * mark new code array as malloced. */ memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes); if (envPtr->mallocedCodeArray) { ckfree((char *) envPtr->codeStart); } envPtr->codeStart = newPtr; envPtr->codeNext = (newPtr + currBytes); envPtr->codeEnd = (newPtr + newBytes); envPtr->mallocedCodeArray = 1; } /* *---------------------------------------------------------------------- * * EnterCmdStartData -- * * Registers the starting source and bytecode location of a command. This * information is used at runtime to map between instruction pc and * source locations. * * Results: * None. * * Side effects: * Inserts source and code location information into the compilation * environment envPtr for the command at index cmdIndex. The compilation * environment's CmdLocation array is grown if necessary. * *---------------------------------------------------------------------- */ static void EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) CompileEnv *envPtr; /* Points to the compilation environment * structure in which to enter command * location information. */ int cmdIndex; /* Index of the command whose start data is * being set. */ int srcOffset; /* Offset of first char of the command. */ int codeOffset; /* Offset of first byte of command code. */ { CmdLocation *cmdLocPtr; if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { Tcl_Panic("EnterCmdStartData: bad command index %d\n", cmdIndex); } if (cmdIndex >= envPtr->cmdMapEnd) { /* * Expand the command location array by allocating more storage from * the heap. The currently allocated CmdLocation entries are stored * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive). */ size_t currElems = envPtr->cmdMapEnd; size_t newElems = 2*currElems; size_t currBytes = currElems * sizeof(CmdLocation); size_t newBytes = newElems * sizeof(CmdLocation); CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes); /* * Copy from old command location array to new, free old command * location array if needed, and mark new array as malloced. */ memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes); if (envPtr->mallocedCmdMap) { ckfree((char *) envPtr->cmdMapPtr); } envPtr->cmdMapPtr = (CmdLocation *) newPtr; envPtr->cmdMapEnd = newElems; envPtr->mallocedCmdMap = 1; |
︙ | ︙ | |||
2093 2094 2095 2096 2097 2098 2099 | * source locations. * * Results: * None. * * Side effects: * Inserts source and code length information into the compilation | | | | | | | | | | | | < | | | | | | | | | | < | | < | | | | | | | | | | | > | | | | | | < | | | | | | | | | | | | | | | | | 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 | * source locations. * * Results: * None. * * Side effects: * Inserts source and code length information into the compilation * environment envPtr for the command at index cmdIndex. Starting source * and bytecode information for the command must already have been * registered. * *---------------------------------------------------------------------- */ static void EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes) CompileEnv *envPtr; /* Points to the compilation environment * structure in which to enter command * location information. */ int cmdIndex; /* Index of the command whose source and code * length data is being set. */ int numSrcBytes; /* Number of command source chars. */ int numCodeBytes; /* Offset of last byte of command code. */ { CmdLocation *cmdLocPtr; if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { Tcl_Panic("EnterCmdExtentData: bad command index %d\n", cmdIndex); } if (cmdIndex > envPtr->cmdMapEnd) { Tcl_Panic("EnterCmdExtentData: missing start data for command %d\n", cmdIndex); } cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); cmdLocPtr->numSrcBytes = numSrcBytes; cmdLocPtr->numCodeBytes = numCodeBytes; } /* *---------------------------------------------------------------------- * * TclCreateExceptRange -- * * Procedure that allocates and initializes a new ExceptionRange * structure of the specified kind in a CompileEnv. * * Results: * Returns the index for the newly created ExceptionRange. * * Side effects: * If there is not enough room in the CompileEnv's ExceptionRange array, * the array in expanded: a new array of double the size is allocated, if * envPtr->mallocedExceptArray is non-zero the old array is freed, and * ExceptionRange entries are copied from the old array to the new one. * *---------------------------------------------------------------------- */ int TclCreateExceptRange(type, envPtr) ExceptionRangeType type; /* The kind of ExceptionRange desired. */ register CompileEnv *envPtr;/* Points to CompileEnv for which to create a * new ExceptionRange structure. */ { register ExceptionRange *rangePtr; int index = envPtr->exceptArrayNext; if (index >= envPtr->exceptArrayEnd) { /* * Expand the ExceptionRange array. The currently allocated entries * are stored between elements 0 and (envPtr->exceptArrayNext - 1) * [inclusive]. */ size_t currBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); int newElems = 2*envPtr->exceptArrayEnd; size_t newBytes = newElems * sizeof(ExceptionRange); ExceptionRange *newPtr = (ExceptionRange *) ckalloc((unsigned) newBytes); /* * Copy from old ExceptionRange array to new, free old ExceptionRange * array if needed, and mark the new ExceptionRange array as malloced. */ memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr, currBytes); if (envPtr->mallocedExceptArray) { ckfree((char *) envPtr->exceptArrayPtr); } envPtr->exceptArrayPtr = (ExceptionRange *) newPtr; envPtr->exceptArrayEnd = newElems; envPtr->mallocedExceptArray = 1; } envPtr->exceptArrayNext++; rangePtr = &(envPtr->exceptArrayPtr[index]); rangePtr->type = type; rangePtr->nestingLevel = envPtr->exceptDepth; rangePtr->codeOffset = -1; rangePtr->numCodeBytes = -1; rangePtr->breakOffset = -1; rangePtr->continueOffset = -1; rangePtr->catchOffset = -1; return index; } /* *---------------------------------------------------------------------- * * TclCreateAuxData -- * * Procedure that allocates and initializes a new AuxData structure in a * CompileEnv's array of compilation auxiliary data records. These * AuxData records hold information created during compilation by * CompileProcs and used by instructions during execution. * * Results: * Returns the index for the newly created AuxData structure. * * Side effects: * If there is not enough room in the CompileEnv's AuxData array, the * AuxData array in expanded: a new array of double the size is * allocated, if envPtr->mallocedAuxDataArray is non-zero the old array * is freed, and AuxData entries are copied from the old array to the new * one. * *---------------------------------------------------------------------- */ int TclCreateAuxData(clientData, typePtr, envPtr) ClientData clientData; /* The compilation auxiliary data to store in * the new aux data record. */ AuxDataType *typePtr; /* Pointer to the type to attach to this * AuxData */ register CompileEnv *envPtr;/* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { int index; /* Index for the new AuxData structure. */ register AuxData *auxDataPtr; /* Points to the new AuxData structure */ index = envPtr->auxDataArrayNext; if (index >= envPtr->auxDataArrayEnd) { /* * Expand the AuxData array. The currently allocated entries are * stored between elements 0 and (envPtr->auxDataArrayNext - 1) * [inclusive]. */ size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); int newElems = 2*envPtr->auxDataArrayEnd; size_t newBytes = newElems * sizeof(AuxData); AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); /* * Copy from old AuxData array to new, free old AuxData array if * needed, and mark the new AuxData array as malloced. */ memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr, currBytes); if (envPtr->mallocedAuxDataArray) { ckfree((char *) envPtr->auxDataArrayPtr); } envPtr->auxDataArrayPtr = newPtr; envPtr->auxDataArrayEnd = newElems; envPtr->mallocedAuxDataArray = 1; } envPtr->auxDataArrayNext++; auxDataPtr = &(envPtr->auxDataArrayPtr[index]); auxDataPtr->clientData = clientData; auxDataPtr->type = typePtr; return index; } /* *---------------------------------------------------------------------- * * TclInitJumpFixupArray -- * * Initializes a JumpFixupArray structure to hold some number of jump * fixup entries. * * Results: * None. * * Side effects: * The JumpFixupArray structure is initialized. * *---------------------------------------------------------------------- */ void TclInitJumpFixupArray(fixupArrayPtr) register JumpFixupArray *fixupArrayPtr; /* Points to the JumpFixupArray structure to * initialize. */ { fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; fixupArrayPtr->next = 0; fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1); fixupArrayPtr->mallocedArray = 0; } /* *---------------------------------------------------------------------- * * TclExpandJumpFixupArray -- * * Procedure that uses malloc to allocate more storage for a jump fixup * array. * * Results: * None. * * Side effects: * The jump fixup array in *fixupArrayPtr is reallocated to a new array * of double the size, and if fixupArrayPtr->mallocedArray is non-zero * the old array is freed. Jump fixup structures are copied from the old * array to the new one. * *---------------------------------------------------------------------- */ void TclExpandJumpFixupArray(fixupArrayPtr) register JumpFixupArray *fixupArrayPtr; /* Points to the JumpFixupArray structure * to enlarge. */ { /* * The currently allocated jump fixup entries are stored from fixup[0] up * to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd. */ size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); int newElems = 2*(fixupArrayPtr->end + 1); size_t newBytes = newElems * sizeof(JumpFixup); JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); /* * Copy from the old array to new, free the old array if needed, and mark * the new array as malloced. */ memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes); if (fixupArrayPtr->mallocedArray) { ckfree((char *) fixupArrayPtr->fixup); } fixupArrayPtr->fixup = (JumpFixup *) newPtr; fixupArrayPtr->end = newElems; fixupArrayPtr->mallocedArray = 1; |
︙ | ︙ | |||
2367 2368 2369 2370 2371 2372 2373 | * *---------------------------------------------------------------------- */ void TclFreeJumpFixupArray(fixupArrayPtr) register JumpFixupArray *fixupArrayPtr; | | | | | | | | | | | | | | | | | < | | | | | | < | | | | | | | | | | | | | | | | | | | | | | 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 | * *---------------------------------------------------------------------- */ void TclFreeJumpFixupArray(fixupArrayPtr) register JumpFixupArray *fixupArrayPtr; /* Points to the JumpFixupArray structure to * free. */ { if (fixupArrayPtr->mallocedArray) { ckfree((char *) fixupArrayPtr->fixup); } } /* *---------------------------------------------------------------------- * * TclEmitForwardJump -- * * Procedure to emit a two-byte forward jump of kind "jumpType". Since * the jump may later have to be grown to five bytes if the jump target * is more than, say, 127 bytes away, this procedure also initializes a * JumpFixup record with information about the jump. * * Results: * None. * * Side effects: * The JumpFixup record pointed to by "jumpFixupPtr" is initialized with * information needed later if the jump is to be grown. Also, a two byte * jump of the designated type is emitted at the current point in the * bytecode stream. * *---------------------------------------------------------------------- */ void TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr) CompileEnv *envPtr; /* Points to the CompileEnv structure that * holds the resulting instruction. */ TclJumpType jumpType; /* Indicates the kind of jump: if true or * false or unconditional. */ JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure to * initialize with information about this * forward jump. */ { /* * Initialize the JumpFixup structure: * - codeOffset is offset of first byte of jump below * - cmdIndex is index of the command after the current one * - exceptIndex is the index of the first ExceptionRange after the * current one. */ jumpFixupPtr->jumpType = jumpType; jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart); jumpFixupPtr->cmdIndex = envPtr->numCommands; jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext; switch (jumpType) { case TCL_UNCONDITIONAL_JUMP: TclEmitInstInt1(INST_JUMP1, 0, envPtr); break; case TCL_TRUE_JUMP: TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr); break; default: TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); break; } } /* *---------------------------------------------------------------------- * * TclFixupForwardJump -- * * Procedure that updates a previously-emitted forward jump to jump a * specified number of bytes, "jumpDist". If necessary, the jump is grown * from two to five bytes; this is done if the jump distance is greater * than "distThreshold" (normally 127 bytes). The jump is described by a * JumpFixup record previously initialized by TclEmitForwardJump. * * Results: * 1 if the jump was grown and subsequent instructions had to be moved; * otherwise 0. This result is returned to allow callers to update any * additional code offsets they may hold. * * Side effects: * The jump may be grown and subsequent instructions moved. If this * happens, the code offsets for any commands and any ExceptionRange * records between the jump and the current code address will be updated * to reflect the moved code. Also, the bytecode instruction array in the * CompileEnv structure may be grown and reallocated. * *---------------------------------------------------------------------- */ int TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) CompileEnv *envPtr; /* Points to the CompileEnv structure that * holds the resulting instruction. */ JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that * describes the forward jump. */ int jumpDist; /* Jump distance to set in jump instr. */ int distThreshold; /* Maximum distance before the two byte jump * is grown to five bytes. */ { unsigned char *jumpPc, *p; int firstCmd, lastCmd, firstRange, lastRange, k; unsigned int numBytes; if (jumpDist <= distThreshold) { jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); switch (jumpFixupPtr->jumpType) { case TCL_UNCONDITIONAL_JUMP: TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc); break; case TCL_TRUE_JUMP: TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc); break; default: TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc); break; } return 0; } /* * We must grow the jump then move subsequent instructions down. Note * that if we expand the space for generated instructions, code addresses * might change; be careful about updating any of these addresses held in * variables. */ if ((envPtr->codeNext + 3) > envPtr->codeEnd) { TclExpandCodeArray(envPtr); } jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1; numBytes > 0; numBytes--, p--) { p[3] = p[0]; } envPtr->codeNext += 3; jumpDist += 3; switch (jumpFixupPtr->jumpType) { case TCL_UNCONDITIONAL_JUMP: TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc); break; case TCL_TRUE_JUMP: TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc); break; default: TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc); break; } /* * Adjust the code offsets for any commands and any ExceptionRange records * between the jump and the current code address. */ firstCmd = jumpFixupPtr->cmdIndex; lastCmd = (envPtr->numCommands - 1); if (firstCmd < lastCmd) { for (k = firstCmd; k <= lastCmd; k++) { (envPtr->cmdMapPtr[k]).codeOffset += 3; } } firstRange = jumpFixupPtr->exceptIndex; lastRange = (envPtr->exceptArrayNext - 1); for (k = firstRange; k <= lastRange; k++) { ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]); rangePtr->codeOffset += 3; switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: rangePtr->breakOffset += 3; if (rangePtr->continueOffset != -1) { rangePtr->continueOffset += 3; } break; case CATCH_EXCEPTION_RANGE: rangePtr->catchOffset += 3; break; default: Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d\n", rangePtr->type); } } return 1; /* the jump was grown */ } /* *---------------------------------------------------------------------- * * TclGetInstructionTable -- * * 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. |
︙ | ︙ | |||
2587 2588 2589 2590 2591 2592 2593 | } /* *-------------------------------------------------------------- * * TclRegisterAuxDataType -- * | | | | | | | | | | | | 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 | } /* *-------------------------------------------------------------- * * TclRegisterAuxDataType -- * * This procedure is called to register a new AuxData type in the table * of all AuxData types supported by Tcl. * * Results: * None. * * Side effects: * The type is registered in the AuxData type table. If there was already * a type with the same name as in typePtr, it is replaced with the new * type. * *-------------------------------------------------------------- */ void TclRegisterAuxDataType(typePtr) AuxDataType *typePtr; /* Information about object type; storage must * be statically allocated (must live * forever; will not be deallocated). */ { register Tcl_HashEntry *hPtr; int new; Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { TclInitAuxDataTypeTable(); } /* * If there's already a type with the given name, remove it. */ hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name); if (hPtr != (Tcl_HashEntry *) NULL) { Tcl_DeleteHashEntry(hPtr); } /* * Now insert the new object type. */ hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new); if (new) { Tcl_SetHashValue(hPtr, typePtr); } Tcl_MutexUnlock(&tableMutex); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
2661 2662 2663 2664 2665 2666 2667 | char *typeName; /* Name of AuxData type to look up. */ { register Tcl_HashEntry *hPtr; AuxDataType *typePtr = NULL; Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { | | | | | | 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 | char *typeName; /* Name of AuxData type to look up. */ { register Tcl_HashEntry *hPtr; AuxDataType *typePtr = NULL; Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { TclInitAuxDataTypeTable(); } hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); if (hPtr != (Tcl_HashEntry *) NULL) { typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); return typePtr; } /* *-------------------------------------------------------------- * * TclInitAuxDataTypeTable -- * * This procedure is invoked to perform once-only initialization of the * AuxData type table. It also registers the AuxData types defined in * this file. * * Results: * None. * * Side effects: * Initializes the table of defined AuxData types "auxDataTypeTable" with |
︙ | ︙ | |||
2714 2715 2716 2717 2718 2719 2720 | } /* *---------------------------------------------------------------------- * * TclFinalizeAuxDataTypeTable -- * | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TclFinalizeAuxDataTypeTable -- * * This procedure is called by Tcl_Finalize after all exit handlers have * been run to free up storage associated with the table of AuxData * types. This procedure is called by TclFinalizeExecution() which is * called by Tcl_Finalize(). * * Results: * None. * * Side effects: * Deletes all entries in the hash table of AuxData types. * *---------------------------------------------------------------------- */ void TclFinalizeAuxDataTypeTable() { Tcl_MutexLock(&tableMutex); if (auxDataTypeTableInitialized) { Tcl_DeleteHashTable(&auxDataTypeTable); auxDataTypeTableInitialized = 0; } Tcl_MutexUnlock(&tableMutex); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
2758 2759 2760 2761 2762 2763 2764 | * None. * *---------------------------------------------------------------------- */ static int GetCmdLocEncodingSize(envPtr) | | | | | | | 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 | * None. * *---------------------------------------------------------------------- */ static int GetCmdLocEncodingSize(envPtr) CompileEnv *envPtr; /* Points to compilation environment structure * containing the CmdLocation structure to * encode. */ { register CmdLocation *mapPtr = envPtr->cmdMapPtr; int numCmds = envPtr->numCommands; int codeDelta, codeLen, srcDelta, srcLen; int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; /* The offsets in their respective byte * sequences where the next encoded offset or * length should go. */ int prevCodeOffset, prevSrcOffset, i; codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; prevCodeOffset = prevSrcOffset = 0; for (i = 0; i < numCmds; i++) { codeDelta = (mapPtr[i].codeOffset - prevCodeOffset); if (codeDelta < 0) { |
︙ | ︙ | |||
2819 2820 2821 2822 2823 2824 2825 | } /* *---------------------------------------------------------------------- * * EncodeCmdLocMap -- * | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * EncodeCmdLocMap -- * * Encode the command location information for some compiled code into a * ByteCode structure. The encoded command location map is stored as * three adjacent byte sequences. * * Results: * Pointer to the first byte after the encoded command location * information. * * Side effects: * The encoded information is stored into the block of memory headed by * codePtr. Also records pointers to the start of the four byte sequences * in fields in codePtr's ByteCode header structure. * *---------------------------------------------------------------------- */ static unsigned char * EncodeCmdLocMap(envPtr, codePtr, startPtr) CompileEnv *envPtr; /* Points to compilation environment structure * containing the CmdLocation structure to * encode. */ ByteCode *codePtr; /* ByteCode in which to encode envPtr's * command location information. */ unsigned char *startPtr; /* Points to the first byte in codePtr's * memory block where the location information * is to be stored. */ { register CmdLocation *mapPtr = envPtr->cmdMapPtr; int numCmds = envPtr->numCommands; register unsigned char *p = startPtr; int codeDelta, codeLen, srcDelta, srcLen, prevOffset; register int i; /* * Encode the code offset for each command as a sequence of deltas. */ codePtr->codeDeltaStart = p; prevOffset = 0; for (i = 0; i < numCmds; i++) { |
︙ | ︙ | |||
2933 2934 2935 2936 2937 2938 2939 | } else { TclStoreInt1AtPtr(0xFF, p); p++; TclStoreInt4AtPtr(srcLen, p); p += 4; } } | | | | | 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 | } else { TclStoreInt1AtPtr(0xFF, p); p++; TclStoreInt4AtPtr(srcLen, p); p += 4; } } return p; } #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * * TclPrintByteCodeObj -- * * This procedure prints ("disassembles") the instructions of a bytecode * object to stdout. * * Results: * None. * * Side effects: * None. * |
︙ | ︙ | |||
2991 2992 2993 2994 2995 2996 2997 | TclPrintSource(stdout, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | 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 | TclPrintSource(stdout, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS codePtr->numSrcBytes? codePtr->structureSize/(float)codePtr->numSrcBytes : #endif 0.0); #ifdef TCL_COMPILE_STATS fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", codePtr->structureSize, (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), codePtr->numCodeBytes, (codePtr->numLitObjects * sizeof(Tcl_Obj *)), (codePtr->numExceptRanges * sizeof(ExceptionRange)), (codePtr->numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ /* * If the ByteCode is the compiled body of a Tcl procedure, print * information about that procedure. Note that we don't know the * procedure's name since ByteCode's can be shared among procedures. */ if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; fprintf(stdout, " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; for (i = 0; i < numCompiledLocals; i++) { fprintf(stdout, " slot %d%s%s%s%s%s%s", i, (localPtr->flags & VAR_SCALAR) ? ", scalar" : "", (localPtr->flags & VAR_ARRAY) ? ", array" : "", (localPtr->flags & VAR_LINK) ? ", link" : "", (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); if (TclIsVarTemporary(localPtr)) { fprintf(stdout, "\n"); } else { fprintf(stdout, ", \"%s\"\n", localPtr->name); } localPtr = localPtr->nextPtr; } } } /* * Print the ExceptionRange array. */ if (codePtr->numExceptRanges > 0) { fprintf(stdout, " Exception ranges %d, depth %d:\n", codePtr->numExceptRanges, codePtr->maxExceptDepth); for (i = 0; i < codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]); fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", i, rangePtr->nestingLevel, (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), rangePtr->codeOffset, (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: fprintf(stdout, "continue %d, break %d\n", rangePtr->continueOffset, rangePtr->breakOffset); break; case CATCH_EXCEPTION_RANGE: fprintf(stdout, "catch %d\n", rangePtr->catchOffset); break; default: Tcl_Panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n", rangePtr->type); } } } /* * If there were no commands (e.g., an expression or an empty string was * compiled), just print all instructions and return. */ if (numCmds == 0) { pc = codeStart; while (pc < codeLimit) { fprintf(stdout, " "); pc += TclPrintInstruction(codePtr, pc); } return; } /* * Print table showing the code offset, source offset, and source length * for each command. These are encoded as a sequence of bytes. */ fprintf(stdout, " Commands %d:", numCmds); codeDeltaNext = codePtr->codeDeltaStart; codeLengthNext = codePtr->codeLengthStart; srcDeltaNext = codePtr->srcDeltaStart; srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; for (i = 0; i < numCmds; i++) { if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); codeDeltaNext += 4; |
︙ | ︙ | |||
3115 3116 3117 3118 3119 3120 3121 | codeLengthNext++; codeLen = TclGetInt4AtPtr(codeLengthNext); codeLengthNext += 4; } else { codeLen = TclGetInt1AtPtr(codeLengthNext); codeLengthNext++; } | | | | | | | | | 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 | codeLengthNext++; codeLen = TclGetInt4AtPtr(codeLengthNext); codeLengthNext += 4; } else { codeLen = TclGetInt1AtPtr(codeLengthNext); codeLengthNext++; } if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; } else { delta = TclGetInt1AtPtr(srcDeltaNext); srcDeltaNext++; } srcOffset += delta; if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; } else { srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d", ((i % 2)? " " : "\n "), (i+1), codeOffset, (codeOffset + codeLen - 1), srcOffset, (srcOffset + srcLen - 1)); } if (numCmds > 0) { fprintf(stdout, "\n"); } /* * Print each instruction. If the instruction corresponds to the start of * a command, print the command's source. Note that we don't need the code * length here. */ codeDeltaNext = codePtr->codeDeltaStart; srcDeltaNext = codePtr->srcDeltaStart; srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; pc = codeStart; for (i = 0; i < numCmds; i++) { if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); |
︙ | ︙ | |||
3188 3189 3190 3191 3192 3193 3194 | srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } /* * Print instructions before command i. */ | | | < | | | 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 | srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } /* * Print instructions before command i. */ while ((pc-codeStart) < codeOffset) { fprintf(stdout, " "); pc += TclPrintInstruction(codePtr, pc); } fprintf(stdout, " Command %d: ", (i+1)); TclPrintSource(stdout, (codePtr->source + srcOffset), TclMin(srcLen, 55)); fprintf(stdout, "\n"); } if (pc < codeLimit) { /* * Print instructions after the last command. */ while (pc < codeLimit) { fprintf(stdout, " "); pc += TclPrintInstruction(codePtr, pc); } } } /* *---------------------------------------------------------------------- * * TclPrintInstruction -- * * This procedure prints ("disassembles") one instruction from a bytecode * object to stdout. * * Results: * Returns the length in bytes of the current instruiction. * * Side effects: * None. * |
︙ | ︙ | |||
3240 3241 3242 3243 3244 3245 3246 | { 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, numBytes = 1; | > > | > > > > > > < | | < < | > < | | < < | > | < | < < < < < < < < < | < < < < < < < < < < < | < < | < < | < < < < < < < < < < < | < < < < | < | < < | > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > | | | | | | 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 | { 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, numBytes = 1; int localCt = procPtr ? procPtr->numCompiledLocals : 0; CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; char suffixBuffer[64]; /* Additional info to print after main opcode * and immediates. */ char *suffixSrc = NULL; Tcl_Obj *suffixObj = NULL; suffixBuffer[0] = '\0'; fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name); for (i = 0; i < instDesc->numOperands; i++) { switch (instDesc->opTypes[i]) { case OPERAND_INT1: opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 || opCode == INST_JUMP_FALSE1) { sprintf(suffixBuffer, "pc %u", pcOffset+opnd); } fprintf(stdout, "%+d ", opnd); break; case OPERAND_INT4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 || opCode == INST_JUMP_FALSE4) { sprintf(suffixBuffer, "pc %u", pcOffset+opnd); } fprintf(stdout, "%+d ", opnd); break; case OPERAND_UINT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; if (opCode == INST_PUSH1) { suffixObj = codePtr->objArrayPtr[opnd]; } fprintf(stdout, "%u ", (unsigned int) opnd); break; case OPERAND_UINT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; if (opCode == INST_PUSH4) { suffixObj = codePtr->objArrayPtr[opnd]; } else if (opCode == INST_START_CMD) { sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); } fprintf(stdout, "%u ", (unsigned int) opnd); break; case OPERAND_IDX4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; if (opnd >= -1) { fprintf(stdout, "%d ", opnd); } else if (opnd == -2) { fprintf(stdout, "end "); } else { fprintf(stdout, "end-%d ", -2-opnd); } break; case OPERAND_LVT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; goto printLVTindex; case OPERAND_LVT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; printLVTindex: if (localPtr != NULL) { if (opnd >= localCt) { Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)\n", (unsigned int) opnd, localCt); } for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; } if (TclIsVarTemporary(localPtr)) { sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); } else { sprintf(suffixBuffer, "var "); suffixSrc = localPtr->name; } } fprintf(stdout, "%%v%u ", (unsigned) opnd); break; case OPERAND_NONE: default: break; } } if (suffixObj) { fprintf(stdout, "\t# "); TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); } else if (suffixBuffer[0]) { fprintf(stdout, "\t# %s", suffixBuffer); if (suffixSrc) { TclPrintSource(stdout, suffixSrc, 40); } } fprintf(stdout, "\n"); return numBytes; } /* *---------------------------------------------------------------------- * * TclPrintObject -- * * This procedure prints up to a specified number of characters from the * argument Tcl object's string representation to a specified file. * * Results: * None. * * Side effects: * Outputs characters to the specified file. * *---------------------------------------------------------------------- */ void TclPrintObject(outFile, objPtr, maxChars) FILE *outFile; /* The file to print the source to. */ Tcl_Obj *objPtr; /* Points to the Tcl object whose string * representation should be printed. */ int maxChars; /* Maximum number of chars to print. */ { char *bytes; int length; bytes = Tcl_GetStringFromObj(objPtr, &length); TclPrintSource(outFile, bytes, TclMin(length, maxChars)); } /* *---------------------------------------------------------------------- * * TclPrintSource -- * * This procedure prints up to a specified number of characters from the * argument string to a specified file. It tries to produce legible * output by adding backslashes as necessary. * * Results: * None. * * Side effects: * Outputs characters to the specified file. |
︙ | ︙ | |||
3410 3411 3412 3413 3414 3415 3416 | return; } fprintf(outFile, "\""); p = stringPtr; for (; (*p != '\0') && (i < maxChars); p++, i++) { switch (*p) { | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | > > > > > > > > | 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 | return; } fprintf(outFile, "\""); p = stringPtr; for (; (*p != '\0') && (i < maxChars); p++, i++) { switch (*p) { case '"': fprintf(outFile, "\\\""); continue; case '\f': fprintf(outFile, "\\f"); continue; case '\n': fprintf(outFile, "\\n"); continue; case '\r': fprintf(outFile, "\\r"); continue; case '\t': fprintf(outFile, "\\t"); continue; case '\v': fprintf(outFile, "\\v"); continue; default: fprintf(outFile, "%c", *p); continue; } } fprintf(outFile, "\""); } #endif /* TCL_COMPILE_DEBUG */ #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- * * RecordByteCodeStats -- * * Accumulates various compilation-related statistics for each newly * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is * compiled with the -DTCL_COMPILE_STATS flag * * Results: * None. * * Side effects: * Accumulates aggregate code-related statistics in the interpreter's * ByteCodeStats structure. Records statistics specific to a ByteCode in * its ByteCode structure. * *---------------------------------------------------------------------- */ void RecordByteCodeStats(codePtr) ByteCode *codePtr; /* Points to ByteCode structure with info * to add to accumulated statistics. */ { Interp *iPtr = (Interp *) *codePtr->interpHandle; register ByteCodeStats *statsPtr = &(iPtr->stats); statsPtr->numCompilations++; statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++; statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; statsPtr->currentLitBytes += (double) codePtr->numLitObjects * sizeof(Tcl_Obj *); statsPtr->currentExceptBytes += (double) codePtr->numExceptRanges * sizeof(ExceptionRange); statsPtr->currentAuxBytes += (double) codePtr->numAuxDataItems * sizeof(AuxData); statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes; } #endif /* TCL_COMPILE_STATS */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclCompile.h.
1 2 3 4 5 6 7 8 9 10 | /* * tclCompile.h -- * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclCompile.h -- * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclCompile.h,v 1.51.2.6 2005/08/02 18:15:21 dgp Exp $ */ #ifndef _TCLCOMPILATION #define _TCLCOMPILATION 1 #include "tclInt.h" |
︙ | ︙ | |||
30 31 32 33 34 35 36 | * 0: no compilation tracing * 1: summarize compilation of top level cmds and proc bodies * 2: display all instructions of each ByteCode compiled * This variable is linked to the Tcl variable "tcl_traceCompile". */ MODULE_SCOPE int tclTraceCompile; | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | < | | | | | | | | | | | | | | 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 | * 0: no compilation tracing * 1: summarize compilation of top level cmds and proc bodies * 2: display all instructions of each ByteCode compiled * This variable is linked to the Tcl variable "tcl_traceCompile". */ MODULE_SCOPE int tclTraceCompile; /* * Variable that controls whether execution tracing is enabled and, if so, * what level of tracing is desired: * 0: no execution tracing * 1: trace invocations of Tcl procs only * 2: trace invocations of all (not compiled away) commands * 3: display each instruction executed * This variable is linked to the Tcl variable "tcl_traceExec". */ MODULE_SCOPE int tclTraceExec; #endif /* *------------------------------------------------------------------------ * Data structures related to compilation. *------------------------------------------------------------------------ */ /* * The structure used to implement Tcl "exceptions" (exceptional returns): for * example, those generated in loops by the break and continue commands, and * those generated by scripts and caught by the catch command. This * ExceptionRange structure describes a range of code (e.g., a loop body), the * kind of exceptions (e.g., a break or continue) that might occur, and the PC * offsets to jump to if a matching exception does occur. Exception ranges can * nest so this structure includes a nesting level that is used at runtime to * find the closest exception range surrounding a PC. For example, when a * break command is executed, the ExceptionRange structure for the most deeply * nested loop, if any, is found and used. These structures are also generated * for the "next" subcommands of for loops since a break there terminates the * for command. This means a for command actually generates two LoopInfo * structures. */ typedef enum { LOOP_EXCEPTION_RANGE, /* Exception's range is part of a loop. Break * and continue "exceptions" cause jumps to * appropriate PC offsets. */ CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a catch * command. Errors in the range cause a jump * to a catch PC offset. */ } ExceptionRangeType; typedef struct ExceptionRange { ExceptionRangeType type; /* The kind of ExceptionRange. */ int nestingLevel; /* Static depth of the exception range. Used * to find the most deeply-nested range * surrounding a PC at runtime. */ int codeOffset; /* Offset of the first instruction byte of the * code range. */ int numCodeBytes; /* Number of bytes in the code range. */ int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC * offset for a break command in the range. */ int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the * target PC offset for a continue command in * the code range. Otherwise, ignore this * range when processing a continue * command. */ int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC * offset for any "exception" in range. */ } ExceptionRange; /* * Structure used to map between instruction pc and source locations. It * defines for each compiled Tcl command its code's starting offset and its * source's starting offset and length. Note that the code offset increases * monotonically: that is, the table is sorted in code offset order. The * source offset is not monotonic. */ typedef struct CmdLocation { int codeOffset; /* Offset of first byte of command code. */ int numCodeBytes; /* Number of bytes for command's code. */ int srcOffset; /* Offset of first char of the command. */ int numSrcBytes; /* Number of command source chars. */ } CmdLocation; /* * CompileProcs need the ability to record information during compilation that * can be used by bytecode instructions during execution. The AuxData * structure provides this "auxiliary data" mechanism. An arbitrary number of * these structures can be stored in the ByteCode record (during compilation * they are stored in a CompileEnv structure). Each AuxData record holds one * word of client-specified data (often a pointer) and is given an index that * instructions can later use to look up the structure and its data. * * The following definitions declare the types of procedures that are called * to duplicate or free this auxiliary data when the containing ByteCode * objects are duplicated and freed. Pointers to these procedures are kept in * the AuxData structure. */ typedef ClientData (AuxDataDupProc) _ANSI_ARGS_((ClientData clientData)); typedef void (AuxDataFreeProc) _ANSI_ARGS_((ClientData clientData)); /* * We define a separate AuxDataType struct to hold type-related information * for the AuxData structure. This separation makes it possible for clients * outside of the TCL core to manipulate (in a limited fashion!) AuxData; for * example, it makes it possible to pickle and unpickle AuxData structs. */ typedef struct AuxDataType { char *name; /* the name of the type. Types can be * registered and found by name */ AuxDataDupProc *dupProc; /* Callback procedure to invoke when the aux * data is duplicated (e.g., when the ByteCode * structure containing the aux data is * duplicated). NULL means just copy the * source clientData bits; no proc need be * called. */ AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the aux * data is freed. NULL means no proc need be * called. */ } AuxDataType; /* * The definition of the AuxData structure that holds information created * during compilation by CompileProcs and used by instructions during * execution. */ |
︙ | ︙ | |||
176 177 178 179 180 181 182 | #define COMPILEENV_INIT_NUM_OBJECTS 60 #define COMPILEENV_INIT_EXCEPT_RANGES 5 #define COMPILEENV_INIT_CMD_MAP_SIZE 40 #define COMPILEENV_INIT_AUX_DATA_SIZE 5 typedef struct CompileEnv { Interp *iPtr; /* Interpreter containing the code being | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | < | | | | | | | 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 | #define COMPILEENV_INIT_NUM_OBJECTS 60 #define COMPILEENV_INIT_EXCEPT_RANGES 5 #define COMPILEENV_INIT_CMD_MAP_SIZE 40 #define COMPILEENV_INIT_AUX_DATA_SIZE 5 typedef struct CompileEnv { Interp *iPtr; /* Interpreter containing the code being * compiled. Commands and their compile procs * are specific to an interpreter so the code * emitted will depend on the interpreter. */ char *source; /* The source string being compiled by * SetByteCodeFromAny. This pointer is not * owned by the CompileEnv and must not be * freed or changed by it. */ int numSrcBytes; /* Number of bytes in source. */ Proc *procPtr; /* If a procedure is being compiled, a pointer * to its Proc structure; otherwise NULL. Used * to compile local variables. Set from * information provided by ObjInterpProc in * tclProc.c. */ int numCommands; /* Number of commands compiled. */ int exceptDepth; /* Current exception range nesting level; -1 * if not in any range currently. */ int maxExceptDepth; /* Max nesting level of exception ranges; -1 * if no ranges have been compiled. */ int maxStackDepth; /* Maximum number of stack elements needed to * execute the code. Set by compilation * procedures before returning. */ int currStackDepth; /* Current stack depth. */ LiteralTable localLitTable; /* Contains LiteralEntry's describing all Tcl * objects referenced by this compiled code. * Indexed by the string representations of * the literals. Used to avoid creating * duplicate objects. */ unsigned char *codeStart; /* Points to the first byte of the code. */ unsigned char *codeNext; /* Points to next code array byte to use. */ unsigned char *codeEnd; /* Points just after the last allocated code * array byte. */ int mallocedCodeArray; /* Set 1 if code array was expanded and * codeStart points into the heap.*/ LiteralEntry *literalArrayPtr; /* Points to start of LiteralEntry array. */ int literalArrayNext; /* Index of next free object array entry. */ int literalArrayEnd; /* Index just after last obj array entry. */ int mallocedLiteralArray; /* 1 if object array was expanded and objArray * points into the heap, else 0. */ ExceptionRange *exceptArrayPtr; /* Points to start of the ExceptionRange * array. */ int exceptArrayNext; /* Next free ExceptionRange array index. * exceptArrayNext is the number of ranges and * (exceptArrayNext-1) is the index of the * current range's array entry. */ int exceptArrayEnd; /* Index after the last ExceptionRange array * entry. */ int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and * exceptArrayPtr points in heap, else 0. */ CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. * numCommands is the index of the next entry * to use; (numCommands-1) is the entry index * for the last command. */ int cmdMapEnd; /* Index after last CmdLocation entry. */ int mallocedCmdMap; /* 1 if command map array was expanded and * cmdMapPtr points in the heap, else 0. */ AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ int auxDataArrayNext; /* Next free compile aux data array index. * auxDataArrayNext is the number of aux data * items and (auxDataArrayNext-1) is index of * current aux data array entry. */ int auxDataArrayEnd; /* Index after last aux data array entry. */ int mallocedAuxDataArray; /* 1 if aux data array was expanded and * auxDataArrayPtr points in heap else 0. */ unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; /* Initial storage for code. */ LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS]; /* Initial storage of LiteralEntry array. */ ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; /* Initial ExceptionRange array storage. */ CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE]; /* Initial storage for cmd location map. */ AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; /* Initial storage for aux data array. */ } CompileEnv; /* * The structure defining the bytecode instructions resulting from compiling a * Tcl script. Note that this structure is variable length: a single heap * object is allocated to hold the ByteCode structure immediately followed by * the code bytes, the literal object array, the ExceptionRange array, the * CmdLocation map, and the compilation AuxData array. */ /* * A PRECOMPILED bytecode struct is one that was generated from a compiled * image rather than implicitly compiled from source */ #define TCL_BYTECODE_PRECOMPILED 0x0001 /* * When a bytecode is compiled, interp or namespace resolvers have not been * applied yet: this is indicated by the TCL_BYTECODE_RESOLVE_VARS flag. */ #define TCL_BYTECODE_RESOLVE_VARS 0x0002 typedef struct ByteCode { TclHandle interpHandle; /* Handle for interpreter containing the * compiled code. Commands and their compile * procs are specific to an interpreter so the * code emitted will depend on the * interpreter. */ int compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * procs are redefined. */ Namespace *nsPtr; /* Namespace context in which this code was * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ int nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ int refCount; /* Reference count: set 1 when created plus 1 * for each execution of the code currently * active. This structure can be freed when * refCount becomes zero. */ unsigned int flags; /* flags describing state for the codebyte. * this variable holds ORed values from the * TCL_BYTECODE_ masks defined above */ char *source; /* The source string from which this ByteCode * was compiled. Note that this pointer is not * owned by the ByteCode and must not be freed * or modified by it. */ Proc *procPtr; /* If the ByteCode was compiled from a * procedure body, this is a pointer to its * Proc structure; otherwise NULL. This * pointer is also not owned by the ByteCode * and must not be freed by it. */ size_t structureSize; /* Number of bytes in the ByteCode structure * itself. Does not include heap space for * literal Tcl objects or storage referenced * by AuxData entries. */ int numCommands; /* Number of commands compiled. */ int numSrcBytes; /* Number of source bytes compiled. */ int numCodeBytes; /* Number of code bytes. */ int numLitObjects; /* Number of objects in literal array. */ int numExceptRanges; /* Number of ExceptionRange array elems. */ int numAuxDataItems; /* Number of AuxData items. */ int numCmdLocBytes; /* Number of bytes needed for encoded command * location information. */ int maxExceptDepth; /* Maximum nesting level of ExceptionRanges; * -1 if no ranges were compiled. */ int maxStackDepth; /* Maximum number of stack elements needed to * execute the code. */ unsigned char *codeStart; /* Points to the first byte of the code. This * is just after the final ByteCode member * cmdMapPtr. */ Tcl_Obj **objArrayPtr; /* Points to the start of the literal object * array. This is just after the last code * byte. */ ExceptionRange *exceptArrayPtr; /* Points to the start of the ExceptionRange * array. This is just after the last object * in the object array. */ AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data * array. This is just after the last entry in * the ExceptionRange array. */ unsigned char *codeDeltaStart; /* Points to the first of a sequence of bytes * that encode the change in the starting * offset of each command's code. If -127 <= * delta <= 127, it is encoded as 1 byte, * otherwise 0xFF (128) appears and the delta * is encoded by the next 4 bytes. Code deltas * are always positive. This sequence is just * after the last entry in the AuxData * array. */ unsigned char *codeLengthStart; /* Points to the first of a sequence of bytes * that encode the length of each command's * code. The encoding is the same as for code * deltas. Code lengths are always positive. * This sequence is just after the last entry * in the code delta sequence. */ unsigned char *srcDeltaStart; /* Points to the first of a sequence of bytes * that encode the change in the starting * offset of each command's source. The * encoding is the same as for code deltas. * Source deltas can be negative. This * sequence is just after the last byte in the * code length sequence. */ unsigned char *srcLengthStart; /* Points to the first of a sequence of bytes * that encode the length of each command's * source. The encoding is the same as for * code deltas. Source lengths are always * positive. This sequence is just after the * last byte in the source delta sequence. */ #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 |
︙ | ︙ | |||
513 514 515 516 517 518 519 | #define INST_OVER 95 #define INST_LSET_LIST 96 #define INST_LSET_FLAT 97 /* TIP#90 - 'return' command. */ | | | | | | > > > > > > > > > > > > > > > > > > > | | | | | | < | > | > > > > | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < | | 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 | #define INST_OVER 95 #define INST_LSET_LIST 96 #define INST_LSET_FLAT 97 /* TIP#90 - 'return' command. */ #define INST_RETURN_IMM 98 /* TIP#123 - exponentiation operator. */ #define INST_EXPON 99 /* TIP #157 - {expand}... language syntax support. */ #define INST_EXPAND_START 100 #define INST_EXPAND_STKTOP 101 #define INST_INVOKE_EXPANDED 102 /* * TIP #57 - 'lassign' command. Code generation requires immediate * LINDEX and LRANGE operators. */ #define INST_LIST_INDEX_IMM 103 #define INST_LIST_RANGE_IMM 104 #define INST_START_CMD 105 #define INST_LIST_IN 106 #define INST_LIST_NOT_IN 107 #define INST_PUSH_RETURN_OPTIONS 108 #define INST_RETURN_STK 109 /* * Dictionary (TIP#111) related commands. */ #define INST_DICT_GET 110 #define INST_DICT_SET 111 #define INST_DICT_UNSET 112 #define INST_DICT_INCR_IMM 113 #define INST_DICT_APPEND 114 #define INST_DICT_LAPPEND 115 #define INST_DICT_FIRST 116 #define INST_DICT_NEXT 117 #define INST_DICT_DONE 118 #define INST_DICT_UPDATE_START 119 #define INST_DICT_UPDATE_END 120 /* The last opcode */ #define LAST_INST_OPCODE 120 /* * Table describing the Tcl bytecode instructions: their name (for displaying * code), total number of code bytes required (including operand bytes), and a * description of the type of each operand. These operand types include signed * and unsigned integers of length one and four bytes. The unsigned integers * are used for indexes or for, e.g., the count of objects to push in a "push" * instruction. */ #define MAX_INSTRUCTION_OPERANDS 2 typedef enum InstOperandType { OPERAND_NONE, OPERAND_INT1, /* One byte signed integer. */ OPERAND_INT4, /* Four byte signed integer. */ OPERAND_UINT1, /* One byte unsigned integer. */ OPERAND_UINT4, /* Four byte unsigned integer. */ OPERAND_IDX4, /* Four byte signed index (actually an * integer, but displayed differently.) */ OPERAND_LVT1, /* One byte unsigned index into the local * variable table. */ OPERAND_LVT4 /* Four byte unsigned index into the local * variable table. */ } InstOperandType; typedef struct InstructionDesc { char *name; /* Name of instruction. */ int numBytes; /* Total number of bytes for instruction. */ int stackEffect; /* The worst-case balance stack effect of the * instruction, used for stack requirements * computations. The value INT_MIN signals * that the instruction's worst case effect is * (1-opnd1). */ int numOperands; /* Number of operands. */ InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS]; /* The type of each operand. */ } InstructionDesc; MODULE_SCOPE InstructionDesc tclInstructionTable[]; /* * 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 jumps to one * target PC. When we learn the target PC, we update the jumps with the * correct distance. Also, if the distance is too great (> 127 bytes), we * replace the single-byte jump with a four byte jump instruction, move the * instructions after the jump down, and update the code offsets for any * commands between the jump and the target. */ typedef enum { TCL_UNCONDITIONAL_JUMP, TCL_TRUE_JUMP, TCL_FALSE_JUMP } TclJumpType; typedef struct JumpFixup { TclJumpType jumpType; /* Indicates the kind of jump. */ int codeOffset; /* Offset of the first byte of the one-byte * forward jump's code. */ int cmdIndex; /* Index of the first command after the one * for which the jump was emitted. Used to * update the code offsets for subsequent * commands if the two-byte jump at jumpPc * must be replaced with a five-byte one. */ int exceptIndex; /* Index of the first range entry in the * ExceptionRange array after the current one. * This field is used to adjust the code * offsets in subsequent ExceptionRange * records when a jump is grown from 2 bytes * to 5 bytes. */ } JumpFixup; #define JUMPFIXUP_INIT_ENTRIES 10 typedef struct JumpFixupArray { JumpFixup *fixup; /* Points to start of jump fixup array. */ int next; /* Index of next free array entry. */ int end; /* Index of last usable entry in array. */ int mallocedArray; /* 1 if array was expanded and fixups points * into the heap, else 0. */ JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES]; /* Initial storage for jump fixup array. */ } JumpFixupArray; /* * The structure describing one variable list of a foreach command. Note that * only foreach commands inside procedure bodies are compiled inline so a * ForeachVarList structure always describes local variables. Furthermore, * only scalar variables are supported for inline-compiled foreach loops. */ typedef struct ForeachVarList { int numVars; /* The number of variables in the list. */ int varIndexes[1]; /* An array of the indexes ("slot numbers") * for each variable in the procedure's array * of local variables. Only scalar variables * are supported. The actual size of this * field will be large enough to numVars * indexes. THIS MUST BE THE LAST FIELD IN THE * STRUCTURE! */ } ForeachVarList; /* * Structure used to hold information about a foreach command that is needed * during program execution. These structures are stored in CompileEnv and * ByteCode structures as auxiliary data. */ typedef struct ForeachInfo { int numLists; /* The number of both the variable and value * lists of the foreach command. */ int firstValueTemp; /* Index of the first temp var in a proc frame * used to point to a value list. */ int loopCtTemp; /* Index of temp var in a proc frame holding * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large * enough to numVars indexes. THIS MUST BE THE * LAST FIELD IN THE STRUCTURE! */ } ForeachInfo; MODULE_SCOPE AuxDataType tclForeachInfoType; /* *---------------------------------------------------------------- * Procedures exported by tclBasic.c to be used within the engine. *---------------------------------------------------------------- */ MODULE_SCOPE int TclEvalObjvInternal _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], CONST char *command, int length, int flags)); /* *---------------------------------------------------------------- * Procedures exported by the engine to be used by tclBasic.c *---------------------------------------------------------------- */ /* * Declaration moved to the internal stubs table * MODULE_SCOPE int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); */ /* *---------------------------------------------------------------- * Procedures shared among Tcl bytecode compilation and execution * modules but not used outside: *---------------------------------------------------------------- */ |
︙ | ︙ | |||
807 808 809 810 811 812 813 | MODULE_SCOPE void TclFreeJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); MODULE_SCOPE void TclInitAuxDataTypeTable _ANSI_ARGS_((void)); MODULE_SCOPE void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr, CompileEnv *envPtr)); MODULE_SCOPE void TclInitCompilation _ANSI_ARGS_((void)); MODULE_SCOPE void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp, | | < | > | | | | | | > > > | < | > > > | > > > > > > > > > > > > | | | > | | | < | | | > > | | | | < | | | | | | 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 | MODULE_SCOPE void TclFreeJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); MODULE_SCOPE void TclInitAuxDataTypeTable _ANSI_ARGS_((void)); MODULE_SCOPE void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr, CompileEnv *envPtr)); MODULE_SCOPE void TclInitCompilation _ANSI_ARGS_((void)); MODULE_SCOPE void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp, CompileEnv *envPtr, char *string, int numBytes)); MODULE_SCOPE void TclInitJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); MODULE_SCOPE void TclInitLiteralTable _ANSI_ARGS_(( LiteralTable *tablePtr)); #ifdef TCL_COMPILE_STATS MODULE_SCOPE char * TclLiteralStats _ANSI_ARGS_(( LiteralTable *tablePtr)); MODULE_SCOPE int TclLog2 _ANSI_ARGS_((int value)); #endif #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); #endif MODULE_SCOPE int TclPrintInstruction _ANSI_ARGS_((ByteCode* codePtr, unsigned char *pc)); MODULE_SCOPE void TclPrintObject _ANSI_ARGS_((FILE *outFile, Tcl_Obj *objPtr, int maxChars)); MODULE_SCOPE void TclPrintSource _ANSI_ARGS_((FILE *outFile, CONST char *string, int maxChars)); MODULE_SCOPE void TclRegisterAuxDataType _ANSI_ARGS_(( AuxDataType *typePtr)); MODULE_SCOPE int TclRegisterLiteral _ANSI_ARGS_((CompileEnv *envPtr, char *bytes, int length, int flags)); MODULE_SCOPE void TclReleaseLiteral _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); MODULE_SCOPE void TclSetCmdNameObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr)); #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclVerifyGlobalLiteralTable _ANSI_ARGS_(( Interp *iPtr)); MODULE_SCOPE void TclVerifyLocalLiteralTable _ANSI_ARGS_(( CompileEnv *envPtr)); #endif MODULE_SCOPE int TclCompileVariableCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, CompileEnv *envPtr)); MODULE_SCOPE int TclWordKnownAtCompileTime _ANSI_ARGS_(( Tcl_Token *tokenPtr, Tcl_Obj *valuePtr)); /* *---------------------------------------------------------------- * Macros and flag values used by Tcl bytecode compilation and execution * modules inside the Tcl core but not used outside. *---------------------------------------------------------------- */ #define LITERAL_ON_HEAP 0x01 #define LITERAL_NS_SCOPE 0x02 /* * 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. * * int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes, * int length); */ #define TclRegisterNewLiteral(envPtr, bytes, length) \ TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0) /* * Form of TclRegisterNSLiteral 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. * * int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes, * int length); */ #define TclRegisterNewNSLiteral(envPtr, bytes, length) \ TclRegisterLiteral(envPtr, (char *)(bytes), length, \ /*flags*/ LITERAL_NS_SCOPE) /* * Macro used to manually adjust the stack requirements; used in cases where * the stack effect cannot be computed from the opcode and its operands, but * is still known at compile time. * * void TclAdjustStackDepth(int delta, CompileEnv *envPtr); */ #define TclAdjustStackDepth(delta, envPtr) \ if ((delta) < 0) {\ if((envPtr)->maxStackDepth < (envPtr)->currStackDepth) {\ (envPtr)->maxStackDepth = (envPtr)->currStackDepth;\ }\ }\ (envPtr)->currStackDepth += (delta) /* * 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. * * void TclUpdateStackReqs(unsigned char op, int i, CompileEnv *envPtr); */ #define TclUpdateStackReqs(op, i, envPtr) \ {\ int delta = tclInstructionTable[(op)].stackEffect;\ if (delta) {\ if (delta == INT_MIN) {\ delta = 1 - (i);\ }\ TclAdjustStackDepth(delta, envPtr);\ }\ } /* * Macro to emit an opcode byte into a CompileEnv's code array. The ANSI C * "prototype" for this macro is: * * void TclEmitOpcode(unsigned char op, CompileEnv *envPtr); */ #define TclEmitOpcode(op, envPtr) \ if ((envPtr)->codeNext == (envPtr)->codeEnd) \ TclExpandCodeArray(envPtr); \ *(envPtr)->codeNext++ = (unsigned char) (op);\ TclUpdateStackReqs(op, 0, envPtr) /* * Macros to emit an integer operand. The ANSI C "prototype" for these macros * are: * * void TclEmitInt1(int i, CompileEnv *envPtr); * void TclEmitInt4(int i, CompileEnv *envPtr); */ #define TclEmitInt1(i, envPtr) \ if ((envPtr)->codeNext == (envPtr)->codeEnd) \ TclExpandCodeArray(envPtr); \ *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)) |
︙ | ︙ | |||
940 941 942 943 944 945 946 | (unsigned char) ((unsigned int) (i) >> 8); \ *(envPtr)->codeNext++ = \ (unsigned char) ((unsigned int) (i) ) /* * Macros to emit an instruction with signed or unsigned integer operands. * Four byte integers are stored in "big-endian" order with the high order | | | < | < | < | 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 | (unsigned char) ((unsigned int) (i) >> 8); \ *(envPtr)->codeNext++ = \ (unsigned char) ((unsigned int) (i) ) /* * Macros to emit an instruction with signed or unsigned integer operands. * Four byte integers are stored in "big-endian" order with the high order * byte stored at the lowest address. The ANSI C "prototypes" for these * macros are: * * void TclEmitInstInt1(unsigned char op, int i, CompileEnv *envPtr); * void TclEmitInstInt4(unsigned char op, int i, CompileEnv *envPtr); */ #define TclEmitInstInt1(op, i, envPtr) \ if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \ TclExpandCodeArray(envPtr); \ } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i));\ |
︙ | ︙ | |||
975 976 977 978 979 980 981 | (unsigned char) ((unsigned int) (i) >> 8); \ *(envPtr)->codeNext++ = \ (unsigned char) ((unsigned int) (i) );\ TclUpdateStackReqs(op, i, envPtr) /* * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the | | | | | | | | | | | | | < | < | | | | | | | | | | | | | | | | | | < | | | | | | | 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 | (unsigned char) ((unsigned int) (i) >> 8); \ *(envPtr)->codeNext++ = \ (unsigned char) ((unsigned int) (i) );\ TclUpdateStackReqs(op, i, envPtr) /* * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the * object's one or four byte array index into the CompileEnv's code 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: * * void TclEmitPush(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: * * void TclStoreInt1AtPtr(int i, unsigned char *p); * void TclStoreInt4AtPtr(int i, unsigned char *p); */ #define TclStoreInt1AtPtr(i, p) \ *(p) = (unsigned char) ((unsigned int) (i)) #define TclStoreInt4AtPtr(i, p) \ *(p) = (unsigned char) ((unsigned int) (i) >> 24); \ *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \ *(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \ *(p+3) = (unsigned char) ((unsigned int) (i) ) /* * Macros to update instructions at a particular pc with a new op code and a * (signed or unsigned) int operand. The ANSI C "prototypes" for these macros * are: * * void TclUpdateInstInt1AtPc(unsigned char op, int i, unsigned char *pc); * void TclUpdateInstInt4AtPc(unsigned char op, int i, unsigned char *pc); */ #define TclUpdateInstInt1AtPc(op, i, pc) \ *(pc) = (unsigned char) (op); \ TclStoreInt1AtPtr((i), ((pc)+1)) #define TclUpdateInstInt4AtPc(op, i, pc) \ *(pc) = (unsigned char) (op); \ TclStoreInt4AtPtr((i), ((pc)+1)) /* * Macro to fix up a forward jump to point to the current code-generation * position in the bytecode being created (the most common case). The ANSI C * "prototypes" for this macro is: * * int TclFixupForwardJumpToHere(CompileEnv *envPtr, JumpFixup *fixupPtr, * int threshold); */ #define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \ TclFixupForwardJump((envPtr), (fixupPtr), \ (envPtr)->codeNext-(envPtr)->codeStart-(fixupPtr)->codeOffset, \ (threshold)) /* * Macros to get a signed integer (GET_INT{1,2}) or an unsigned int * (GET_UINT{1,2}) from a pointer. There are two variants for each return type * that depend on the number of bytes fetched. The ANSI C "prototypes" for * these macros are: * * int TclGetInt1AtPtr(unsigned char *p); * int TclGetInt4AtPtr(unsigned char *p); * unsigned int TclGetUInt1AtPtr(unsigned char *p); * unsigned int TclGetUInt4AtPtr(unsigned char *p); */ /* * The TclGetInt1AtPtr macro is tricky because we want to do sign extension on * the 1-byte value. Unfortunately the "char" type isn't signed on all * platforms so sign-extension doesn't always happen automatically. Sometimes * we can explicitly declare the pointer to be signed, but other times we have * to explicitly sign-extend the value in software. */ #ifndef __CHAR_UNSIGNED__ # define TclGetInt1AtPtr(p) ((int) *((char *) p)) #else # ifdef HAVE_SIGNED_CHAR # define TclGetInt1AtPtr(p) ((int) *((signed char *) p)) # else # define TclGetInt1AtPtr(p) (((int) *((char *) p)) \ | ((*(p) & 0200) ? (-256) : 0)) # endif #endif #define TclGetInt4AtPtr(p) (((int) TclGetInt1AtPtr(p) << 24) | \ (*((p)+1) << 16) | \ (*((p)+2) << 8) | \ (*((p)+3))) #define TclGetUInt1AtPtr(p) ((unsigned int) *(p)) #define TclGetUInt4AtPtr(p) ((unsigned int) (*(p) << 24) | \ (*((p)+1) << 16) | \ (*((p)+2) << 8) | \ (*((p)+3))) /* * Macros used to compute the minimum and maximum of two integers. The ANSI C * "prototypes" for these macros are: * * int TclMin(int i, int j); * int TclMax(int i, int j); */ #define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) #define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) #endif /* _TCLCOMPILATION */ |
Changes to generic/tclConfig.c.
|
| | | | | | | | < | | | < | | | < | < < | < < | | | | | | | | | | | | < | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < | < < < < < < | < < < < < < < < < < < < < < < > | | | < | > | > | | | | > | | | | | < < | < | | | < | < | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | /* * tclConfig.c -- * * This file provides the facilities which allow Tcl and other packages * to embed configuration information into their binary libraries. * * Copyright (c) 2002 Andreas Kupries <[email protected]> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclConfig.c,v 1.6.2.2 2005/08/02 18:15:22 dgp Exp $ */ #include "tclInt.h" /* * Internal structure to hold embedded configuration information. * * Our structure is a two-level dictionary associated with the 'interp'. The * first level is keyed with the package name and maps to the dictionary for * that package. The package dictionary is keyed with metadata keys and maps * to the metadata value for that key. This is package specific. The metadata * values are in UTF-8, converted from the external representation given to us * by the caller. */ #define ASSOC_KEY "tclPackageAboutDict" /* * Static functions in this file: */ static int QueryConfigObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv)); static void QueryConfigDelete _ANSI_ARGS_((ClientData clientData)); static Tcl_Obj * GetConfigDict _ANSI_ARGS_((Tcl_Interp* interp)); static void ConfigDictDeleteProc _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); /* *---------------------------------------------------------------------- * * Tcl_RegisterConfig -- * * See TIP#59 for details on what this function does. * * Results: * None. * * Side effects: * Creates namespace and cfg query command in it as per TIP #59. * *---------------------------------------------------------------------- */ void Tcl_RegisterConfig(interp, pkgName, configuration, valEncoding) Tcl_Interp *interp; /* Interpreter the configuration command is * registered in. */ CONST char *pkgName; /* Name of the package registering the * embedded configuration. ASCII, thus in * UTF-8 too. */ Tcl_Config *configuration; /* Embedded configuration. */ CONST char *valEncoding; /* Name of the encoding used to store the * configuration values, ASCII, thus UTF-8. */ { Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding); Tcl_Obj *pDB = GetConfigDict(interp); Tcl_Obj *pkg = Tcl_NewStringObj(pkgName, -1); Tcl_Obj *pkgDict; Tcl_DString cmdName; Tcl_Config *cfg; int res; /* * Phase I: Adding the provided information to the internal database of * package meta data. * * Phase II: Create a command for querying this database, specific to the * package registerting its configuration. This is the approved interface * in TIP 59. In the future a more general interface should be done, as * followup to TIP 59. Simply because our database is now general across * packages, and not a structure tied to one package. * * Note, the created command will have a reference through its clientdata. */ Tcl_IncrRefCount(pkg); /* * Retrieve package specific configuration... */ res = Tcl_DictObjGet(interp, pDB, pkg, &pkgDict); if ((TCL_OK != res) || (pkgDict == NULL)) { pkgDict = Tcl_NewDictObj(); } else if (Tcl_IsShared(pkgDict)) { pkgDict = Tcl_DuplicateObj(pkgDict); } /* * Extend the package configuration... */ for (cfg=configuration ; (cfg->key!=NULL) && (cfg->key[0]!='\0') ; cfg++) { Tcl_DString conv; CONST char *convValue = Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv); /* * We know that the keys are in ASCII/UTF-8, so for them is no * conversion required. */ Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1), Tcl_NewStringObj(convValue, -1)); Tcl_DStringFree(&conv); } /* * Write the changes back into the overall database. */ Tcl_DictObjPut(interp, pDB, pkg, pkgDict); /* * Now create the interface command for retrieval of the package * information. */ Tcl_DStringInit(&cmdName); Tcl_DStringAppend(&cmdName, "::", -1); Tcl_DStringAppend(&cmdName, pkgName, -1); /* * The incomplete command name is the name of the namespace to place it * in. */ if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL, TCL_GLOBAL_ONLY) == NULL) { if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName), (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL) == NULL) { Tcl_Panic("%s.\n%s %s", Tcl_GetStringResult(interp), "Tcl_RegisterConfig: Unable to create namespace for", "package configuration."); } } Tcl_DStringAppend(&cmdName, "::pkgconfig", -1); if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName), QueryConfigObjCmd, (ClientData) pkg, QueryConfigDelete) == NULL) { Tcl_Panic("%s %s", "Tcl_RegisterConfig: Unable to create query", "command for package configuration"); } Tcl_DStringFree(&cmdName); } /* *---------------------------------------------------------------------- * * QueryConfigObjCmd -- * |
︙ | ︙ | |||
186 187 188 189 190 191 192 | * See the manual for what this command does. * *---------------------------------------------------------------------- */ static int QueryConfigObjCmd(clientData, interp, objc, objv) | | | | | | | < | < | | > | > > > | 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 | * See the manual for what this command does. * *---------------------------------------------------------------------- */ static int QueryConfigObjCmd(clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; struct Tcl_Obj * CONST *objv; { Tcl_Obj *pkgName = (Tcl_Obj *) clientData; Tcl_Obj *pDB, *pkgDict, *val, *listPtr; int n, i, res, index; static CONST char *subcmdStrings[] = { "get", "list", NULL }; enum subcmds { CFG_GET, CFG_LIST }; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0, &index) != TCL_OK) { return TCL_ERROR; } pDB = GetConfigDict(interp); res = Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict); if (res!=TCL_OK || pkgDict==NULL) { /* * Maybe a Tcl_Panic is better, because the package data has to be * present. */ Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); return TCL_ERROR; } switch ((enum subcmds) index) { case CFG_GET: if (objc != 3) { |
︙ | ︙ | |||
244 245 246 247 248 249 250 | case CFG_LIST: if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } Tcl_DictObjSize(interp, pkgDict, &n); | > | > | > | > > > > > > | > > | | | > | | > | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > | 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 | case CFG_LIST: if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } Tcl_DictObjSize(interp, pkgDict, &n); listPtr = Tcl_NewListObj(n, NULL); if (!listPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj("insufficient memory to create list",-1)); return TCL_ERROR; } if (n) { List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; Tcl_DictSearch s; Tcl_Obj *key, **vals; int done; listRepPtr->elemCount = n; vals = &listRepPtr->elements; for (i=0, Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); !done; Tcl_DictObjNext(&s, &key, NULL, &done), i++) { vals[i] = key; Tcl_IncrRefCount(key); } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; default: Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen"); break; } return TCL_ERROR; } /* *------------------------------------------------------------------------- * * QueryConfigDelete -- * * Command delete function. Cleans up after the configuration query * command when it is deleted by the user or during finalization. * * Results: * None. * * Side effects: * Deallocates all non-transient memory allocated by Tcl_RegisterConfig. * *------------------------------------------------------------------------- */ static void QueryConfigDelete(clientData) ClientData clientData; { Tcl_Obj *pkgName = (Tcl_Obj *) clientData; Tcl_DecrRefCount(pkgName); } /* *------------------------------------------------------------------------- * * GetConfigDict -- * * Retrieve the package metadata database from the interpreter. * Initializes it, if not present yet. * * Results: * A Tcl_Obj reference * * Side effects: * May allocate a Tcl_Obj. * *------------------------------------------------------------------------- */ static Tcl_Obj * GetConfigDict(interp) Tcl_Interp *interp; { Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (pDB == (Tcl_Obj *) NULL) { pDB = Tcl_NewDictObj(); Tcl_IncrRefCount(pDB); Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB); } return pDB; } /* *---------------------------------------------------------------------- * * ConfigDictDeleteProc -- * * This function is associated with the "Package About dict" assoc data * for an interpreter; it is invoked when the interpreter is deleted in * order to free the information assoicated with any pending error * reports. * * Results: * None. * * Side effects: * The package metadata database is freed. * *---------------------------------------------------------------------- */ static void ConfigDictDeleteProc(clientData, interp) ClientData clientData; /* Pointer to Tcl_Obj. */ Tcl_Interp *interp; /* Interpreter being deleted. */ { Tcl_Obj *pDB = (Tcl_Obj *) clientData; Tcl_DecrRefCount(pDB); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclDate.c.
|
| | | | 1 2 3 4 5 6 7 8 9 10 11 | /* A Bison parser, made by GNU Bison 1.875b. */ /* Skeleton parser for Yacc-like parsing with Bison, Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, |
︙ | ︙ | |||
101 102 103 104 105 106 107 | #define tDAY_UNIT 274 #define tNEXT 275 /* Copy the first part of user declarations. */ | | | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 | #define tDAY_UNIT 274 #define tNEXT 275 /* Copy the first part of user declarations. */ /* * tclDate.c -- * * This file is generated from a yacc grammar defined in * the file tclGetDate.y. It should not be edited directly. * |
︙ | ︙ | |||
165 166 167 168 169 170 171 172 173 174 175 176 177 178 | time_t dateDayOrdinal; time_t dateDayNumber; int dateHaveDay; char *dateInput; time_t *dateRelPointer; } DateInfo; #define YYPARSE_PARAM info #define YYLEX_PARAM info #define yyDSTmode (((DateInfo*)info)->dateDSTmode) #define yyDayOrdinal (((DateInfo*)info)->dateDayOrdinal) | > > | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | time_t dateDayOrdinal; time_t dateDayNumber; int dateHaveDay; char *dateInput; time_t *dateRelPointer; int dateDigitCount; } DateInfo; #define YYPARSE_PARAM info #define YYLEX_PARAM info #define yyDSTmode (((DateInfo*)info)->dateDSTmode) #define yyDayOrdinal (((DateInfo*)info)->dateDayOrdinal) |
︙ | ︙ | |||
193 194 195 196 197 198 199 200 201 202 203 204 205 206 | #define yySeconds (((DateInfo*)info)->dateSeconds) #define yyMeridian (((DateInfo*)info)->dateMeridian) #define yyRelMonth (((DateInfo*)info)->dateRelMonth) #define yyRelDay (((DateInfo*)info)->dateRelDay) #define yyRelSeconds (((DateInfo*)info)->dateRelSeconds) #define yyRelPointer (((DateInfo*)info)->dateRelPointer) #define yyInput (((DateInfo*)info)->dateInput) #define EPOCH 1970 #define START_OF_TIME 1902 #define END_OF_TIME 2037 /* * The offset of tm_year of struct tm returned by localtime, gmtime, etc. | > | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 | #define yySeconds (((DateInfo*)info)->dateSeconds) #define yyMeridian (((DateInfo*)info)->dateMeridian) #define yyRelMonth (((DateInfo*)info)->dateRelMonth) #define yyRelDay (((DateInfo*)info)->dateRelDay) #define yyRelSeconds (((DateInfo*)info)->dateRelSeconds) #define yyRelPointer (((DateInfo*)info)->dateRelPointer) #define yyInput (((DateInfo*)info)->dateInput) #define yyDigitCount (((DateInfo*)info)->dateDigitCount) #define EPOCH 1970 #define START_OF_TIME 1902 #define END_OF_TIME 2037 /* * The offset of tm_year of struct tm returned by localtime, gmtime, etc. |
︙ | ︙ | |||
259 260 261 262 263 264 265 | # undef YYERROR_VERBOSE # define YYERROR_VERBOSE 1 #else # define YYERROR_VERBOSE 0 #endif #if ! defined (YYSTYPE) && ! defined (YYSTYPE_IS_DECLARED) | | | | | 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 | # undef YYERROR_VERBOSE # define YYERROR_VERBOSE 1 #else # define YYERROR_VERBOSE 0 #endif #if ! defined (YYSTYPE) && ! defined (YYSTYPE_IS_DECLARED) typedef union YYSTYPE { time_t Number; enum _MERIDIAN Meridian; } YYSTYPE; /* Line 191 of yacc.c. */ # define yystype YYSTYPE /* obsolescent; will be withdrawn */ # define YYSTYPE_IS_DECLARED 1 # define YYSTYPE_IS_TRIVIAL 1 #endif /* Copy the second part of user declarations. */ /* Line 214 of yacc.c. */ #if ! defined (yyoverflow) || YYERROR_VERBOSE /* The parser invokes alloca or malloc; define the necessary symbols. */ # if YYSTACK_USE_ALLOCA # define YYSTACK_ALLOC alloca |
︙ | ︙ | |||
466 467 468 469 470 471 472 | 14, 40, -1, 40, -1, 22, -1, 26, -1, 12, -1, 19, -1, 10, -1, 14, -1, -1, 7, -1 }; /* YYRLINE[YYN] -- source line where rule number YYN was defined. */ static const unsigned short yyrline[] = { | | | | | | | | 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 | 14, 40, -1, 40, -1, 22, -1, 26, -1, 12, -1, 19, -1, 10, -1, 14, -1, -1, 7, -1 }; /* YYRLINE[YYN] -- source line where rule number YYN was defined. */ static const unsigned short yyrline[] = { 0, 179, 179, 180, 183, 186, 189, 192, 195, 198, 201, 205, 210, 213, 219, 225, 233, 239, 250, 254, 258, 264, 268, 272, 276, 280, 286, 290, 295, 300, 305, 310, 314, 319, 323, 328, 335, 339, 345, 354, 363, 373, 386, 391, 393, 394, 395, 396, 397, 399, 400, 402, 403, 404, 407, 426, 429 }; #endif #if YYDEBUG || YYERROR_VERBOSE /* YYTNME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. First, the terminals, then, starting at YYNTOKENS, nonterminals. */ static const char *const yytname[] = |
︙ | ︙ | |||
637 638 639 640 641 642 643 644 645 646 647 648 649 650 | #define yyclearin (yychar = YYEMPTY) #define YYEMPTY (-2) #define YYEOF 0 #define YYACCEPT goto yyacceptlab #define YYABORT goto yyabortlab #define YYERROR goto yyerrlab1 /* Like YYERROR except do call yyerror. This remains here temporarily to ease the transition to the new meaning of YYERROR, for GCC. Once GCC version 2 has supplanted version 1, this can go. */ #define YYFAIL goto yyerrlab | > | 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 | #define yyclearin (yychar = YYEMPTY) #define YYEMPTY (-2) #define YYEOF 0 #define YYACCEPT goto yyacceptlab #define YYABORT goto yyabortlab #define YYERROR goto yyerrlab1 /* Like YYERROR except do call yyerror. This remains here temporarily to ease the transition to the new meaning of YYERROR, for GCC. Once GCC version 2 has supplanted version 1, this can go. */ #define YYFAIL goto yyerrlab |
︙ | ︙ | |||
758 759 760 761 762 763 764 | #else static void yy_reduce_print (yyrule) int yyrule; #endif { int yyi; | | | | 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 | #else static void yy_reduce_print (yyrule) int yyrule; #endif { int yyi; unsigned int yylno = yyrline[yyrule]; YYFPRINTF (stderr, "Reducing stack by rule %d (line %u), ", yyrule - 1, yylno); /* Print the symbols being reduced, and their result. */ for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++) YYFPRINTF (stderr, "%s ", yytname [yyrhs[yyi]]); YYFPRINTF (stderr, "-> %s\n", yytname [yyr1[yyrule]]); } # define YY_REDUCE_PRINT(Rule) \ |
︙ | ︙ | |||
1220 1221 1222 1223 1224 1225 1226 | yyval = yyvsp[1-yylen]; YY_REDUCE_PRINT (yyn); switch (yyn) { case 4: | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | yyval = yyvsp[1-yylen]; YY_REDUCE_PRINT (yyn); switch (yyn) { case 4: { yyHaveTime++; ;} break; case 5: { yyHaveZone++; ;} break; case 6: { yyHaveDate++; ;} break; case 7: { yyHaveOrdinalMonth++; ;} break; case 8: { yyHaveDay++; ;} break; case 9: { yyHaveRel++; ;} break; case 10: { yyHaveTime++; yyHaveDate++; ;} break; case 11: { yyHaveTime++; yyHaveDate++; yyHaveRel++; ;} break; case 13: { yyHour = yyvsp[-1].Number; yyMinutes = 0; yySeconds = 0; yyMeridian = yyvsp[0].Meridian; ;} break; case 14: { yyHour = yyvsp[-3].Number; yyMinutes = yyvsp[-1].Number; yySeconds = 0; yyMeridian = yyvsp[0].Meridian; ;} break; case 15: { yyHour = yyvsp[-4].Number; yyMinutes = yyvsp[-2].Number; yyMeridian = MER24; yyDSTmode = DSToff; yyTimezone = (yyvsp[0].Number % 100 + (yyvsp[0].Number / 100) * 60); ++yyHaveZone; ;} break; case 16: { yyHour = yyvsp[-5].Number; yyMinutes = yyvsp[-3].Number; yySeconds = yyvsp[-1].Number; yyMeridian = yyvsp[0].Meridian; ;} break; case 17: { yyHour = yyvsp[-6].Number; yyMinutes = yyvsp[-4].Number; yySeconds = yyvsp[-2].Number; yyMeridian = MER24; yyDSTmode = DSToff; yyTimezone = (yyvsp[0].Number % 100 + (yyvsp[0].Number / 100) * 60); ++yyHaveZone; ;} break; case 18: { yyTimezone = yyvsp[-1].Number; yyDSTmode = DSTon; ;} break; case 19: { yyTimezone = yyvsp[0].Number; yyDSTmode = DSToff; ;} break; case 20: { yyTimezone = yyvsp[0].Number; yyDSTmode = DSTon; ;} break; case 21: { yyDayOrdinal = 1; yyDayNumber = yyvsp[0].Number; ;} break; case 22: { yyDayOrdinal = 1; yyDayNumber = yyvsp[-1].Number; ;} break; case 23: { yyDayOrdinal = yyvsp[-1].Number; yyDayNumber = yyvsp[0].Number; ;} break; case 24: { yyDayOrdinal = yyvsp[-2].Number * yyvsp[-1].Number; yyDayNumber = yyvsp[0].Number; ;} break; case 25: { yyDayOrdinal = 2; yyDayNumber = yyvsp[0].Number; ;} break; case 26: { yyMonth = yyvsp[-2].Number; yyDay = yyvsp[0].Number; ;} break; case 27: { yyMonth = yyvsp[-4].Number; yyDay = yyvsp[-2].Number; yyYear = yyvsp[0].Number; ;} break; case 28: { yyYear = yyvsp[0].Number / 10000; yyMonth = (yyvsp[0].Number % 10000)/100; yyDay = yyvsp[0].Number % 100; ;} break; case 29: { yyDay = yyvsp[-4].Number; yyMonth = yyvsp[-2].Number; yyYear = yyvsp[0].Number; ;} break; case 30: { yyMonth = yyvsp[-2].Number; yyDay = yyvsp[0].Number; yyYear = yyvsp[-4].Number; ;} break; case 31: { yyMonth = yyvsp[-1].Number; yyDay = yyvsp[0].Number; ;} break; case 32: { yyMonth = yyvsp[-3].Number; yyDay = yyvsp[-2].Number; yyYear = yyvsp[0].Number; ;} break; case 33: { yyMonth = yyvsp[0].Number; yyDay = yyvsp[-1].Number; ;} break; case 34: { yyMonth = 1; yyDay = 1; yyYear = EPOCH; ;} break; case 35: { yyMonth = yyvsp[-1].Number; yyDay = yyvsp[-2].Number; yyYear = yyvsp[0].Number; ;} break; case 36: { yyMonthOrdinal = 1; yyMonth = yyvsp[0].Number; ;} break; case 37: { yyMonthOrdinal = yyvsp[-1].Number; yyMonth = yyvsp[0].Number; ;} break; case 38: { if (yyvsp[-1].Number != HOUR(- 7)) YYABORT; yyYear = yyvsp[-2].Number / 10000; yyMonth = (yyvsp[-2].Number % 10000)/100; yyDay = yyvsp[-2].Number % 100; yyHour = yyvsp[0].Number / 10000; yyMinutes = (yyvsp[0].Number % 10000)/100; yySeconds = yyvsp[0].Number % 100; ;} break; case 39: { if (yyvsp[-5].Number != HOUR(- 7)) YYABORT; yyYear = yyvsp[-6].Number / 10000; yyMonth = (yyvsp[-6].Number % 10000)/100; yyDay = yyvsp[-6].Number % 100; yyHour = yyvsp[-4].Number; yyMinutes = yyvsp[-2].Number; yySeconds = yyvsp[0].Number; ;} break; case 40: { yyYear = yyvsp[-1].Number / 10000; yyMonth = (yyvsp[-1].Number % 10000)/100; yyDay = yyvsp[-1].Number % 100; yyHour = yyvsp[0].Number / 10000; yyMinutes = (yyvsp[0].Number % 10000)/100; yySeconds = yyvsp[0].Number % 100; ;} break; case 41: { /* * Offset computed year by -377 so that the returned years will * be in a range accessible with a 32 bit clock seconds value */ yyYear = yyvsp[-2].Number/1000 + 2323 - 377; yyDay = 1; yyMonth = 1; yyRelDay += ((yyvsp[-2].Number%1000)*(365 + IsLeapYear(yyYear)))/1000; yyRelSeconds += yyvsp[0].Number * 144 * 60; ;} break; case 42: { yyRelSeconds *= -1; yyRelMonth *= -1; yyRelDay *= -1; ;} break; case 44: { *yyRelPointer += yyvsp[-2].Number * yyvsp[-1].Number * yyvsp[0].Number; ;} break; case 45: { *yyRelPointer += yyvsp[-1].Number * yyvsp[0].Number; ;} break; case 46: { *yyRelPointer += yyvsp[0].Number; ;} break; case 47: { *yyRelPointer += yyvsp[-1].Number * yyvsp[0].Number; ;} break; case 48: { *yyRelPointer += yyvsp[0].Number; ;} break; case 49: { yyval.Number = -1; ;} break; case 50: { yyval.Number = 1; ;} break; case 51: { yyval.Number = yyvsp[0].Number; yyRelPointer = &yyRelSeconds; ;} break; case 52: { yyval.Number = yyvsp[0].Number; yyRelPointer = &yyRelDay; ;} break; case 53: { yyval.Number = yyvsp[0].Number; yyRelPointer = &yyRelMonth; ;} break; case 54: { if (yyHaveTime && yyHaveDate && !yyHaveRel) { yyYear = yyvsp[0].Number; } else { yyHaveTime++; if (yyDigitCount <= 2) { yyHour = yyvsp[0].Number; yyMinutes = 0; } else { yyHour = yyvsp[0].Number / 100; yyMinutes = yyvsp[0].Number % 100; } yySeconds = 0; yyMeridian = MER24; } ;} break; case 55: { yyval.Meridian = MER24; ;} break; case 56: { yyval.Meridian = yyvsp[0].Meridian; ;} break; } /* Line 999 of yacc.c. */ yyvsp -= yylen; yyssp -= yylen; YY_STACK_PRINT (yyss, yyssp); |
︙ | ︙ | |||
1691 1692 1693 1694 1695 1696 1697 1698 | #if YYERROR_VERBOSE yyn = yypact[yystate]; if (YYPACT_NINF < yyn && yyn < YYLAST) { YYSIZE_T yysize = 0; int yytype = YYTRANSLATE (yychar); char *yymsg; | > | < | | > > > > > > > > | > > > > > > > | | | | < < < | | | 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 | #if YYERROR_VERBOSE yyn = yypact[yystate]; if (YYPACT_NINF < yyn && yyn < YYLAST) { YYSIZE_T yysize = 0; int yytype = YYTRANSLATE (yychar); const char* yyprefix; char *yymsg; int yyx; /* Start YYX at -YYN if negative to avoid negative indexes in YYCHECK. */ int yyxbegin = yyn < 0 ? -yyn : 0; /* Stay within bounds of both yycheck and yytname. */ int yychecklim = YYLAST - yyn; int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; int yycount = 0; yyprefix = ", expecting "; for (yyx = yyxbegin; yyx < yyxend; ++yyx) if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) { yysize += yystrlen (yyprefix) + yystrlen (yytname [yyx]); yycount += 1; if (yycount == 5) { yysize = 0; break; } } yysize += (sizeof ("syntax error, unexpected ") + yystrlen (yytname[yytype])); yymsg = (char *) YYSTACK_ALLOC (yysize); if (yymsg != 0) { char *yyp = yystpcpy (yymsg, "syntax error, unexpected "); yyp = yystpcpy (yyp, yytname[yytype]); if (yycount < 5) { yyprefix = ", expecting "; for (yyx = yyxbegin; yyx < yyxend; ++yyx) if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) { yyp = yystpcpy (yyp, yyprefix); yyp = yystpcpy (yyp, yytname[yyx]); yyprefix = " or "; } } yyerror (yymsg); YYSTACK_FREE (yymsg); } else yyerror ("syntax error; also virtual memory exhausted"); |
︙ | ︙ | |||
1764 1765 1766 1767 1768 1769 1770 | yydestruct (yytoken, &yylval); yychar = YYEMPTY; } /* Else will try to reuse lookahead token after shifting the error token. */ | | < < < < < < < < < < < < < < < < < | 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 | yydestruct (yytoken, &yylval); yychar = YYEMPTY; } /* Else will try to reuse lookahead token after shifting the error token. */ goto yyerrlab1; /*----------------------------------------------------. | yyerrlab1 -- error raised explicitly by an action. | `----------------------------------------------------*/ yyerrlab1: yyerrstatus = 3; /* Each real token shifted decrements this. */ for (;;) { yyn = yypact[yystate]; if (yyn != YYPACT_NINF) { |
︙ | ︙ | |||
1861 1862 1863 1864 1865 1866 1867 | if (yyss != yyssa) YYSTACK_FREE (yyss); #endif return yyresult; } | | | 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 | if (yyss != yyssa) YYSTACK_FREE (yyss); #endif return yyresult; } /* * Month and day table. */ static TABLE MonthDayTable[] = { { "january", tMONTH, 1 }, |
︙ | ︙ | |||
2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 | Count = 0; for (yylval.Number = 0; isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */ yylval.Number = 10 * yylval.Number + c - '0'; Count++; } yyInput--; /* A number with 6 or more digits is considered an ISO 8601 base */ if (Count >= 6) { return tISOBASE; } else { return tUNUMBER; } } | > | 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 | Count = 0; for (yylval.Number = 0; isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */ yylval.Number = 10 * yylval.Number + c - '0'; Count++; } yyInput--; yyDigitCount = Count; /* A number with 6 or more digits is considered an ISO 8601 base */ if (Count >= 6) { return tISOBASE; } else { return tUNUMBER; } } |
︙ | ︙ |
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.107.2.9 2005/09/20 14:11:51 dgp Exp $ */ #ifndef _TCLDECLS #define _TCLDECLS #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl |
︙ | ︙ | |||
51 52 53 54 55 56 57 | Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); #endif #ifndef Tcl_Panic_TCL_DECLARED #define Tcl_Panic_TCL_DECLARED /* 2 */ | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); #endif #ifndef Tcl_Panic_TCL_DECLARED #define Tcl_Panic_TCL_DECLARED /* 2 */ EXTERN void Tcl_Panic _ANSI_ARGS_((CONST char *format, ...)); #endif #ifndef Tcl_Alloc_TCL_DECLARED #define Tcl_Alloc_TCL_DECLARED /* 3 */ EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size)); #endif #ifndef Tcl_Free_TCL_DECLARED |
︙ | ︙ | |||
127 128 129 130 131 132 133 | /* 14 */ EXTERN int Tcl_AppendAllObjTypes _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr)); #endif #ifndef Tcl_AppendStringsToObj_TCL_DECLARED #define Tcl_AppendStringsToObj_TCL_DECLARED /* 15 */ | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | /* 14 */ EXTERN int Tcl_AppendAllObjTypes _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr)); #endif #ifndef Tcl_AppendStringsToObj_TCL_DECLARED #define Tcl_AppendStringsToObj_TCL_DECLARED /* 15 */ EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_((Tcl_Obj *objPtr, ...)); #endif #ifndef Tcl_AppendToObj_TCL_DECLARED #define Tcl_AppendToObj_TCL_DECLARED /* 16 */ EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); #endif |
︙ | ︙ | |||
223 224 225 226 227 228 229 | /* 30 */ EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj * objPtr)); #endif #ifndef Tcl_GetBoolean_TCL_DECLARED #define Tcl_GetBoolean_TCL_DECLARED /* 31 */ EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp * interp, | | | | | 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 | /* 30 */ EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj * objPtr)); #endif #ifndef Tcl_GetBoolean_TCL_DECLARED #define Tcl_GetBoolean_TCL_DECLARED /* 31 */ EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp * interp, CONST char * src, int * boolPtr)); #endif #ifndef Tcl_GetBooleanFromObj_TCL_DECLARED #define Tcl_GetBooleanFromObj_TCL_DECLARED /* 32 */ EXTERN int Tcl_GetBooleanFromObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, int * boolPtr)); #endif #ifndef Tcl_GetByteArrayFromObj_TCL_DECLARED #define Tcl_GetByteArrayFromObj_TCL_DECLARED /* 33 */ EXTERN unsigned char * Tcl_GetByteArrayFromObj _ANSI_ARGS_(( Tcl_Obj * objPtr, int * lengthPtr)); #endif #ifndef Tcl_GetDouble_TCL_DECLARED #define Tcl_GetDouble_TCL_DECLARED /* 34 */ EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp * interp, CONST char * src, double * doublePtr)); #endif #ifndef Tcl_GetDoubleFromObj_TCL_DECLARED #define Tcl_GetDoubleFromObj_TCL_DECLARED /* 35 */ EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr)); #endif #ifndef Tcl_GetIndexFromObj_TCL_DECLARED #define Tcl_GetIndexFromObj_TCL_DECLARED /* 36 */ EXTERN int Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST84 char ** tablePtr, CONST char * msg, int flags, int * indexPtr)); #endif #ifndef Tcl_GetInt_TCL_DECLARED #define Tcl_GetInt_TCL_DECLARED /* 37 */ EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp * interp, CONST char * src, int * intPtr)); #endif #ifndef Tcl_GetIntFromObj_TCL_DECLARED #define Tcl_GetIntFromObj_TCL_DECLARED /* 38 */ EXTERN int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); #endif |
︙ | ︙ | |||
452 453 454 455 456 457 458 | /* 68 */ EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp * interp)); #endif #ifndef Tcl_AppendElement_TCL_DECLARED #define Tcl_AppendElement_TCL_DECLARED /* 69 */ EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp, | | | | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 | /* 68 */ EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp * interp)); #endif #ifndef Tcl_AppendElement_TCL_DECLARED #define Tcl_AppendElement_TCL_DECLARED /* 69 */ EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp, CONST char * element)); #endif #ifndef Tcl_AppendResult_TCL_DECLARED #define Tcl_AppendResult_TCL_DECLARED /* 70 */ EXTERN void Tcl_AppendResult _ANSI_ARGS_((Tcl_Interp *interp, ...)); #endif #ifndef Tcl_AsyncCreate_TCL_DECLARED #define Tcl_AsyncCreate_TCL_DECLARED /* 71 */ EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); #endif |
︙ | ︙ | |||
768 769 770 771 772 773 774 | EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc * proc, ClientData clientData)); #endif #ifndef Tcl_DStringAppend_TCL_DECLARED #define Tcl_DStringAppend_TCL_DECLARED /* 117 */ EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString * dsPtr, | | | | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 | EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc * proc, ClientData clientData)); #endif #ifndef Tcl_DStringAppend_TCL_DECLARED #define Tcl_DStringAppend_TCL_DECLARED /* 117 */ EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * bytes, int length)); #endif #ifndef Tcl_DStringAppendElement_TCL_DECLARED #define Tcl_DStringAppendElement_TCL_DECLARED /* 118 */ EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_(( Tcl_DString * dsPtr, CONST char * element)); #endif #ifndef Tcl_DStringEndSublist_TCL_DECLARED #define Tcl_DStringEndSublist_TCL_DECLARED /* 119 */ EXTERN void Tcl_DStringEndSublist _ANSI_ARGS_(( Tcl_DString * dsPtr)); #endif |
︙ | ︙ | |||
835 836 837 838 839 840 841 | /* 128 */ EXTERN CONST84_RETURN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err)); #endif #ifndef Tcl_Eval_TCL_DECLARED #define Tcl_Eval_TCL_DECLARED /* 129 */ EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp * interp, | | | 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 | /* 128 */ EXTERN CONST84_RETURN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err)); #endif #ifndef Tcl_Eval_TCL_DECLARED #define Tcl_Eval_TCL_DECLARED /* 129 */ EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script)); #endif #ifndef Tcl_EvalFile_TCL_DECLARED #define Tcl_EvalFile_TCL_DECLARED /* 130 */ EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName)); #endif |
︙ | ︙ | |||
872 873 874 875 876 877 878 | CONST char * hiddenCmdToken, CONST char * cmdName)); #endif #ifndef Tcl_ExprBoolean_TCL_DECLARED #define Tcl_ExprBoolean_TCL_DECLARED /* 135 */ EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp * interp, | | | | | | 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 | CONST char * hiddenCmdToken, CONST char * cmdName)); #endif #ifndef Tcl_ExprBoolean_TCL_DECLARED #define Tcl_ExprBoolean_TCL_DECLARED /* 135 */ EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp * interp, CONST char * expr, int * ptr)); #endif #ifndef Tcl_ExprBooleanObj_TCL_DECLARED #define Tcl_ExprBooleanObj_TCL_DECLARED /* 136 */ EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); #endif #ifndef Tcl_ExprDouble_TCL_DECLARED #define Tcl_ExprDouble_TCL_DECLARED /* 137 */ EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp * interp, CONST char * expr, double * ptr)); #endif #ifndef Tcl_ExprDoubleObj_TCL_DECLARED #define Tcl_ExprDoubleObj_TCL_DECLARED /* 138 */ EXTERN int Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); #endif #ifndef Tcl_ExprLong_TCL_DECLARED #define Tcl_ExprLong_TCL_DECLARED /* 139 */ EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp * interp, CONST char * expr, long * ptr)); #endif #ifndef Tcl_ExprLongObj_TCL_DECLARED #define Tcl_ExprLongObj_TCL_DECLARED /* 140 */ EXTERN int Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); #endif #ifndef Tcl_ExprObj_TCL_DECLARED #define Tcl_ExprObj_TCL_DECLARED /* 141 */ EXTERN int Tcl_ExprObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); #endif #ifndef Tcl_ExprString_TCL_DECLARED #define Tcl_ExprString_TCL_DECLARED /* 142 */ EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp * interp, CONST char * expr)); #endif #ifndef Tcl_Finalize_TCL_DECLARED #define Tcl_Finalize_TCL_DECLARED /* 143 */ EXTERN void Tcl_Finalize _ANSI_ARGS_((void)); #endif #ifndef Tcl_FindExecutable_TCL_DECLARED |
︙ | ︙ | |||
1064 1065 1066 1067 1068 1069 1070 | EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp * interp)); #endif #if !defined(__WIN32__) /* UNIX */ #ifndef Tcl_GetOpenFile_TCL_DECLARED #define Tcl_GetOpenFile_TCL_DECLARED /* 167 */ EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp, | | | 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 | EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp * interp)); #endif #if !defined(__WIN32__) /* UNIX */ #ifndef Tcl_GetOpenFile_TCL_DECLARED #define Tcl_GetOpenFile_TCL_DECLARED /* 167 */ EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp, CONST char * chanID, int forWriting, int checkUsage, ClientData * filePtr)); #endif #endif /* UNIX */ #ifndef Tcl_GetPathType_TCL_DECLARED #define Tcl_GetPathType_TCL_DECLARED /* 168 */ EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((CONST char * path)); |
︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 | /* 202 */ EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp * interp, double value, char * dst)); #endif #ifndef Tcl_PutEnv_TCL_DECLARED #define Tcl_PutEnv_TCL_DECLARED /* 203 */ | | | 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 | /* 202 */ EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp * interp, double value, char * dst)); #endif #ifndef Tcl_PutEnv_TCL_DECLARED #define Tcl_PutEnv_TCL_DECLARED /* 203 */ EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char * assignment)); #endif #ifndef Tcl_PosixError_TCL_DECLARED #define Tcl_PosixError_TCL_DECLARED /* 204 */ EXTERN CONST84_RETURN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp * interp)); #endif #ifndef Tcl_QueueEvent_TCL_DECLARED |
︙ | ︙ | |||
1349 1350 1351 1352 1353 1354 1355 | EXTERN void Tcl_RegisterObjType _ANSI_ARGS_(( Tcl_ObjType * typePtr)); #endif #ifndef Tcl_RegExpCompile_TCL_DECLARED #define Tcl_RegExpCompile_TCL_DECLARED /* 212 */ EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp * interp, | | | | | 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 | EXTERN void Tcl_RegisterObjType _ANSI_ARGS_(( Tcl_ObjType * typePtr)); #endif #ifndef Tcl_RegExpCompile_TCL_DECLARED #define Tcl_RegExpCompile_TCL_DECLARED /* 212 */ EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); #endif #ifndef Tcl_RegExpExec_TCL_DECLARED #define Tcl_RegExpExec_TCL_DECLARED /* 213 */ EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * text, CONST char * start)); #endif #ifndef Tcl_RegExpMatch_TCL_DECLARED #define Tcl_RegExpMatch_TCL_DECLARED /* 214 */ EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp * interp, CONST char * text, CONST char * pattern)); #endif #ifndef Tcl_RegExpRange_TCL_DECLARED #define Tcl_RegExpRange_TCL_DECLARED /* 215 */ EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp, int index, CONST84 char ** startPtr, CONST84 char ** endPtr)); |
︙ | ︙ | |||
1446 1447 1448 1449 1450 1451 1452 | #define Tcl_SetErrno_TCL_DECLARED /* 227 */ EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err)); #endif #ifndef Tcl_SetErrorCode_TCL_DECLARED #define Tcl_SetErrorCode_TCL_DECLARED /* 228 */ | | | 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 | #define Tcl_SetErrno_TCL_DECLARED /* 227 */ EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err)); #endif #ifndef Tcl_SetErrorCode_TCL_DECLARED #define Tcl_SetErrorCode_TCL_DECLARED /* 228 */ EXTERN void Tcl_SetErrorCode _ANSI_ARGS_((Tcl_Interp *interp, ...)); #endif #ifndef Tcl_SetMaxBlockTime_TCL_DECLARED #define Tcl_SetMaxBlockTime_TCL_DECLARED /* 229 */ EXTERN void Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time * timePtr)); #endif #ifndef Tcl_SetPanicProc_TCL_DECLARED |
︙ | ︙ | |||
1469 1470 1471 1472 1473 1474 1475 | EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_(( Tcl_Interp * interp, int depth)); #endif #ifndef Tcl_SetResult_TCL_DECLARED #define Tcl_SetResult_TCL_DECLARED /* 232 */ EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp * interp, | | | 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 | EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_(( Tcl_Interp * interp, int depth)); #endif #ifndef Tcl_SetResult_TCL_DECLARED #define Tcl_SetResult_TCL_DECLARED /* 232 */ EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp * interp, char * result, Tcl_FreeProc * freeProc)); #endif #ifndef Tcl_SetServiceMode_TCL_DECLARED #define Tcl_SetServiceMode_TCL_DECLARED /* 233 */ EXTERN int Tcl_SetServiceMode _ANSI_ARGS_((int mode)); #endif #ifndef Tcl_SetObjErrorCode_TCL_DECLARED |
︙ | ︙ | |||
1649 1650 1651 1652 1653 1654 1655 | CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); #endif #ifndef Tcl_VarEval_TCL_DECLARED #define Tcl_VarEval_TCL_DECLARED /* 260 */ | | | 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 | CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); #endif #ifndef Tcl_VarEval_TCL_DECLARED #define Tcl_VarEval_TCL_DECLARED /* 260 */ EXTERN int Tcl_VarEval _ANSI_ARGS_((Tcl_Interp *interp, ...)); #endif #ifndef Tcl_VarTraceInfo_TCL_DECLARED #define Tcl_VarTraceInfo_TCL_DECLARED /* 261 */ EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, |
︙ | ︙ | |||
1714 1715 1716 1717 1718 1719 1720 | EXTERN CONST84_RETURN char * Tcl_HashStats _ANSI_ARGS_(( Tcl_HashTable * tablePtr)); #endif #ifndef Tcl_ParseVar_TCL_DECLARED #define Tcl_ParseVar_TCL_DECLARED /* 270 */ EXTERN CONST84_RETURN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp, | | | 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 | EXTERN CONST84_RETURN char * Tcl_HashStats _ANSI_ARGS_(( Tcl_HashTable * tablePtr)); #endif #ifndef Tcl_ParseVar_TCL_DECLARED #define Tcl_ParseVar_TCL_DECLARED /* 270 */ EXTERN CONST84_RETURN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, CONST84 char ** termPtr)); #endif #ifndef Tcl_PkgPresent_TCL_DECLARED #define Tcl_PkgPresent_TCL_DECLARED /* 271 */ EXTERN CONST84_RETURN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); |
︙ | ︙ | |||
1966 1967 1968 1969 1970 1971 1972 | Tcl_Condition * condPtr, Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); #endif #ifndef Tcl_NumUtfChars_TCL_DECLARED #define Tcl_NumUtfChars_TCL_DECLARED /* 312 */ EXTERN int Tcl_NumUtfChars _ANSI_ARGS_((CONST char * src, | | | 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 | Tcl_Condition * condPtr, Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); #endif #ifndef Tcl_NumUtfChars_TCL_DECLARED #define Tcl_NumUtfChars_TCL_DECLARED /* 312 */ EXTERN int Tcl_NumUtfChars _ANSI_ARGS_((CONST char * src, int length)); #endif #ifndef Tcl_ReadChars_TCL_DECLARED #define Tcl_ReadChars_TCL_DECLARED /* 313 */ EXTERN int Tcl_ReadChars _ANSI_ARGS_((Tcl_Channel channel, Tcl_Obj * objPtr, int charsToRead, int appendFlag)); |
︙ | ︙ | |||
2048 2049 2050 2051 2052 2053 2054 | EXTERN CONST84_RETURN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src, int index)); #endif #ifndef Tcl_UtfCharComplete_TCL_DECLARED #define Tcl_UtfCharComplete_TCL_DECLARED /* 326 */ EXTERN int Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src, | | | 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 | EXTERN CONST84_RETURN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src, int index)); #endif #ifndef Tcl_UtfCharComplete_TCL_DECLARED #define Tcl_UtfCharComplete_TCL_DECLARED /* 326 */ EXTERN int Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src, int length)); #endif #ifndef Tcl_UtfBackslash_TCL_DECLARED #define Tcl_UtfBackslash_TCL_DECLARED /* 327 */ EXTERN int Tcl_UtfBackslash _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); #endif |
︙ | ︙ | |||
2193 2194 2195 2196 2197 2198 2199 | #define Tcl_UniCharIsWordChar_TCL_DECLARED /* 351 */ EXTERN int Tcl_UniCharIsWordChar _ANSI_ARGS_((int ch)); #endif #ifndef Tcl_UniCharLen_TCL_DECLARED #define Tcl_UniCharLen_TCL_DECLARED /* 352 */ | | > | | > | | | 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 | #define Tcl_UniCharIsWordChar_TCL_DECLARED /* 351 */ EXTERN int Tcl_UniCharIsWordChar _ANSI_ARGS_((int ch)); #endif #ifndef Tcl_UniCharLen_TCL_DECLARED #define Tcl_UniCharLen_TCL_DECLARED /* 352 */ EXTERN int Tcl_UniCharLen _ANSI_ARGS_(( CONST Tcl_UniChar * uniStr)); #endif #ifndef Tcl_UniCharNcmp_TCL_DECLARED #define Tcl_UniCharNcmp_TCL_DECLARED /* 353 */ EXTERN int Tcl_UniCharNcmp _ANSI_ARGS_((CONST Tcl_UniChar * ucs, CONST Tcl_UniChar * uct, unsigned long numChars)); #endif #ifndef Tcl_UniCharToUtfDString_TCL_DECLARED #define Tcl_UniCharToUtfDString_TCL_DECLARED /* 354 */ EXTERN char * Tcl_UniCharToUtfDString _ANSI_ARGS_(( CONST Tcl_UniChar * uniStr, int uniLength, Tcl_DString * dsPtr)); #endif #ifndef Tcl_UtfToUniCharDString_TCL_DECLARED #define Tcl_UtfToUniCharDString_TCL_DECLARED /* 355 */ EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString _ANSI_ARGS_(( CONST char * src, int length, Tcl_DString * dsPtr)); #endif #ifndef Tcl_GetRegExpFromObj_TCL_DECLARED #define Tcl_GetRegExpFromObj_TCL_DECLARED /* 356 */ EXTERN Tcl_RegExp Tcl_GetRegExpFromObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * patObj, |
︙ | ︙ | |||
2244 2245 2246 2247 2248 2249 2250 | CONST char * script, CONST char * command, int length)); #endif #ifndef Tcl_ParseBraces_TCL_DECLARED #define Tcl_ParseBraces_TCL_DECLARED /* 360 */ EXTERN int Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp, | | | | | | | | 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 | CONST char * script, CONST char * command, int length)); #endif #ifndef Tcl_ParseBraces_TCL_DECLARED #define Tcl_ParseBraces_TCL_DECLARED /* 360 */ EXTERN int Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); #endif #ifndef Tcl_ParseCommand_TCL_DECLARED #define Tcl_ParseCommand_TCL_DECLARED /* 361 */ EXTERN int Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, int nested, Tcl_Parse * parsePtr)); #endif #ifndef Tcl_ParseExpr_TCL_DECLARED #define Tcl_ParseExpr_TCL_DECLARED /* 362 */ EXTERN int Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr)); #endif #ifndef Tcl_ParseQuotedString_TCL_DECLARED #define Tcl_ParseQuotedString_TCL_DECLARED /* 363 */ EXTERN int Tcl_ParseQuotedString _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); #endif #ifndef Tcl_ParseVarName_TCL_DECLARED #define Tcl_ParseVarName_TCL_DECLARED /* 364 */ EXTERN int Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr, int append)); #endif #ifndef Tcl_GetCwd_TCL_DECLARED #define Tcl_GetCwd_TCL_DECLARED /* 365 */ EXTERN char * Tcl_GetCwd _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); |
︙ | ︙ | |||
2341 2342 2343 2344 2345 2346 2347 | /* 375 */ EXTERN int Tcl_UniCharIsPunct _ANSI_ARGS_((int ch)); #endif #ifndef Tcl_RegExpExecObj_TCL_DECLARED #define Tcl_RegExpExecObj_TCL_DECLARED /* 376 */ EXTERN int Tcl_RegExpExecObj _ANSI_ARGS_((Tcl_Interp * interp, | | | 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 | /* 375 */ EXTERN int Tcl_UniCharIsPunct _ANSI_ARGS_((int ch)); #endif #ifndef Tcl_RegExpExecObj_TCL_DECLARED #define Tcl_RegExpExecObj_TCL_DECLARED /* 376 */ EXTERN int Tcl_RegExpExecObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, Tcl_Obj * textObj, int offset, int nmatches, int flags)); #endif #ifndef Tcl_RegExpGetInfo_TCL_DECLARED #define Tcl_RegExpGetInfo_TCL_DECLARED /* 377 */ EXTERN void Tcl_RegExpGetInfo _ANSI_ARGS_((Tcl_RegExp regexp, Tcl_RegExpInfo * infoPtr)); |
︙ | ︙ | |||
2394 2395 2396 2397 2398 2399 2400 | EXTERN void Tcl_AppendUnicodeToObj _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int length)); #endif #ifndef Tcl_RegExpMatchObj_TCL_DECLARED #define Tcl_RegExpMatchObj_TCL_DECLARED /* 385 */ EXTERN int Tcl_RegExpMatchObj _ANSI_ARGS_((Tcl_Interp * interp, | | | 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 | EXTERN void Tcl_AppendUnicodeToObj _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int length)); #endif #ifndef Tcl_RegExpMatchObj_TCL_DECLARED #define Tcl_RegExpMatchObj_TCL_DECLARED /* 385 */ EXTERN int Tcl_RegExpMatchObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * textObj, Tcl_Obj * patternObj)); #endif #ifndef Tcl_SetNotifier_TCL_DECLARED #define Tcl_SetNotifier_TCL_DECLARED /* 386 */ EXTERN void Tcl_SetNotifier _ANSI_ARGS_(( Tcl_NotifierProcs * notifierProcPtr)); #endif |
︙ | ︙ | |||
2593 2594 2595 2596 2597 2598 2599 | EXTERN int Tcl_IsChannelExisting _ANSI_ARGS_(( CONST char* channelName)); #endif #ifndef Tcl_UniCharNcasecmp_TCL_DECLARED #define Tcl_UniCharNcasecmp_TCL_DECLARED /* 419 */ EXTERN int Tcl_UniCharNcasecmp _ANSI_ARGS_(( | | | > | | | 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 | EXTERN int Tcl_IsChannelExisting _ANSI_ARGS_(( CONST char* channelName)); #endif #ifndef Tcl_UniCharNcasecmp_TCL_DECLARED #define Tcl_UniCharNcasecmp_TCL_DECLARED /* 419 */ EXTERN int Tcl_UniCharNcasecmp _ANSI_ARGS_(( CONST Tcl_UniChar * ucs, CONST Tcl_UniChar * uct, unsigned long numChars)); #endif #ifndef Tcl_UniCharCaseMatch_TCL_DECLARED #define Tcl_UniCharCaseMatch_TCL_DECLARED /* 420 */ EXTERN int Tcl_UniCharCaseMatch _ANSI_ARGS_(( CONST Tcl_UniChar * uniStr, CONST Tcl_UniChar * uniPattern, int nocase)); #endif #ifndef Tcl_FindHashEntry_TCL_DECLARED #define Tcl_FindHashEntry_TCL_DECLARED /* 421 */ EXTERN Tcl_HashEntry * Tcl_FindHashEntry _ANSI_ARGS_(( Tcl_HashTable * tablePtr, CONST char * key)); #endif |
︙ | ︙ | |||
3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 | #endif #ifndef Tcl_GetReturnOptions_TCL_DECLARED #define Tcl_GetReturnOptions_TCL_DECLARED /* 539 */ EXTERN Tcl_Obj * Tcl_GetReturnOptions _ANSI_ARGS_(( Tcl_Interp * interp, int result)); #endif typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; struct TclIntStubs *tclIntStubs; struct TclIntPlatStubs *tclIntPlatStubs; } 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 */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 | #endif #ifndef Tcl_GetReturnOptions_TCL_DECLARED #define Tcl_GetReturnOptions_TCL_DECLARED /* 539 */ EXTERN Tcl_Obj * Tcl_GetReturnOptions _ANSI_ARGS_(( Tcl_Interp * interp, int result)); #endif #ifndef Tcl_IsEnsemble_TCL_DECLARED #define Tcl_IsEnsemble_TCL_DECLARED /* 540 */ EXTERN int Tcl_IsEnsemble _ANSI_ARGS_((Tcl_Command token)); #endif #ifndef Tcl_CreateEnsemble_TCL_DECLARED #define Tcl_CreateEnsemble_TCL_DECLARED /* 541 */ EXTERN Tcl_Command Tcl_CreateEnsemble _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * namespacePtr, int flags)); #endif #ifndef Tcl_FindEnsemble_TCL_DECLARED #define Tcl_FindEnsemble_TCL_DECLARED /* 542 */ EXTERN Tcl_Command Tcl_FindEnsemble _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * cmdNameObj, int flags)); #endif #ifndef Tcl_SetEnsembleSubcommandList_TCL_DECLARED #define Tcl_SetEnsembleSubcommandList_TCL_DECLARED /* 543 */ EXTERN int Tcl_SetEnsembleSubcommandList _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * subcmdList)); #endif #ifndef Tcl_SetEnsembleMappingDict_TCL_DECLARED #define Tcl_SetEnsembleMappingDict_TCL_DECLARED /* 544 */ EXTERN int Tcl_SetEnsembleMappingDict _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * mapDict)); #endif #ifndef Tcl_SetEnsembleUnknownHandler_TCL_DECLARED #define Tcl_SetEnsembleUnknownHandler_TCL_DECLARED /* 545 */ EXTERN int Tcl_SetEnsembleUnknownHandler _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * unknownList)); #endif #ifndef Tcl_SetEnsembleFlags_TCL_DECLARED #define Tcl_SetEnsembleFlags_TCL_DECLARED /* 546 */ EXTERN int Tcl_SetEnsembleFlags _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command token, int flags)); #endif #ifndef Tcl_GetEnsembleSubcommandList_TCL_DECLARED #define Tcl_GetEnsembleSubcommandList_TCL_DECLARED /* 547 */ EXTERN int Tcl_GetEnsembleSubcommandList _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** subcmdListPtr)); #endif #ifndef Tcl_GetEnsembleMappingDict_TCL_DECLARED #define Tcl_GetEnsembleMappingDict_TCL_DECLARED /* 548 */ EXTERN int Tcl_GetEnsembleMappingDict _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** mapDictPtr)); #endif #ifndef Tcl_GetEnsembleUnknownHandler_TCL_DECLARED #define Tcl_GetEnsembleUnknownHandler_TCL_DECLARED /* 549 */ EXTERN int Tcl_GetEnsembleUnknownHandler _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** unknownListPtr)); #endif #ifndef Tcl_GetEnsembleFlags_TCL_DECLARED #define Tcl_GetEnsembleFlags_TCL_DECLARED /* 550 */ EXTERN int Tcl_GetEnsembleFlags _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command token, int * flagsPtr)); #endif #ifndef Tcl_GetEnsembleNamespace_TCL_DECLARED #define Tcl_GetEnsembleNamespace_TCL_DECLARED /* 551 */ EXTERN int Tcl_GetEnsembleNamespace _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command token, Tcl_Namespace ** namespacePtrPtr)); #endif #ifndef Tcl_SetTimeProc_TCL_DECLARED #define Tcl_SetTimeProc_TCL_DECLARED /* 552 */ EXTERN void Tcl_SetTimeProc _ANSI_ARGS_(( Tcl_GetTimeProc* getProc, Tcl_ScaleTimeProc* scaleProc, ClientData clientData)); #endif #ifndef Tcl_QueryTimeProc_TCL_DECLARED #define Tcl_QueryTimeProc_TCL_DECLARED /* 553 */ EXTERN void Tcl_QueryTimeProc _ANSI_ARGS_(( Tcl_GetTimeProc** getProc, Tcl_ScaleTimeProc** scaleProc, ClientData* clientData)); #endif #ifndef Tcl_ChannelThreadActionProc_TCL_DECLARED #define Tcl_ChannelThreadActionProc_TCL_DECLARED /* 554 */ EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); #endif #ifndef Tcl_NewBignumObj_TCL_DECLARED #define Tcl_NewBignumObj_TCL_DECLARED /* 555 */ EXTERN Tcl_Obj* Tcl_NewBignumObj _ANSI_ARGS_((mp_int* value)); #endif #ifndef Tcl_DbNewBignumObj_TCL_DECLARED #define Tcl_DbNewBignumObj_TCL_DECLARED /* 556 */ EXTERN Tcl_Obj* Tcl_DbNewBignumObj _ANSI_ARGS_((mp_int* value, CONST char* file, int line)); #endif #ifndef Tcl_SetBignumObj_TCL_DECLARED #define Tcl_SetBignumObj_TCL_DECLARED /* 557 */ EXTERN void Tcl_SetBignumObj _ANSI_ARGS_((Tcl_Obj* obj, mp_int* value)); #endif #ifndef Tcl_GetBignumFromObj_TCL_DECLARED #define Tcl_GetBignumFromObj_TCL_DECLARED /* 558 */ EXTERN int Tcl_GetBignumFromObj _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); #endif #ifndef Tcl_GetBignumAndClearObj_TCL_DECLARED #define Tcl_GetBignumAndClearObj_TCL_DECLARED /* 559 */ EXTERN int Tcl_GetBignumAndClearObj _ANSI_ARGS_(( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); #endif #ifndef Tcl_TruncateChannel_TCL_DECLARED #define Tcl_TruncateChannel_TCL_DECLARED /* 560 */ EXTERN int Tcl_TruncateChannel _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt length)); #endif #ifndef Tcl_ChannelTruncateProc_TCL_DECLARED #define Tcl_ChannelTruncateProc_TCL_DECLARED /* 561 */ EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); #endif #ifndef Tcl_SetChannelErrorInterp_TCL_DECLARED #define Tcl_SetChannelErrorInterp_TCL_DECLARED /* 562 */ EXTERN void Tcl_SetChannelErrorInterp _ANSI_ARGS_(( Tcl_Interp* interp, Tcl_Obj* msg)); #endif #ifndef Tcl_GetChannelErrorInterp_TCL_DECLARED #define Tcl_GetChannelErrorInterp_TCL_DECLARED /* 563 */ EXTERN void Tcl_GetChannelErrorInterp _ANSI_ARGS_(( Tcl_Interp* interp, Tcl_Obj** msg)); #endif #ifndef Tcl_SetChannelError_TCL_DECLARED #define Tcl_SetChannelError_TCL_DECLARED /* 564 */ EXTERN void Tcl_SetChannelError _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj* msg)); #endif #ifndef Tcl_GetChannelError_TCL_DECLARED #define Tcl_GetChannelError_TCL_DECLARED /* 565 */ EXTERN void Tcl_GetChannelError _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj** msg)); #endif typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; struct TclIntStubs *tclIntStubs; struct TclIntPlatStubs *tclIntPlatStubs; } 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_((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__) /* UNIX */ |
︙ | ︙ | |||
3387 3388 3389 3390 3391 3392 3393 | #ifdef __WIN32__ void *reserved10; #endif /* __WIN32__ */ void (*tcl_SetTimer) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 11 */ void (*tcl_Sleep) _ANSI_ARGS_((int ms)); /* 12 */ int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 13 */ int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 14 */ | | | | | | 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 | #ifdef __WIN32__ void *reserved10; #endif /* __WIN32__ */ void (*tcl_SetTimer) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 11 */ void (*tcl_Sleep) _ANSI_ARGS_((int ms)); /* 12 */ int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 13 */ int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 14 */ void (*tcl_AppendStringsToObj) _ANSI_ARGS_((Tcl_Obj *objPtr, ...)); /* 15 */ void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 16 */ Tcl_Obj * (*tcl_ConcatObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 17 */ int (*tcl_ConvertToType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr)); /* 18 */ void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 19 */ void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 20 */ int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 21 */ Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, CONST char * file, int line)); /* 22 */ Tcl_Obj * (*tcl_DbNewByteArrayObj) _ANSI_ARGS_((CONST unsigned char * bytes, int length, CONST char * file, int line)); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) _ANSI_ARGS_((double doubleValue, CONST char * file, int line)); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST * objv, CONST char * file, int line)); /* 25 */ Tcl_Obj * (*tcl_DbNewLongObj) _ANSI_ARGS_((long longValue, CONST char * file, int line)); /* 26 */ Tcl_Obj * (*tcl_DbNewObj) _ANSI_ARGS_((CONST char * file, int line)); /* 27 */ Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((CONST char * bytes, int length, CONST char * file, int line)); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 29 */ void (*tclFreeObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 30 */ int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * src, int * boolPtr)); /* 31 */ int (*tcl_GetBooleanFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * boolPtr)); /* 32 */ unsigned char * (*tcl_GetByteArrayFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 33 */ int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * src, double * doublePtr)); /* 34 */ int (*tcl_GetDoubleFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr)); /* 35 */ int (*tcl_GetIndexFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST84 char ** tablePtr, CONST char * msg, int flags, int * indexPtr)); /* 36 */ int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * src, int * intPtr)); /* 37 */ int (*tcl_GetIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); /* 38 */ int (*tcl_GetLongFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * longPtr)); /* 39 */ Tcl_ObjType * (*tcl_GetObjType) _ANSI_ARGS_((CONST char * typeName)); /* 40 */ char * (*tcl_GetStringFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 41 */ void (*tcl_InvalidateStringRep) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 42 */ int (*tcl_ListObjAppendList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * elemListPtr)); /* 43 */ int (*tcl_ListObjAppendElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * objPtr)); /* 44 */ |
︙ | ︙ | |||
3441 3442 3443 3444 3445 3446 3447 | void (*tcl_SetListObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int objc, Tcl_Obj *CONST objv[])); /* 62 */ void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */ void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */ void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 65 */ void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */ void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */ void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */ | | | | 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 | void (*tcl_SetListObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int objc, Tcl_Obj *CONST objv[])); /* 62 */ void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */ void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */ void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 65 */ void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */ void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */ void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */ void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * element)); /* 69 */ void (*tcl_AppendResult) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 70 */ Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); /* 71 */ void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */ int (*tcl_AsyncInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int code)); /* 73 */ void (*tcl_AsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 74 */ 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 */ |
︙ | ︙ | |||
3494 3495 3496 3497 3498 3499 3500 | void (*tcl_DetachPids) _ANSI_ARGS_((int numPids, Tcl_Pid * pidPtr)); /* 111 */ #endif /* __WIN32__ */ void (*tcl_DeleteTimerHandler) _ANSI_ARGS_((Tcl_TimerToken token)); /* 112 */ void (*tcl_DeleteTrace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Trace trace)); /* 113 */ void (*tcl_DontCallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 114 */ int (*tcl_DoOneEvent) _ANSI_ARGS_((int flags)); /* 115 */ void (*tcl_DoWhenIdle) _ANSI_ARGS_((Tcl_IdleProc * proc, ClientData clientData)); /* 116 */ | | | | | | | | | 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 | void (*tcl_DetachPids) _ANSI_ARGS_((int numPids, Tcl_Pid * pidPtr)); /* 111 */ #endif /* __WIN32__ */ void (*tcl_DeleteTimerHandler) _ANSI_ARGS_((Tcl_TimerToken token)); /* 112 */ void (*tcl_DeleteTrace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Trace trace)); /* 113 */ void (*tcl_DontCallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 114 */ int (*tcl_DoOneEvent) _ANSI_ARGS_((int flags)); /* 115 */ void (*tcl_DoWhenIdle) _ANSI_ARGS_((Tcl_IdleProc * proc, ClientData clientData)); /* 116 */ char * (*tcl_DStringAppend) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * bytes, int length)); /* 117 */ char * (*tcl_DStringAppendElement) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * element)); /* 118 */ void (*tcl_DStringEndSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 119 */ 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 * script)); /* 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 * expr, 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 * expr, 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 * expr, 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 * expr)); /* 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 */ |
︙ | ︙ | |||
3545 3546 3547 3548 3549 3550 3551 | 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__) /* UNIX */ | | | 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 | 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__) /* UNIX */ int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * chanID, int forWriting, int checkUsage, ClientData * filePtr)); /* 167 */ #endif /* UNIX */ #ifdef __WIN32__ void *reserved167; #endif /* __WIN32__ */ 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 */ |
︙ | ︙ | |||
3590 3591 3592 3593 3594 3595 3596 | Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */ #endif /* __WIN32__ */ 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 */ | | | | | | | | 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 | Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */ #endif /* __WIN32__ */ 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 * assignment)); /* 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__) /* UNIX */ void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */ #endif /* UNIX */ #ifdef __WIN32__ void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */ #endif /* __WIN32__ */ int (*tcl_RecordAndEval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmd, int flags)); /* 208 */ int (*tcl_RecordAndEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * cmdPtr, int flags)); /* 209 */ void (*tcl_RegisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 210 */ void (*tcl_RegisterObjType) _ANSI_ARGS_((Tcl_ObjType * typePtr)); /* 211 */ Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 212 */ int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * text, CONST char * start)); /* 213 */ int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * text, CONST char * pattern)); /* 214 */ void (*tcl_RegExpRange) _ANSI_ARGS_((Tcl_RegExp regexp, int index, CONST84 char ** startPtr, CONST84 char ** endPtr)); /* 215 */ void (*tcl_Release) _ANSI_ARGS_((ClientData clientData)); /* 216 */ void (*tcl_ResetResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 217 */ int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * str, int * flagPtr)); /* 218 */ int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * str, int length, int * flagPtr)); /* 219 */ int (*tcl_SeekOld) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */ int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */ int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */ void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */ void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */ int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, CONST char * newValue)); /* 225 */ int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */ void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */ void (*tcl_SetErrorCode) _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* 228 */ void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */ 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 * result, 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 */ |
︙ | ︙ | |||
3652 3653 3654 3655 3656 3657 3658 | 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 */ | | | | 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 | 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_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 * start, 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 */ |
︙ | ︙ | |||
3704 3705 3706 3707 3708 3709 3710 | 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 */ | | | | 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 | 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 length)); /* 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 length)); /* 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 */ |
︙ | ︙ | |||
3744 3745 3746 3747 3748 3749 3750 | 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 */ | | | | | | | | | | | | | 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 | 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 * uniStr)); /* 352 */ int (*tcl_UniCharNcmp) _ANSI_ARGS_((CONST Tcl_UniChar * ucs, CONST Tcl_UniChar * uct, unsigned long numChars)); /* 353 */ char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * uniStr, int uniLength, Tcl_DString * dsPtr)); /* 354 */ Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * src, 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 * start, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 360 */ int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */ int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr)); /* 362 */ int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 363 */ int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * start, 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 */ int (*tcl_UniCharIsControl) _ANSI_ARGS_((int ch)); /* 372 */ int (*tcl_UniCharIsGraph) _ANSI_ARGS_((int ch)); /* 373 */ int (*tcl_UniCharIsPrint) _ANSI_ARGS_((int ch)); /* 374 */ int (*tcl_UniCharIsPunct) _ANSI_ARGS_((int ch)); /* 375 */ int (*tcl_RegExpExecObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, Tcl_Obj * textObj, int offset, int nmatches, int flags)); /* 376 */ void (*tcl_RegExpGetInfo) _ANSI_ARGS_((Tcl_RegExp regexp, Tcl_RegExpInfo * infoPtr)); /* 377 */ Tcl_Obj * (*tcl_NewUnicodeObj) _ANSI_ARGS_((CONST Tcl_UniChar * unicode, int numChars)); /* 378 */ void (*tcl_SetUnicodeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int numChars)); /* 379 */ int (*tcl_GetCharLength) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 380 */ Tcl_UniChar (*tcl_GetUniChar) _ANSI_ARGS_((Tcl_Obj * objPtr, int index)); /* 381 */ Tcl_UniChar * (*tcl_GetUnicode) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 382 */ Tcl_Obj * (*tcl_GetRange) _ANSI_ARGS_((Tcl_Obj * objPtr, int first, int last)); /* 383 */ void (*tcl_AppendUnicodeToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int length)); /* 384 */ int (*tcl_RegExpMatchObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * textObj, Tcl_Obj * patternObj)); /* 385 */ void (*tcl_SetNotifier) _ANSI_ARGS_((Tcl_NotifierProcs * notifierProcPtr)); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) _ANSI_ARGS_((void)); /* 387 */ int (*tcl_GetChannelNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 388 */ int (*tcl_GetChannelNamesEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 389 */ int (*tcl_ProcObjCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 390 */ void (*tcl_ConditionFinalize) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 391 */ void (*tcl_MutexFinalize) _ANSI_ARGS_((Tcl_Mutex * mutex)); /* 392 */ |
︙ | ︙ | |||
3811 3812 3813 3814 3815 3816 3817 | int (*tcl_JoinThread) _ANSI_ARGS_((Tcl_ThreadId threadId, int* result)); /* 412 */ int (*tcl_IsChannelShared) _ANSI_ARGS_((Tcl_Channel channel)); /* 413 */ int (*tcl_IsChannelRegistered) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 414 */ void (*tcl_CutChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 415 */ void (*tcl_SpliceChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 416 */ void (*tcl_ClearChannelHandlers) _ANSI_ARGS_((Tcl_Channel channel)); /* 417 */ int (*tcl_IsChannelExisting) _ANSI_ARGS_((CONST char* channelName)); /* 418 */ | | | | 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 | int (*tcl_JoinThread) _ANSI_ARGS_((Tcl_ThreadId threadId, int* result)); /* 412 */ int (*tcl_IsChannelShared) _ANSI_ARGS_((Tcl_Channel channel)); /* 413 */ int (*tcl_IsChannelRegistered) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 414 */ void (*tcl_CutChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 415 */ void (*tcl_SpliceChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 416 */ void (*tcl_ClearChannelHandlers) _ANSI_ARGS_((Tcl_Channel channel)); /* 417 */ int (*tcl_IsChannelExisting) _ANSI_ARGS_((CONST char* channelName)); /* 418 */ int (*tcl_UniCharNcasecmp) _ANSI_ARGS_((CONST Tcl_UniChar * ucs, CONST Tcl_UniChar * uct, unsigned long numChars)); /* 419 */ int (*tcl_UniCharCaseMatch) _ANSI_ARGS_((CONST Tcl_UniChar * uniStr, CONST Tcl_UniChar * uniPattern, int nocase)); /* 420 */ Tcl_HashEntry * (*tcl_FindHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key)); /* 421 */ Tcl_HashEntry * (*tcl_CreateHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key, int * newPtr)); /* 422 */ void (*tcl_InitCustomHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType, Tcl_HashKeyType * typePtr)); /* 423 */ void (*tcl_InitObjHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 424 */ ClientData (*tcl_CommandTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * procPtr, ClientData prevClientData)); /* 425 */ int (*tcl_TraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 426 */ void (*tcl_UntraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 427 */ |
︙ | ︙ | |||
3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 | void (*tcl_LimitGetTime) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Time * timeLimitPtr)); /* 533 */ int (*tcl_LimitGetGranularity) _ANSI_ARGS_((Tcl_Interp * interp, int type)); /* 534 */ Tcl_InterpState (*tcl_SaveInterpState) _ANSI_ARGS_((Tcl_Interp * interp, int status)); /* 535 */ int (*tcl_RestoreInterpState) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpState state)); /* 536 */ void (*tcl_DiscardInterpState) _ANSI_ARGS_((Tcl_InterpState state)); /* 537 */ int (*tcl_SetReturnOptions) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * options)); /* 538 */ Tcl_Obj * (*tcl_GetReturnOptions) _ANSI_ARGS_((Tcl_Interp * interp, int result)); /* 539 */ } TclStubs; #ifdef __cplusplus extern "C" { #endif extern TclStubs *tclStubsPtr; #ifdef __cplusplus | > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | void (*tcl_LimitGetTime) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Time * timeLimitPtr)); /* 533 */ int (*tcl_LimitGetGranularity) _ANSI_ARGS_((Tcl_Interp * interp, int type)); /* 534 */ Tcl_InterpState (*tcl_SaveInterpState) _ANSI_ARGS_((Tcl_Interp * interp, int status)); /* 535 */ int (*tcl_RestoreInterpState) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpState state)); /* 536 */ void (*tcl_DiscardInterpState) _ANSI_ARGS_((Tcl_InterpState state)); /* 537 */ int (*tcl_SetReturnOptions) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * options)); /* 538 */ Tcl_Obj * (*tcl_GetReturnOptions) _ANSI_ARGS_((Tcl_Interp * interp, int result)); /* 539 */ int (*tcl_IsEnsemble) _ANSI_ARGS_((Tcl_Command token)); /* 540 */ Tcl_Command (*tcl_CreateEnsemble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * namespacePtr, int flags)); /* 541 */ Tcl_Command (*tcl_FindEnsemble) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * cmdNameObj, int flags)); /* 542 */ int (*tcl_SetEnsembleSubcommandList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * subcmdList)); /* 543 */ int (*tcl_SetEnsembleMappingDict) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * mapDict)); /* 544 */ int (*tcl_SetEnsembleUnknownHandler) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * unknownList)); /* 545 */ int (*tcl_SetEnsembleFlags) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, int flags)); /* 546 */ int (*tcl_GetEnsembleSubcommandList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** subcmdListPtr)); /* 547 */ int (*tcl_GetEnsembleMappingDict) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** mapDictPtr)); /* 548 */ int (*tcl_GetEnsembleUnknownHandler) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** unknownListPtr)); /* 549 */ int (*tcl_GetEnsembleFlags) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, int * flagsPtr)); /* 550 */ int (*tcl_GetEnsembleNamespace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command token, Tcl_Namespace ** namespacePtrPtr)); /* 551 */ void (*tcl_SetTimeProc) _ANSI_ARGS_((Tcl_GetTimeProc* getProc, Tcl_ScaleTimeProc* scaleProc, ClientData clientData)); /* 552 */ void (*tcl_QueryTimeProc) _ANSI_ARGS_((Tcl_GetTimeProc** getProc, Tcl_ScaleTimeProc** scaleProc, ClientData* clientData)); /* 553 */ Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 554 */ Tcl_Obj* (*tcl_NewBignumObj) _ANSI_ARGS_((mp_int* value)); /* 555 */ Tcl_Obj* (*tcl_DbNewBignumObj) _ANSI_ARGS_((mp_int* value, CONST char* file, int line)); /* 556 */ void (*tcl_SetBignumObj) _ANSI_ARGS_((Tcl_Obj* obj, mp_int* value)); /* 557 */ int (*tcl_GetBignumFromObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 558 */ int (*tcl_GetBignumAndClearObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 559 */ int (*tcl_TruncateChannel) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt length)); /* 560 */ Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 561 */ void (*tcl_SetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* msg)); /* 562 */ void (*tcl_GetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj** msg)); /* 563 */ void (*tcl_SetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj* msg)); /* 564 */ void (*tcl_GetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj** msg)); /* 565 */ } TclStubs; #ifdef __cplusplus extern "C" { #endif extern TclStubs *tclStubsPtr; #ifdef __cplusplus |
︙ | ︙ | |||
6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 | #define Tcl_SetReturnOptions \ (tclStubsPtr->tcl_SetReturnOptions) /* 538 */ #endif #ifndef Tcl_GetReturnOptions #define Tcl_GetReturnOptions \ (tclStubsPtr->tcl_GetReturnOptions) /* 539 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLDECLS */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 | #define Tcl_SetReturnOptions \ (tclStubsPtr->tcl_SetReturnOptions) /* 538 */ #endif #ifndef Tcl_GetReturnOptions #define Tcl_GetReturnOptions \ (tclStubsPtr->tcl_GetReturnOptions) /* 539 */ #endif #ifndef Tcl_IsEnsemble #define Tcl_IsEnsemble \ (tclStubsPtr->tcl_IsEnsemble) /* 540 */ #endif #ifndef Tcl_CreateEnsemble #define Tcl_CreateEnsemble \ (tclStubsPtr->tcl_CreateEnsemble) /* 541 */ #endif #ifndef Tcl_FindEnsemble #define Tcl_FindEnsemble \ (tclStubsPtr->tcl_FindEnsemble) /* 542 */ #endif #ifndef Tcl_SetEnsembleSubcommandList #define Tcl_SetEnsembleSubcommandList \ (tclStubsPtr->tcl_SetEnsembleSubcommandList) /* 543 */ #endif #ifndef Tcl_SetEnsembleMappingDict #define Tcl_SetEnsembleMappingDict \ (tclStubsPtr->tcl_SetEnsembleMappingDict) /* 544 */ #endif #ifndef Tcl_SetEnsembleUnknownHandler #define Tcl_SetEnsembleUnknownHandler \ (tclStubsPtr->tcl_SetEnsembleUnknownHandler) /* 545 */ #endif #ifndef Tcl_SetEnsembleFlags #define Tcl_SetEnsembleFlags \ (tclStubsPtr->tcl_SetEnsembleFlags) /* 546 */ #endif #ifndef Tcl_GetEnsembleSubcommandList #define Tcl_GetEnsembleSubcommandList \ (tclStubsPtr->tcl_GetEnsembleSubcommandList) /* 547 */ #endif #ifndef Tcl_GetEnsembleMappingDict #define Tcl_GetEnsembleMappingDict \ (tclStubsPtr->tcl_GetEnsembleMappingDict) /* 548 */ #endif #ifndef Tcl_GetEnsembleUnknownHandler #define Tcl_GetEnsembleUnknownHandler \ (tclStubsPtr->tcl_GetEnsembleUnknownHandler) /* 549 */ #endif #ifndef Tcl_GetEnsembleFlags #define Tcl_GetEnsembleFlags \ (tclStubsPtr->tcl_GetEnsembleFlags) /* 550 */ #endif #ifndef Tcl_GetEnsembleNamespace #define Tcl_GetEnsembleNamespace \ (tclStubsPtr->tcl_GetEnsembleNamespace) /* 551 */ #endif #ifndef Tcl_SetTimeProc #define Tcl_SetTimeProc \ (tclStubsPtr->tcl_SetTimeProc) /* 552 */ #endif #ifndef Tcl_QueryTimeProc #define Tcl_QueryTimeProc \ (tclStubsPtr->tcl_QueryTimeProc) /* 553 */ #endif #ifndef Tcl_ChannelThreadActionProc #define Tcl_ChannelThreadActionProc \ (tclStubsPtr->tcl_ChannelThreadActionProc) /* 554 */ #endif #ifndef Tcl_NewBignumObj #define Tcl_NewBignumObj \ (tclStubsPtr->tcl_NewBignumObj) /* 555 */ #endif #ifndef Tcl_DbNewBignumObj #define Tcl_DbNewBignumObj \ (tclStubsPtr->tcl_DbNewBignumObj) /* 556 */ #endif #ifndef Tcl_SetBignumObj #define Tcl_SetBignumObj \ (tclStubsPtr->tcl_SetBignumObj) /* 557 */ #endif #ifndef Tcl_GetBignumFromObj #define Tcl_GetBignumFromObj \ (tclStubsPtr->tcl_GetBignumFromObj) /* 558 */ #endif #ifndef Tcl_GetBignumAndClearObj #define Tcl_GetBignumAndClearObj \ (tclStubsPtr->tcl_GetBignumAndClearObj) /* 559 */ #endif #ifndef Tcl_TruncateChannel #define Tcl_TruncateChannel \ (tclStubsPtr->tcl_TruncateChannel) /* 560 */ #endif #ifndef Tcl_ChannelTruncateProc #define Tcl_ChannelTruncateProc \ (tclStubsPtr->tcl_ChannelTruncateProc) /* 561 */ #endif #ifndef Tcl_SetChannelErrorInterp #define Tcl_SetChannelErrorInterp \ (tclStubsPtr->tcl_SetChannelErrorInterp) /* 562 */ #endif #ifndef Tcl_GetChannelErrorInterp #define Tcl_GetChannelErrorInterp \ (tclStubsPtr->tcl_GetChannelErrorInterp) /* 563 */ #endif #ifndef Tcl_SetChannelError #define Tcl_SetChannelError \ (tclStubsPtr->tcl_SetChannelError) /* 564 */ #endif #ifndef Tcl_GetChannelError #define Tcl_GetChannelError \ (tclStubsPtr->tcl_GetChannelError) /* 565 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLDECLS */ |
Changes to generic/tclDictObj.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclDictObj.c -- * * This file contains procedures that implement the Tcl dict object * type and its accessor command. * * Copyright (c) 2002 by Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | /* * tclDictObj.c -- * * This file contains procedures that implement the Tcl dict object * type and its accessor command. * * Copyright (c) 2002 by Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclDictObj.c,v 1.27.2.5 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" #include "tommath.h" /* * Forward declaration. */ struct Dict; /* * Prototypes for procedures defined later in this file: */ static void DeleteDict _ANSI_ARGS_((struct Dict *dict)); static int DictAppendCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST *objv)); |
︙ | ︙ | |||
91 92 93 94 95 96 97 | int objc, Tcl_Obj *CONST *objv)); static void DupDictInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); static void FreeDictInternalRep _ANSI_ARGS_((Tcl_Obj *dictPtr)); static void InvalidateDictChain _ANSI_ARGS_((Tcl_Obj *dictObj)); static int SetDictFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); | < < < | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | int objc, Tcl_Obj *CONST *objv)); static void DupDictInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); static void FreeDictInternalRep _ANSI_ARGS_((Tcl_Obj *dictPtr)); static void InvalidateDictChain _ANSI_ARGS_((Tcl_Obj *dictObj)); static int SetDictFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfDict _ANSI_ARGS_((Tcl_Obj *dictPtr)); /* * Internal representation of a dictionary. * * The internal representation of a dictionary object is a hash table * (with Tcl_Objs for both keys and values), a reference count and |
︙ | ︙ | |||
584 585 586 587 588 589 590 | ckfree((char *) dict); return result; } /* *---------------------------------------------------------------------- * | | | 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 | ckfree((char *) dict); return result; } /* *---------------------------------------------------------------------- * * TclTraceDictPath -- * * Trace through a tree of dictionaries using the array of keys * given. If the flags argument has the DICT_PATH_UPDATE flag is * set, a backward-pointing chain of dictionaries is also built * (in the Dict's chain field) and the chained dictionaries are * made into unshared dictionaries (if they aren't already.) * |
︙ | ︙ | |||
615 616 617 618 619 620 621 | * DICT_PATH_CREATE bits set (and not the DICT_PATH_EXISTS bit), * non-existant keys will be inserted with a value of an empty * dictionary, resulting in the path being built. * *---------------------------------------------------------------------- */ | | | | 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 | * DICT_PATH_CREATE bits set (and not the DICT_PATH_EXISTS bit), * non-existant keys will be inserted with a value of an empty * dictionary, resulting in the path being built. * *---------------------------------------------------------------------- */ Tcl_Obj * TclTraceDictPath(interp, dictPtr, keyc, keyv, flags) Tcl_Interp *interp; Tcl_Obj *dictPtr, *CONST keyv[]; int keyc, flags; { Dict *dict, *newDict; int i; |
︙ | ︙ | |||
693 694 695 696 697 698 699 | /* *---------------------------------------------------------------------- * * InvalidateDictChain -- * * Go through a dictionary chain (built by an updating invokation | | | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 | /* *---------------------------------------------------------------------- * * InvalidateDictChain -- * * Go through a dictionary chain (built by an updating invokation * of TclTraceDictPath) and invalidate the string representations * of all the dictionaries on the chain. * * Results: * None * * Side effects: * String reps are invalidated and epoch counters (for detecting * illegal concurrent modifications) are updated through the |
︙ | ︙ | |||
1131 1132 1133 1134 1135 1136 1137 | if (Tcl_IsShared(dictPtr)) { Tcl_Panic("Tcl_DictObjPutKeyList called with shared object"); } if (keyc < 1) { Tcl_Panic("Tcl_DictObjPutKeyList called with empty key list"); } | | | 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 | if (Tcl_IsShared(dictPtr)) { Tcl_Panic("Tcl_DictObjPutKeyList called with shared object"); } if (keyc < 1) { Tcl_Panic("Tcl_DictObjPutKeyList called with empty key list"); } dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE); if (dictPtr == NULL) { return TCL_ERROR; } dict = (Dict *) dictPtr->internalRep.otherValuePtr; hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); |
︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 | if (Tcl_IsShared(dictPtr)) { Tcl_Panic("Tcl_DictObjRemoveKeyList called with shared object"); } if (keyc < 1) { Tcl_Panic("Tcl_DictObjRemoveKeyList called with empty key list"); } | | | 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 | if (Tcl_IsShared(dictPtr)) { Tcl_Panic("Tcl_DictObjRemoveKeyList called with shared object"); } if (keyc < 1) { Tcl_Panic("Tcl_DictObjRemoveKeyList called with empty key list"); } dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE); if (dictPtr == NULL) { return TCL_ERROR; } dict = (Dict *) dictPtr->internalRep.otherValuePtr; hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyv[keyc-1]); if (hPtr != NULL) { |
︙ | ︙ | |||
1422 1423 1424 1425 1426 1427 1428 | * current index in the current dictionary each time. Once we've * done the lookup, we set the current dictionary to be the value * we looked up (in case the value was not the last one and we are * going through a chain of searches.) Note that this loop always * executes at least once. */ | | | 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 | * current index in the current dictionary each time. Once we've * done the lookup, we set the current dictionary to be the value * we looked up (in case the value was not the last one and we are * going through a chain of searches.) Note that this loop always * executes at least once. */ dictPtr = TclTraceDictPath(interp, objv[2], objc-4,objv+3, DICT_PATH_READ); if (dictPtr == NULL) { return TCL_ERROR; } result = Tcl_DictObjGet(interp, dictPtr, objv[objc-1], &valuePtr); if (result != TCL_OK) { return result; } |
︙ | ︙ | |||
1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 | if (result != TCL_OK) { return TCL_ERROR; } if (objc == 4) { pattern = TclGetString(objv[3]); } listPtr = Tcl_NewListObj(0, NULL); for (; !done ; Tcl_DictObjNext(&search, &keyPtr, NULL, &done)) { if (pattern==NULL || Tcl_StringMatch(TclGetString(keyPtr), pattern)) { /* * Assume this operation always succeeds. */ Tcl_ListObjAppendElement(interp, listPtr, keyPtr); } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * | > > > > > > > > > | 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 | if (result != TCL_OK) { return TCL_ERROR; } if (objc == 4) { pattern = TclGetString(objv[3]); } listPtr = Tcl_NewListObj(0, NULL); if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { Tcl_Obj *valuePtr = NULL; Tcl_DictObjGet(interp, objv[2], objv[3], &valuePtr); if (valuePtr != NULL) { Tcl_ListObjAppendElement(interp, listPtr, objv[3]); } goto searchDone; } for (; !done ; Tcl_DictObjNext(&search, &keyPtr, NULL, &done)) { if (pattern==NULL || Tcl_StringMatch(TclGetString(keyPtr), pattern)) { /* * Assume this operation always succeeds. */ Tcl_ListObjAppendElement(interp, listPtr, keyPtr); } } searchDone: Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1802 1803 1804 1805 1806 1807 1808 | int result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "dictionary key ?key ...?"); return TCL_ERROR; } | | > | 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 | int result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "dictionary key ?key ...?"); return TCL_ERROR; } dictPtr = TclTraceDictPath(interp, objv[2], objc-4, objv+3, DICT_PATH_EXISTS); if (dictPtr == NULL) { return TCL_ERROR; } if (dictPtr == DICT_PATH_NON_EXISTENT) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); return TCL_OK; } |
︙ | ︙ | |||
1889 1890 1891 1892 1893 1894 1895 | static int DictIncrCmd(interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST *objv; { | > | > > > > > | 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 | static int DictIncrCmd(interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST *objv; { #if 0 Tcl_Obj *dictPtr, *resultPtr; int result, isWide = 0; long incrValue = 1; Tcl_WideInt wideIncrValue = 0; int allocatedDict = 0; #else int code = TCL_OK; Tcl_Obj *dictPtr, *valuePtr = NULL; #endif if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "varName key ?increment?"); return TCL_ERROR; } #if 0 if (objc == 5) { if (objv[4]->typePtr == &tclIntType) { incrValue = objv[4]->internalRep.longValue; } else if (objv[4]->typePtr == &tclWideIntType) { wideIncrValue = objv[4]->internalRep.wideValue; isWide = 1; } else { |
︙ | ︙ | |||
2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 | TCL_LEAVE_ERR_MSG); TclDecrRefCount(dictPtr); if (resultPtr == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * DictLappendCmd -- * | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | TCL_LEAVE_ERR_MSG); TclDecrRefCount(dictPtr); if (resultPtr == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; #else dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); if (dictPtr == NULL) { /* Variable didn't yet exist. Create new dictionary value */ dictPtr = Tcl_NewDictObj(); } else if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) { /* Variable contents are not a dict, report error */ return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { /* A little internals surgery to avoid copying a string rep * that will soon be no good */ char *saved = dictPtr->bytes; dictPtr->bytes = NULL; dictPtr = Tcl_DuplicateObj(dictPtr); dictPtr->bytes = saved; } if (valuePtr == NULL) { /* Key not in dictionary. Create new key with increment as value */ if (objc == 5) { /* Verify increment is an integer */ mp_int increment; code = Tcl_GetBignumFromObj(interp, objv[4], &increment); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (reading increment)"); } else { Tcl_DictObjPut(interp, dictPtr, objv[3], objv[4]); } } else { Tcl_DictObjPut(interp, dictPtr, objv[3], Tcl_NewIntObj(1)); } } else { /* Key in dictionary. Increment its value with minimum dup. */ if (Tcl_IsShared(valuePtr)) { valuePtr = Tcl_DuplicateObj(valuePtr); Tcl_DictObjPut(interp, dictPtr, objv[3], valuePtr); } if (objc == 5) { code = TclIncrObj(interp, valuePtr, objv[4]); } else { Tcl_Obj *incrPtr = Tcl_NewIntObj(1); Tcl_IncrRefCount(incrPtr); code = TclIncrObj(interp, valuePtr, incrPtr); Tcl_DecrRefCount(incrPtr); } } Tcl_IncrRefCount(dictPtr); if (code == TCL_OK) { Tcl_InvalidateStringRep(dictPtr); valuePtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { code = TCL_ERROR; } } Tcl_DecrRefCount(dictPtr); if (code == TCL_OK) { Tcl_SetObjResult(interp, valuePtr); } return code; #endif } /* *---------------------------------------------------------------------- * * DictLappendCmd -- * |
︙ | ︙ | |||
2243 2244 2245 2246 2247 2248 2249 | static int DictForCmd(interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST *objv; { | | < | | < < < < < > < | | 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 | static int DictForCmd(interp, objc, objv) Tcl_Interp *interp; int objc; Tcl_Obj *CONST *objv; { Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj; Tcl_DictSearch search; int varc, done, result; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "{keyVar valueVar} dictionary script"); return TCL_ERROR; } if (Tcl_ListObjGetElements(interp, objv[2], &varc, &varv) != TCL_OK) { return TCL_ERROR; } if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); return TCL_ERROR; } keyVarObj = varv[0]; valueVarObj = varv[1]; scriptObj = objv[4]; /* * Make sure that these objects (which we need throughout the body of the * loop) don't vanish. Note that the dictionary internal rep is locked * internally so that updates, shimmering, etc are not a problem. */ Tcl_IncrRefCount(keyVarObj); Tcl_IncrRefCount(valueVarObj); Tcl_IncrRefCount(scriptObj); result = Tcl_DictObjFirst(interp, objv[3], &search, &keyObj, &valueObj, &done); if (result != TCL_OK) { goto doneFor; } while (!done) { /* |
︙ | ︙ | |||
2316 2317 2318 2319 2320 2321 2322 | result = Tcl_EvalObjEx(interp, scriptObj, 0); if (result == TCL_CONTINUE) { result = TCL_OK; } else if (result != TCL_OK) { if (result == TCL_BREAK) { result = TCL_OK; } else if (result == TCL_ERROR) { | < | | < < < | 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 | result = Tcl_EvalObjEx(interp, scriptObj, 0); if (result == TCL_CONTINUE) { result = TCL_OK; } else if (result != TCL_OK) { if (result == TCL_BREAK) { result = TCL_OK; } else if (result == TCL_ERROR) { TclFormatToErrorInfo(interp, "\n (\"dict for\" body line %d)", interp->errorLine); } break; } Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); } doneFor: /* * Stop holding a reference to these objects. */ TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); Tcl_DictObjDone(&search); if (result == TCL_OK) { Tcl_ResetResult(interp); } return result; |
︙ | ︙ | |||
2495 2496 2497 2498 2499 2500 2501 | { static CONST char *filters[] = { "key", "script", "value", NULL }; enum FilterTypes { FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES }; | | < | 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 | { static CONST char *filters[] = { "key", "script", "value", NULL }; enum FilterTypes { FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES }; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj, *resultObj, *boolObj; Tcl_DictSearch search; int index, varc, done, result, satisfied; char *pattern; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "dictionary filterType ..."); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[3], filters, "filterType", 0, &index) != TCL_OK) { |
︙ | ︙ | |||
2527 2528 2529 2530 2531 2532 2533 | */ if (Tcl_DictObjFirst(interp, objv[2], &search, &keyObj, &valueObj, &done) != TCL_OK) { return TCL_ERROR; } pattern = TclGetString(objv[4]); resultObj = Tcl_NewDictObj(); | > > > > > > | | | | | > | 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 | */ if (Tcl_DictObjFirst(interp, objv[2], &search, &keyObj, &valueObj, &done) != TCL_OK) { return TCL_ERROR; } pattern = TclGetString(objv[4]); resultObj = Tcl_NewDictObj(); if (TclMatchIsTrivial(pattern)) { Tcl_DictObjGet(interp, objv[2], objv[4], &valueObj); if (valueObj != NULL) { Tcl_DictObjPut(interp, resultObj, objv[4], valueObj); } } else { while (!done) { if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); } Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; case FILTER_VALUES: if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "dictionary value globPattern"); |
︙ | ︙ | |||
2584 2585 2586 2587 2588 2589 2590 | if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); return TCL_ERROR; } keyVarObj = varv[0]; valueVarObj = varv[1]; | < | | > | < < < < < | < | 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 | if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); return TCL_ERROR; } keyVarObj = varv[0]; valueVarObj = varv[1]; scriptObj = objv[5]; /* * Make sure that these objects (which we need throughout the body of * the loop) don't vanish. Note that the dictionary internal rep is * locked internally so that updates, shimmering, etc are not a * problem. */ Tcl_IncrRefCount(keyVarObj); Tcl_IncrRefCount(valueVarObj); Tcl_IncrRefCount(scriptObj); result = Tcl_DictObjFirst(interp, objv[2], &search, &keyObj, &valueObj, &done); if (result != TCL_OK) { TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); return TCL_ERROR; } resultObj = Tcl_NewDictObj(); while (!done) { |
︙ | ︙ | |||
2651 2652 2653 2654 2655 2656 2657 | result = TCL_ERROR; goto abnormalResult; } TclDecrRefCount(boolObj); if (satisfied) { Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); } | < < | | > > > | < < > > > > > > > > > < < < < < < < < < < < | 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 | result = TCL_ERROR; goto abnormalResult; } TclDecrRefCount(boolObj); if (satisfied) { Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); } break; case TCL_BREAK: /* * Force loop termination by calling Tcl_DictObjDone; this * makes the next Tcl_DictObjNext say there is nothing more to * do. */ Tcl_ResetResult(interp); Tcl_DictObjDone(&search); case TCL_CONTINUE: result = TCL_OK; break; case TCL_ERROR: TclFormatToErrorInfo(interp, "\n (\"dict filter\" script line %d)", interp->errorLine); default: goto abnormalResult; } TclDecrRefCount(keyObj); TclDecrRefCount(valueObj); Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); } /* * Stop holding a reference to these objects. */ TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); Tcl_DictObjDone(&search); if (result == TCL_OK) { Tcl_SetObjResult(interp, resultObj); } else { TclDecrRefCount(resultObj); } return result; abnormalResult: Tcl_DictObjDone(&search); TclDecrRefCount(keyObj); TclDecrRefCount(valueObj); TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); TclDecrRefCount(resultObj); return result; } Tcl_Panic("unexpected fallthrough"); /* Control never reaches this point. */ return TCL_ERROR; } /* *---------------------------------------------------------------------- * * DictUpdateCmd -- * |
︙ | ︙ | |||
2875 2876 2877 2878 2879 2880 2881 | */ dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG); if (dictPtr == NULL) { return TCL_ERROR; } if (objc > 4) { | | < < < | 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 | */ dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG); if (dictPtr == NULL) { return TCL_ERROR; } if (objc > 4) { dictPtr = TclTraceDictPath(interp, dictPtr, objc-4, objv+3, DICT_PATH_READ); if (dictPtr == NULL) { return TCL_ERROR; } } /* * Go over the list of keys and write each corresponding value to * a variable in the current context with the same name. Also * keep a copy of the keys so we can write back properly later on * even if the dictionary has been structurally modified. */ if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr, &done) != TCL_OK) { return TCL_ERROR; } TclNewObj(keysPtr); Tcl_IncrRefCount(keysPtr); for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) { Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr); if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr, TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(keysPtr); Tcl_DictObjDone(&s); return TCL_ERROR; } } /* * Execute the body. */ result = Tcl_EvalObjEx(interp, objv[objc-1], 0); if (result == TCL_ERROR) { |
︙ | ︙ | |||
2956 2957 2958 2959 2960 2961 2962 | * do prepare-for-update de-sharing along the path *but* avoid * generating an error on a non-existant path (we'll treat * that the same as a non-existant variable. Luckily, the * de-sharing operation isn't deeply damaging if we don't go * on to update; it's just less than perfectly efficient (but * no memory should be leaked). */ | | | 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 | * do prepare-for-update de-sharing along the path *but* avoid * generating an error on a non-existant path (we'll treat * that the same as a non-existant variable. Luckily, the * de-sharing operation isn't deeply damaging if we don't go * on to update; it's just less than perfectly efficient (but * no memory should be leaked). */ leafPtr = TclTraceDictPath(interp, dictPtr, objc-4, objv+3, DICT_PATH_EXISTS | DICT_PATH_UPDATE); if (leafPtr == NULL) { TclDecrRefCount(keysPtr); if (allocdict) { TclDecrRefCount(dictPtr); } Tcl_DiscardInterpState(state); |
︙ | ︙ |
Changes to generic/tclEncoding.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclEncoding.c -- * * Contains the implementation of the encoding conversion package. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | /* * tclEncoding.c -- * * Contains the implementation of the encoding conversion package. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclEncoding.c,v 1.29.2.6 2005/09/09 18:48:40 dgp Exp $ */ #include "tclInt.h" typedef size_t (LengthProc)_ANSI_ARGS_((CONST char *src)); /* * The following data structure represents an encoding, which describes how to * convert between various character sets and UTF-8. */ typedef struct Encoding { char *name; /* Name of encoding. Malloced because (1) * hash table entry that owns this encoding * may be freed prior to this encoding being * freed, (2) string passed in the * Tcl_EncodingType structure may not be * persistent. */ Tcl_EncodingConvertProc *toUtfProc; /* Procedure to convert from external encoding * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; /* Procedure to convert from UTF-8 into * external encoding. */ Tcl_EncodingFreeProc *freeProc; /* If non-NULL, procedure to call when this * encoding is deleted. */ int nullSize; /* Number of 0x00 bytes that signify |
︙ | ︙ | |||
57 58 59 60 61 62 63 | * The following structure is the clientData for a dynamically-loaded, * table-driven encoding created by LoadTableEncoding(). It maps between * Unicode and a single-byte, double-byte, or multibyte (1 or 2 bytes only) * encoding. */ typedef struct TableEncodingData { | | | | | > | | | | | | | | | | | | | | | | | | | | | < | | | > | | | < | | > | | | | | < > | | > | | | | | | | 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 | * The following structure is the clientData for a dynamically-loaded, * table-driven encoding created by LoadTableEncoding(). It maps between * Unicode and a single-byte, double-byte, or multibyte (1 or 2 bytes only) * encoding. */ typedef struct TableEncodingData { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ char prefixBytes[256]; /* If a byte in the input stream is a lead * byte for a 2-byte sequence, the * corresponding entry in this array is 1, * otherwise it is 0. */ unsigned short **toUnicode; /* Two dimensional sparse matrix to map * characters from the encoding to Unicode. * Each element of the toUnicode array points * to an array of 256 shorts. If there is no * corresponding character in Unicode, the * value in the matrix is 0x0000. * malloc'd. */ unsigned short **fromUnicode; /* Two dimensional sparse matrix to map * characters from Unicode to the encoding. * Each element of the fromUnicode array * points to an array of 256 shorts. If there * is no corresponding character the encoding, * the value in the matrix is 0x0000. * malloc'd. */ } TableEncodingData; /* * The following structures is the clientData for a dynamically-loaded, * escape-driven encoding that is itself comprised of other simpler encodings. * An example is "iso-2022-jp", which uses escape sequences to switch between * ascii, jis0208, jis0212, gb2312, and ksc5601. Note that "escape-driven" * does not necessarily mean that the ESCAPE character is the character used * for switching character sets. */ typedef struct EscapeSubTable { unsigned int sequenceLen; /* Length of following string. */ char sequence[16]; /* Escape code that marks this encoding. */ char name[32]; /* Name for encoding. */ Encoding *encodingPtr; /* Encoding loaded using above name, or NULL * if this sub-encoding has not been needed * yet. */ } EscapeSubTable; typedef struct EscapeEncodingData { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ unsigned int initLen; /* Length of following string. */ char init[16]; /* String to emit or expect before first char * in conversion. */ unsigned int finalLen; /* Length of following string. */ char final[16]; /* String to emit or expect after last char in * conversion. */ char prefixBytes[256]; /* If a byte in the input stream is the first * character of one of the escape sequences in * the following array, the corresponding * entry in this array is 1, otherwise it is * 0. */ int numSubTables; /* Length of following array. */ EscapeSubTable subTables[1];/* Information about each EscapeSubTable used * by this encoding type. The actual size * will be as large as necessary to hold all * EscapeSubTables. */ } EscapeEncodingData; /* * Constants used when loading an encoding file to identify the type of the * file. */ #define ENCODING_SINGLEBYTE 0 #define ENCODING_DOUBLEBYTE 1 #define ENCODING_MULTIBYTE 2 #define ENCODING_ESCAPE 3 /* * A list of directories in which Tcl should look for *.enc files. This list * is shared by all threads. Access is governed by a mutex lock. */ static TclInitProcessGlobalValueProc InitializeEncodingSearchPath; static ProcessGlobalValue encodingSearchPath = { 0, 0, NULL, NULL, InitializeEncodingSearchPath, NULL, NULL }; /* * A map from encoding names to the directories in which their data files have * been seen. The string value of the map is shared by all threads. Access * to the shared string is governed by a mutex lock. */ static ProcessGlobalValue encodingFileMap = { 0, 0, NULL, NULL, NULL, NULL, NULL }; /* * A list of directories making up the "library path". Historically this * search path has served many uses, but the only one remaining is a base for * the encodingSearchPath above. If the application does not explicitly set * the encodingSearchPath, then it will be initialized by appending /encoding * to each directory in this "libraryPath". */ static ProcessGlobalValue libraryPath = { 0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL }; static int encodingsInitialized = 0; /* * Hash table that keeps track of all loaded Encodings. Keys are the string * names that represent the encoding, values are (Encoding *). */ static Tcl_HashTable encodingTable; TCL_DECLARE_MUTEX(encodingMutex) /* * The following are used to hold the default and current system encodings. * If NULL is passed to one of the conversion routines, the current setting of * the system encoding will be used to perform the conversion. */ static Tcl_Encoding defaultEncoding; static Tcl_Encoding systemEncoding; /* * The following variable is used in the sparse matrix code for a |
︙ | ︙ | |||
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 | */ static int BinaryProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static void EscapeFreeProc _ANSI_ARGS_((ClientData clientData)); static int EscapeFromUtfProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static int EscapeToUtfProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static void FillEncodingFileMap (); static void FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); static Encoding * GetTableEncoding _ANSI_ARGS_(( EscapeEncodingData *dataPtr, int state)); static Tcl_Encoding LoadEncodingFile _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); static Tcl_Encoding LoadTableEncoding _ANSI_ARGS_((CONST char *name, int type, Tcl_Channel chan)); | > > > | | > | 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 | */ static int BinaryProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static void DupEncodingIntRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr)); static void EscapeFreeProc _ANSI_ARGS_((ClientData clientData)); static int EscapeFromUtfProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static int EscapeToUtfProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static void FillEncodingFileMap (); static void FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); static void FreeEncodingIntRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static Encoding * GetTableEncoding _ANSI_ARGS_(( EscapeEncodingData *dataPtr, int state)); static Tcl_Encoding LoadEncodingFile _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); static Tcl_Encoding LoadTableEncoding _ANSI_ARGS_((CONST char *name, int type, Tcl_Channel chan)); static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name, Tcl_Channel chan)); static Tcl_Channel OpenEncodingFileChannel _ANSI_ARGS_(( Tcl_Interp *interp, CONST char *name)); static void TableFreeProc _ANSI_ARGS_((ClientData clientData)); static int TableFromUtfProc _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 TableToUtfProc _ANSI_ARGS_((ClientData clientData, |
︙ | ︙ | |||
256 257 258 259 260 261 262 | int *dstCharsPtr)); static int UtfExtToUtfIntProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | < | | | | < | | | | | | | | | | > > > | | | | | | | < | | > | | | < > | | > | | < < > > < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 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 | int *dstCharsPtr)); static int UtfExtToUtfIntProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); /* * A Tcl_ObjType for holding a cached Tcl_Encoding as the intrep. This should * help the lifetime of encodings be more useful. See concerns raised in [Bug * 1077262]. */ static Tcl_ObjType EncodingType = { "encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL }; /* *---------------------------------------------------------------------- * * TclGetEncodingFromObj -- * * Writes to (*encodingPtr) the Tcl_Encoding value of (*objPtr), if * possible, and returns TCL_OK. If no such encoding exists, TCL_ERROR * is returned, and if interp is non-NULL, an error message is written * there. * * Results: * Standard Tcl return code. * * Side effects: * Caches the Tcl_Encoding value as the internal rep of (*objPtr). * *---------------------------------------------------------------------- */ int TclGetEncodingFromObj(interp, objPtr, encodingPtr) Tcl_Interp *interp; Tcl_Obj *objPtr; Tcl_Encoding *encodingPtr; { CONST char *name = Tcl_GetString(objPtr); if (objPtr->typePtr != &EncodingType) { Tcl_Encoding encoding = Tcl_GetEncoding(interp, name); if (encoding == NULL) { return TCL_ERROR; } TclFreeIntRep(objPtr); objPtr->internalRep.otherValuePtr = (VOID *) encoding; objPtr->typePtr = &EncodingType; } *encodingPtr = Tcl_GetEncoding(NULL, name); return TCL_OK; } /* *---------------------------------------------------------------------- * * FreeEncodingIntRep -- * * The Tcl_FreeInternalRepProc for the "encoding" Tcl_ObjType. * *---------------------------------------------------------------------- */ static void FreeEncodingIntRep(objPtr) Tcl_Obj *objPtr; { Tcl_FreeEncoding((Tcl_Encoding) objPtr->internalRep.otherValuePtr); } /* *---------------------------------------------------------------------- * * DupEncodingIntRep -- * * The Tcl_DupInternalRepProc for the "encoding" Tcl_ObjType. * *---------------------------------------------------------------------- */ static void DupEncodingIntRep(srcPtr, dupPtr) Tcl_Obj *srcPtr; Tcl_Obj *dupPtr; { dupPtr->internalRep.otherValuePtr = (VOID *) Tcl_GetEncoding(NULL, srcPtr->bytes); } /* *---------------------------------------------------------------------- * * TclGetEncodingSearchPath -- * * Keeps the per-thread copy of the encoding search path current with * changes to the global copy. * * Results: * Returns a "list" (Tcl_Obj *) that contains the encoding search path. * *---------------------------------------------------------------------- */ Tcl_Obj * TclGetEncodingSearchPath() { return TclGetProcessGlobalValue(&encodingSearchPath); } /* *---------------------------------------------------------------------- * * TclSetEncodingSearchPath -- * * Keeps the per-thread copy of the encoding search path current with * changes to the global copy. * *---------------------------------------------------------------------- */ int TclSetEncodingSearchPath(searchPath) Tcl_Obj *searchPath; { int dummy; if (TCL_ERROR == Tcl_ListObjLength(NULL, searchPath, &dummy)) { return TCL_ERROR; } TclSetProcessGlobalValue(&encodingSearchPath, searchPath, NULL); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclGetLibraryPath -- * * Keeps the per-thread copy of the library path current with changes to * the global copy. * * Results: * Returns a "list" (Tcl_Obj *) that contains the library path. * *---------------------------------------------------------------------- */ Tcl_Obj * TclGetLibraryPath() { return TclGetProcessGlobalValue(&libraryPath); } /* *---------------------------------------------------------------------- * * TclSetLibraryPath -- * * Keeps the per-thread copy of the library path current with changes to * the global copy. * * NOTE: this routine returns void, so there's no way to report the error * that searchPath is not a valid list. In that case, this routine will * silently do nothing. * *---------------------------------------------------------------------- */ void TclSetLibraryPath(path) Tcl_Obj *path; { int dummy; if (TCL_ERROR == Tcl_ListObjLength(NULL, path, &dummy)) { return; } TclSetProcessGlobalValue(&libraryPath, path, NULL); } /* *--------------------------------------------------------------------------- * * FillEncodingFileMap -- * * Called to bring the encoding file map in sync with the current value * of the encoding search path. * * Scan the directories on the encoding search path, find the *.enc * files, and store the found pathnames in a map associated with the * encoding name. * * In particular, if $dir is on the encoding search path, and the file * $dir/foo.enc is found, then store a "foo" -> $dir entry in the map. * Later, any need for the "foo" encoding will quickly * be able to * construct the $dir/foo.enc pathname for reading the encoding data. * * Results: * None. * * Side effects: * Entries are added to the encoding file map. * *--------------------------------------------------------------------------- */ static void FillEncodingFileMap() { int i, numDirs = 0; Tcl_Obj *map, *searchPath; searchPath = TclGetEncodingSearchPath(); Tcl_IncrRefCount(searchPath); Tcl_ListObjLength(NULL, searchPath, &numDirs); map = Tcl_NewDictObj(); Tcl_IncrRefCount(map); for (i = numDirs-1; i >= 0; i--) { /* * Iterate backwards through the search path so as we overwrite * entries found, we favor files earlier on the search path. */ int j, numFiles; Tcl_Obj *directory, *matchFileList = Tcl_NewObj(); Tcl_Obj **filev; Tcl_GlobTypeData readableFiles = { TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL }; Tcl_ListObjIndex(NULL, searchPath, i, &directory); Tcl_IncrRefCount(directory); Tcl_IncrRefCount(matchFileList); Tcl_FSMatchInDirectory(NULL, matchFileList, directory, "*.enc", &readableFiles); Tcl_ListObjGetElements(NULL, matchFileList, &numFiles, &filev); for (j=0; j<numFiles; j++) { Tcl_Obj *encodingName, *file; file = TclPathPart(NULL, filev[j], TCL_PATH_TAIL); encodingName = TclPathPart(NULL, file, TCL_PATH_ROOT); Tcl_DictObjPut(NULL, map, encodingName, directory); Tcl_DecrRefCount(file); Tcl_DecrRefCount(encodingName); } Tcl_DecrRefCount(matchFileList); Tcl_DecrRefCount(directory); } Tcl_DecrRefCount(searchPath); TclSetProcessGlobalValue(&encodingFileMap, map, NULL); Tcl_DecrRefCount(map); } /* *--------------------------------------------------------------------------- * * TclInitEncodingSubsystem -- * * Initialize all resources used by this subsystem on a per-process * basis. * * Results: * None. * * Side effects: * Depends on the memory, object, and IO subsystems. * |
︙ | ︙ | |||
475 476 477 478 479 480 481 | if (encodingsInitialized) { return; } Tcl_MutexLock(&encodingMutex); Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&encodingMutex); | | | | | | 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 | if (encodingsInitialized) { return; } Tcl_MutexLock(&encodingMutex); Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&encodingMutex); /* * Create a few initial encodings. Note that the UTF-8 to UTF-8 * translation is not a no-op, because it will turn a stream of improperly * formed UTF-8 into a properly formed stream. */ type.encodingName = "identity"; type.toUtfProc = BinaryProc; type.fromUtfProc = BinaryProc; type.freeProc = NULL; type.nullSize = 1; |
︙ | ︙ | |||
509 510 511 512 513 514 515 | type.fromUtfProc = UtfToUnicodeProc; type.freeProc = NULL; type.nullSize = 2; type.clientData = NULL; Tcl_CreateEncoding(&type); encodingsInitialized = 1; | < | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 | type.fromUtfProc = UtfToUnicodeProc; type.freeProc = NULL; type.nullSize = 2; type.clientData = NULL; Tcl_CreateEncoding(&type); encodingsInitialized = 1; } /* *---------------------------------------------------------------------- * * TclFinalizeEncodingSubsystem -- * |
︙ | ︙ | |||
535 536 537 538 539 540 541 | void TclFinalizeEncodingSubsystem() { Tcl_HashSearch search; Tcl_HashEntry *hPtr; Tcl_MutexLock(&encodingMutex); | | > | | | > > | | | | | 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 | void TclFinalizeEncodingSubsystem() { Tcl_HashSearch search; Tcl_HashEntry *hPtr; Tcl_MutexLock(&encodingMutex); encodingsInitialized = 0; FreeEncoding(systemEncoding); hPtr = Tcl_FirstHashEntry(&encodingTable, &search); while (hPtr != NULL) { /* * Call FreeEncoding instead of doing it directly to handle refcounts * like escape encodings use. [Bug #524674] Make sure to call * Tcl_FirstHashEntry repeatedly so that all encodings are eventually * cleaned up. */ FreeEncoding((Tcl_Encoding) Tcl_GetHashValue(hPtr)); hPtr = Tcl_FirstHashEntry(&encodingTable, &search); } Tcl_DeleteHashTable(&encodingTable); Tcl_MutexUnlock(&encodingMutex); } /* *------------------------------------------------------------------------- * * Tcl_GetDefaultEncodingDir -- * * Legacy public interface to retrieve first directory in the encoding * searchPath. * * Results: * The directory pathname, as a string, or NULL for an empty encoding * search path. * * Side effects: * None. * *------------------------------------------------------------------------- */ |
︙ | ︙ | |||
590 591 592 593 594 595 596 | } /* *------------------------------------------------------------------------- * * Tcl_SetDefaultEncodingDir -- * | | | | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 | } /* *------------------------------------------------------------------------- * * Tcl_SetDefaultEncodingDir -- * * Legacy public interface to set the first directory in the encoding * search path. * * Results: * None. * * Side effects: * Modifies the encoding search path. * |
︙ | ︙ | |||
625 626 627 628 629 630 631 | * * Given the name of a encoding, find the corresponding Tcl_Encoding * token. If the encoding did not already exist, Tcl attempts to * dynamically load an encoding by that name. * * Results: * Returns a token that represents the encoding. If the name didn't | | | | | | | | | 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 | * * Given the name of a encoding, find the corresponding Tcl_Encoding * token. If the encoding did not already exist, Tcl attempts to * dynamically load an encoding by that name. * * Results: * Returns a token that represents the encoding. If the name didn't * refer to any known or loadable encoding, NULL is returned. If NULL * was returned, an error message is left in interp's result object, * unless interp was NULL. * * Side effects: * The new encoding type is entered into a table visible to all * interpreters, keyed off the encoding's name. For each call to this * procedure, there should eventually be a call to Tcl_FreeEncoding, so * that the database can be cleaned up when encodings aren't needed * anymore. * *------------------------------------------------------------------------- */ Tcl_Encoding Tcl_GetEncoding(interp, name) Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */ |
︙ | ︙ | |||
663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 | if (hPtr != NULL) { encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); encodingPtr->refCount++; Tcl_MutexUnlock(&encodingMutex); return (Tcl_Encoding) encodingPtr; } Tcl_MutexUnlock(&encodingMutex); return LoadEncodingFile(interp, name); } /* *--------------------------------------------------------------------------- * * Tcl_FreeEncoding -- * * This procedure is called to release an encoding allocated by * Tcl_CreateEncoding() or Tcl_GetEncoding(). * * Results: * None. * * Side effects: | > | | | | | | | | 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 | if (hPtr != NULL) { encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); encodingPtr->refCount++; Tcl_MutexUnlock(&encodingMutex); return (Tcl_Encoding) encodingPtr; } Tcl_MutexUnlock(&encodingMutex); return LoadEncodingFile(interp, name); } /* *--------------------------------------------------------------------------- * * Tcl_FreeEncoding -- * * This procedure is called to release an encoding allocated by * Tcl_CreateEncoding() or Tcl_GetEncoding(). * * Results: * None. * * Side effects: * The reference count associated with the encoding is decremented and * the encoding may be deleted if nothing is using it anymore. * *--------------------------------------------------------------------------- */ void Tcl_FreeEncoding(encoding) Tcl_Encoding encoding; { Tcl_MutexLock(&encodingMutex); FreeEncoding(encoding); Tcl_MutexUnlock(&encodingMutex); } /* *---------------------------------------------------------------------- * * FreeEncoding -- * * This procedure is called to release an encoding by procedures that * already have the encodingMutex. * * Results: * None. * * Side effects: * The reference count associated with the encoding is decremented and * the encoding may be deleted if nothing is using it anymore. * *---------------------------------------------------------------------- */ static void FreeEncoding(encoding) Tcl_Encoding encoding; { Encoding *encodingPtr; encodingPtr = (Encoding *) encoding; if (encodingPtr == NULL) { return; } encodingPtr->refCount--; if (encodingPtr->refCount == 0) { if (encodingPtr->freeProc != NULL) { |
︙ | ︙ | |||
739 740 741 742 743 744 745 | } /* *------------------------------------------------------------------------- * * Tcl_GetEncodingName -- * | | | < < | | | | | 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 | } /* *------------------------------------------------------------------------- * * Tcl_GetEncodingName -- * * Given an encoding, return the name that was used to constuct the * encoding. * * Results: * The name of the encoding. * * Side effects: * None. * *--------------------------------------------------------------------------- */ CONST char * Tcl_GetEncodingName(encoding) Tcl_Encoding encoding; /* The encoding whose name to fetch. */ { if (encoding == NULL) { encoding = systemEncoding; } return ((Encoding *) encoding)->name; } /* *------------------------------------------------------------------------- * * Tcl_GetEncodingNames -- * * Get the list of all known encodings, including the ones stored as * files on disk in the encoding path. * * Results: * Modifies interp's result object to hold a list of all the available * encodings. * * Side effects: * None. |
︙ | ︙ | |||
795 796 797 798 799 800 801 | Tcl_HashEntry *hPtr; Tcl_Obj *map, *name, *result = Tcl_NewObj(); Tcl_DictSearch mapSearch; int dummy, done = 0; Tcl_InitObjHashTable(&table); | > | > > > | > > > | > > | | | | | | | | | | | | | 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 | Tcl_HashEntry *hPtr; Tcl_Obj *map, *name, *result = Tcl_NewObj(); Tcl_DictSearch mapSearch; int dummy, done = 0; Tcl_InitObjHashTable(&table); /* * Copy encoding names from loaded encoding table to table. */ Tcl_MutexLock(&encodingMutex); for (hPtr = Tcl_FirstHashEntry(&encodingTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Encoding *encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); Tcl_CreateHashEntry(&table, (char *) Tcl_NewStringObj(encodingPtr->name, -1), &dummy); } Tcl_MutexUnlock(&encodingMutex); FillEncodingFileMap(); map = TclGetProcessGlobalValue(&encodingFileMap); /* * Copy encoding names from encoding file map to table. */ Tcl_DictObjFirst(NULL, map, &mapSearch, &name, NULL, &done); for (; !done; Tcl_DictObjNext(&mapSearch, &name, NULL, &done)) { Tcl_CreateHashEntry(&table, (char *) name, &dummy); } /* * Pull all encoding names from table into the result list. */ for (hPtr = Tcl_FirstHashEntry(&table, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_ListObjAppendElement(NULL, result, (Tcl_Obj *) Tcl_GetHashKey(&table, hPtr)); } Tcl_SetObjResult(interp, result); Tcl_DeleteHashTable(&table); } /* *------------------------------------------------------------------------ * * Tcl_SetSystemEncoding -- * * Sets the default encoding that should be used whenever the user passes * a NULL value in to one of the conversion routines. If the supplied * name is NULL, the system encoding is reset to the default system * encoding. * * Results: * The return value is TCL_OK if the system encoding was successfully set * to the encoding specified by name, TCL_ERROR otherwise. If TCL_ERROR * is returned, an error message is left in interp's result object, * unless interp was NULL. * * Side effects: * The reference count of the new system encoding is incremented. The * reference count of the old system encoding is decremented and it may * be freed. * *------------------------------------------------------------------------ */ int Tcl_SetSystemEncoding(interp, name) Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */ |
︙ | ︙ | |||
884 885 886 887 888 889 890 | /* *--------------------------------------------------------------------------- * * Tcl_CreateEncoding -- * * This procedure is called to define a new encoding and the procedures | | | | | | | | | | | | | | | | | | 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 | /* *--------------------------------------------------------------------------- * * Tcl_CreateEncoding -- * * This procedure is called to define a new encoding and the procedures * that are used to convert between the specified encoding and Unicode. * * Results: * Returns a token that represents the encoding. If an encoding with the * same name already existed, the old encoding token remains valid and * continues to behave as it used to, and will eventually be garbage * collected when the last reference to it goes away. Any subsequent * calls to Tcl_GetEncoding with the specified name will retrieve the * most recent encoding token. * * Side effects: * The new encoding type is entered into a table visible to all * interpreters, keyed off the encoding's name. For each call to this * procedure, there should eventually be a call to Tcl_FreeEncoding, so * that the database can be cleaned up when encodings aren't needed * anymore. * *--------------------------------------------------------------------------- */ Tcl_Encoding Tcl_CreateEncoding(typePtr) Tcl_EncodingType *typePtr; /* The encoding type. */ { Tcl_HashEntry *hPtr; int new; Encoding *encodingPtr; char *name; Tcl_MutexLock(&encodingMutex); hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &new); if (new == 0) { /* * Remove old encoding from hash table, but don't delete it until last * reference goes away. */ encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); encodingPtr->hPtr = NULL; } name = ckalloc((unsigned) strlen(typePtr->encodingName) + 1); encodingPtr = (Encoding *) ckalloc(sizeof(Encoding)); encodingPtr->name = strcpy(name, typePtr->encodingName); encodingPtr->toUtfProc = typePtr->toUtfProc; encodingPtr->fromUtfProc = typePtr->fromUtfProc; encodingPtr->freeProc = typePtr->freeProc; encodingPtr->nullSize = typePtr->nullSize; encodingPtr->clientData = typePtr->clientData; |
︙ | ︙ | |||
953 954 955 956 957 958 959 | } /* *------------------------------------------------------------------------- * * Tcl_ExternalToUtfDString -- * | | | | | | | | | | | | | > > > > | 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 | } /* *------------------------------------------------------------------------- * * Tcl_ExternalToUtfDString -- * * Convert a source buffer from the specified encoding into UTF-8. If any * of the bytes in the source buffer are invalid or cannot be represented * in the target encoding, a default fallback character will be * substituted. * * Results: * The converted bytes are stored in the DString, which is then NULL * terminated. The return value is a pointer to the value stored in the * DString. * * Side effects: * None. * *------------------------------------------------------------------------- */ char * Tcl_ExternalToUtfDString(encoding, src, srcLen, dstPtr) Tcl_Encoding encoding; /* The encoding for the source string, or NULL * for the default system encoding. */ CONST char *src; /* Source string in specified encoding. */ int srcLen; /* Source string length in bytes, or < 0 for * encoding-specific string length. */ Tcl_DString *dstPtr; /* Uninitialized or free DString in which the * converted string is stored. */ { char *dst; Tcl_EncodingState state; Encoding *encodingPtr; int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; if (encoding == NULL) { encoding = systemEncoding; } encodingPtr = (Encoding *) encoding; if (src == NULL) { srcLen = 0; } else if (srcLen < 0) { srcLen = (*encodingPtr->lengthProc)(src); } flags = TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); return Tcl_DStringValue(dstPtr); } flags &= ~TCL_ENCODING_START; src += srcRead; srcLen -= srcRead; if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); } Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1); |
︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 | * * Tcl_ExternalToUtf -- * * Convert a source buffer from the specified encoding into UTF-8. * * Results: * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE, | | | | | | | | | | | | 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 | * * Tcl_ExternalToUtf -- * * Convert a source buffer from the specified encoding into UTF-8. * * Results: * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE, * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, as * documented in tcl.h. * * Side effects: * The converted bytes are stored in the output buffer. * *------------------------------------------------------------------------- */ int Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) Tcl_Interp *interp; /* Interp for error return, if not NULL. */ Tcl_Encoding encoding; /* The encoding for the source string, or NULL * for the default system encoding. */ CONST char *src; /* Source string in specified encoding. */ int srcLen; /* Source string length in bytes, or < 0 for * encoding-specific string length. */ int flags; /* Conversion control flags. */ Tcl_EncodingState *statePtr;/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string is * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length * if there was a problem converting some * source characters. */ int *dstWrotePtr; /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { Encoding *encodingPtr; int result, srcRead, dstWrote, dstChars; Tcl_EncodingState state; if (encoding == NULL) { encoding = systemEncoding; } encodingPtr = (Encoding *) encoding; if (src == NULL) { srcLen = 0; |
︙ | ︙ | |||
1099 1100 1101 1102 1103 1104 1105 | } if (dstCharsPtr == NULL) { dstCharsPtr = &dstChars; } /* * If there are any null characters in the middle of the buffer, they will | | | > | | | | | | | | | | | | > | > | 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 | } if (dstCharsPtr == NULL) { dstCharsPtr = &dstChars; } /* * If there are any null characters in the middle of the buffer, they will * converted to the UTF-8 null character (\xC080). To get the actual \0 at * the end of the destination buffer, we need to append it manually. */ dstLen--; result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr); dst[*dstWrotePtr] = '\0'; return result; } /* *------------------------------------------------------------------------- * * Tcl_UtfToExternalDString -- * * Convert a source buffer from UTF-8 into the specified encoding. If * any of the bytes in the source buffer are invalid or cannot be * represented in the target encoding, a default fallback character will * be substituted. * * Results: * The converted bytes are stored in the DString, which is then NULL * terminated in an encoding-specific manner. The return value is a * pointer to the value stored in the DString. * * Side effects: * None. * *------------------------------------------------------------------------- */ char * Tcl_UtfToExternalDString(encoding, src, srcLen, dstPtr) Tcl_Encoding encoding; /* The encoding for the converted string, or * NULL for the default system encoding. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes, or < 0 for * strlen(). */ Tcl_DString *dstPtr; /* Uninitialized or free DString in which the * converted string is stored. */ { char *dst; Tcl_EncodingState state; Encoding *encodingPtr; int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; if (encoding == NULL) { encoding = systemEncoding; } encodingPtr = (Encoding *) encoding; if (src == NULL) { srcLen = 0; } else if (srcLen < 0) { srcLen = strlen(src); } flags = TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); if (result != TCL_CONVERT_NOSPACE) { if (encodingPtr->nullSize == 2) { Tcl_DStringSetLength(dstPtr, soFar + 1); } Tcl_DStringSetLength(dstPtr, soFar); return Tcl_DStringValue(dstPtr); } flags &= ~TCL_ENCODING_START; src += srcRead; srcLen -= srcRead; if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); } Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1); |
︙ | ︙ | |||
1195 1196 1197 1198 1199 1200 1201 | * * Tcl_UtfToExternal -- * * Convert a buffer from UTF-8 into the specified encoding. * * Results: * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE, | | | | | | | | | 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 | * * Tcl_UtfToExternal -- * * Convert a buffer from UTF-8 into the specified encoding. * * Results: * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE, * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, as * documented in tcl.h. * * Side effects: * The converted bytes are stored in the output buffer. * *------------------------------------------------------------------------- */ int Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) Tcl_Interp *interp; /* Interp for error return, if not NULL. */ Tcl_Encoding encoding; /* The encoding for the converted string, or * NULL for the default system encoding. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes, or < 0 for * strlen(). */ int flags; /* Conversion control flags. */ Tcl_EncodingState *statePtr;/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string * is stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ |
︙ | ︙ | |||
1238 1239 1240 1241 1242 1243 1244 | int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { Encoding *encodingPtr; int result, srcRead, dstWrote, dstChars; Tcl_EncodingState state; | | | 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 | int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { Encoding *encodingPtr; int result, srcRead, dstWrote, dstChars; Tcl_EncodingState state; if (encoding == NULL) { encoding = systemEncoding; } encodingPtr = (Encoding *) encoding; if (src == NULL) { srcLen = 0; |
︙ | ︙ | |||
1271 1272 1273 1274 1275 1276 1277 | result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr); if (encodingPtr->nullSize == 2) { dst[*dstWrotePtr + 1] = '\0'; } dst[*dstWrotePtr] = '\0'; | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | < < | < < < < < < < < < | < < < < < < | < < < < < < < < | < < < < < < | | | < | | | < | | | < | | | < < < < < < | | | | | | | | | 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 | result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr); if (encodingPtr->nullSize == 2) { dst[*dstWrotePtr + 1] = '\0'; } dst[*dstWrotePtr] = '\0'; return result; } /* *--------------------------------------------------------------------------- * * Tcl_FindExecutable -- * * This procedure computes the absolute path name of the current * application, given its argv[0] value. * * Results: * None. * * Side effects: * The absolute pathname for the application is computed and stored to be * returned later be [info nameofexecutable]. * *--------------------------------------------------------------------------- */ void Tcl_FindExecutable(argv0) CONST char *argv0; /* The value of the application's argv[0] * (native). */ { TclInitSubsystems(); TclpSetInitialEncodings(); TclpFindExecutable(argv0); } /* *--------------------------------------------------------------------------- * * OpenEncodingFileChannel -- * * Open the file believed to hold data for the encoding, "name". * * Results: * Returns the readable Tcl_Channel from opening the file, or NULL if the * file could not be successfully opened. If NULL was * returned, an * error message is left in interp's result object, * unless interp was * NULL. * * Side effects: * Channel may be opened. Information about the filesystem may be cached * to speed later calls. * *--------------------------------------------------------------------------- */ static Tcl_Channel OpenEncodingFileChannel(interp, name) Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */ CONST char *name; /* The name of the encoding file on disk and * also the name for new encoding. */ { Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1); Tcl_Obj *fileNameObj = Tcl_DuplicateObj(nameObj); Tcl_Obj *searchPath = Tcl_DuplicateObj(TclGetEncodingSearchPath()); Tcl_Obj *map = TclGetProcessGlobalValue(&encodingFileMap); Tcl_Obj **dir, *path, *directory = NULL; Tcl_Channel chan = NULL; int i, numDirs; Tcl_ListObjGetElements(NULL, searchPath, &numDirs, &dir); Tcl_IncrRefCount(nameObj); Tcl_AppendToObj(fileNameObj, ".enc", -1); Tcl_IncrRefCount(fileNameObj); Tcl_DictObjGet(NULL, map, nameObj, &directory); /* * Check that any cached directory is still on the encoding search path. */ if (NULL != directory) { int verified = 0; for (i=0; i<numDirs && !verified; i++) { if (dir[i] == directory) { verified = 1; } } if (!verified) { CONST char *dirString = Tcl_GetString(directory); for (i=0; i<numDirs && !verified; i++) { if (strcmp(dirString, Tcl_GetString(dir[i])) == 0) { verified = 1; } } } if (!verified) { /* * Directory no longer on the search path. Remove from cache. */ map = Tcl_DuplicateObj(map); Tcl_DictObjRemove(NULL, map, nameObj); TclSetProcessGlobalValue(&encodingFileMap, map, NULL); directory = NULL; } } if (NULL != directory) { /* * Got a directory from the cache. Try to use it first. */ Tcl_IncrRefCount(directory); path = Tcl_FSJoinToPath(directory, 1, &fileNameObj); Tcl_IncrRefCount(path); Tcl_DecrRefCount(directory); chan = Tcl_FSOpenFileChannel(NULL, path, "r", 0); Tcl_DecrRefCount(path); } /* * Scan the search path until we find it. */ for (i=0; i<numDirs && (chan == NULL); i++) { path = Tcl_FSJoinToPath(dir[i], 1, &fileNameObj); Tcl_IncrRefCount(path); chan = Tcl_FSOpenFileChannel(NULL, path, "r", 0); Tcl_DecrRefCount(path); if (chan != NULL) { /* * Save directory in the cache. */ map = Tcl_DuplicateObj(TclGetProcessGlobalValue(&encodingFileMap)); Tcl_DictObjPut(NULL, map, nameObj, dir[i]); TclSetProcessGlobalValue(&encodingFileMap, map, NULL); } } if ((NULL == chan) && (interp != NULL)) { Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL); } Tcl_DecrRefCount(fileNameObj); Tcl_DecrRefCount(nameObj); Tcl_DecrRefCount(searchPath); return chan; } /* *--------------------------------------------------------------------------- * * LoadEncodingFile -- * * Read a file that describes an encoding and create a new Encoding from * the data. * * Results: * The return value is the newly loaded Encoding, or NULL if the file * didn't exist of was in the incorrect format. If NULL was returned, an * error message is left in interp's result object, unless interp was * NULL. * * Side effects: * File read from disk. * *--------------------------------------------------------------------------- */ static Tcl_Encoding LoadEncodingFile(interp, name) Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */ CONST char *name; /* The name of the encoding file on disk and * also the name for new encoding. */ { Tcl_Channel chan = NULL; Tcl_Encoding encoding = NULL; int ch; chan = OpenEncodingFileChannel(interp, name); if (chan == NULL) { return NULL; } Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); while (1) { Tcl_DString ds; Tcl_DStringInit(&ds); Tcl_Gets(chan, &ds); ch = Tcl_DStringValue(&ds)[0]; Tcl_DStringFree(&ds); if (ch != '#') { break; } } switch (ch) { case 'S': encoding = LoadTableEncoding(name, ENCODING_SINGLEBYTE, chan); break; case 'D': encoding = LoadTableEncoding(name, ENCODING_DOUBLEBYTE, chan); break; case 'M': encoding = LoadTableEncoding(name, ENCODING_MULTIBYTE, chan); break; case 'E': encoding = LoadEscapeEncoding(name, chan); break; } if ((encoding == NULL) && (interp != NULL)) { Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL); } Tcl_Close(NULL, chan); return encoding; } /* *------------------------------------------------------------------------- * * LoadTableEncoding -- * * Helper function for LoadEncodingTable(). Loads a table to that * converts between Unicode and some other encoding and creates an * encoding (using a TableEncoding structure) from that information. * * File contains binary data, but begins with a marker to indicate * byte-ordering, so that same binary file can be read on either endian * platforms. * * Results: * The return value is the new encoding, or NULL if the encoding could * not be created (because the file contained invalid data). * * Side effects: * None. * *------------------------------------------------------------------------- */ |
︙ | ︙ | |||
1503 1504 1505 1506 1507 1508 1509 | dataPtr = (TableEncodingData *) ckalloc(sizeof(TableEncodingData)); memset(dataPtr, 0, sizeof(TableEncodingData)); dataPtr->fallback = fallback; /* * Read the table that maps characters to Unicode. Performs a single | | | | | | | | | | | 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 | dataPtr = (TableEncodingData *) ckalloc(sizeof(TableEncodingData)); memset(dataPtr, 0, sizeof(TableEncodingData)); dataPtr->fallback = fallback; /* * Read the table that maps characters to Unicode. Performs a single * malloc to get the memory for the array and all the pages needed by the * array. */ size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; dataPtr->toUnicode = (unsigned short **) ckalloc(size); memset(dataPtr->toUnicode, 0, size); pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256); TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); for (i = 0; i < numPages; i++) { int ch; char *p; Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0); p = Tcl_GetString(objPtr); hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])]; dataPtr->toUnicode[hi] = pageMemPtr; p += 2; for (lo = 0; lo < 256; lo++) { if ((lo & 0x0f) == 0) { p++; } ch = (staticHex[UCHAR(p[0])] << 12) + (staticHex[UCHAR(p[1])] << 8) + (staticHex[UCHAR(p[2])] << 4) + staticHex[UCHAR(p[3])]; if (ch != 0) { used[ch >> 8] = 1; } *pageMemPtr = (unsigned short) ch; pageMemPtr++; p += 4; } } TclDecrRefCount(objPtr); if (type == ENCODING_DOUBLEBYTE) { memset(dataPtr->prefixBytes, 1, sizeof(dataPtr->prefixBytes)); } else { for (hi = 1; hi < 256; hi++) { if (dataPtr->toUnicode[hi] != NULL) { dataPtr->prefixBytes[hi] = 1; } } } /* * Invert toUnicode array to produce the fromUnicode array. Performs a * single malloc to get the memory for the array and all the pages needed * by the array. While reading in the toUnicode array, we remembered what * pages that would be needed for the fromUnicode array. */ if (symbol) { used[0] = 1; } numPages = 0; for (hi = 0; hi < 256; hi++) { |
︙ | ︙ | |||
1580 1581 1582 1583 1584 1585 1586 | } else { for (lo = 0; lo < 256; lo++) { int ch; ch = dataPtr->toUnicode[hi][lo]; if (ch != 0) { unsigned short *page; | | | 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 | } else { for (lo = 0; lo < 256; lo++) { int ch; ch = dataPtr->toUnicode[hi][lo]; if (ch != 0) { unsigned short *page; page = dataPtr->fromUnicode[ch >> 8]; if (page == NULL) { page = pageMemPtr; pageMemPtr += 256; dataPtr->fromUnicode[ch >> 8] = page; } page[ch & 0xff] = (unsigned short) ((hi << 8) + lo); |
︙ | ︙ | |||
1608 1609 1610 1611 1612 1613 1614 | if (dataPtr->fromUnicode[0]['\\'] == '\0') { dataPtr->fromUnicode[0]['\\'] = '\\'; } } } if (symbol) { unsigned short *page; | | | | | | | < > > > > | > > > | | > | | 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 | if (dataPtr->fromUnicode[0]['\\'] == '\0') { dataPtr->fromUnicode[0]['\\'] = '\\'; } } } if (symbol) { unsigned short *page; /* * Make a special symbol encoding that not only maps the symbol * characters from their Unicode code points down into page 0, but * also ensure that the characters on page 0 map to themselves. This * is so that a symbol font can be used to display a simple string * like "abcd" and have alpha, beta, chi, delta show up, rather than * have "unknown" chars show up because strictly speaking the symbol * font doesn't have glyphs for those low ascii chars. */ page = dataPtr->fromUnicode[0]; if (page == NULL) { page = pageMemPtr; dataPtr->fromUnicode[0] = page; } for (lo = 0; lo < 256; lo++) { if (dataPtr->toUnicode[0][lo] != 0) { page[lo] = (unsigned short) lo; } } } for (hi = 0; hi < 256; hi++) { if (dataPtr->fromUnicode[hi] == NULL) { dataPtr->fromUnicode[hi] = emptyPage; } } /* * For trailing 'R'everse encoding, see [Patch #689341] */ Tcl_DStringInit(&lineString); do { int len; /* * Skip leading empty lines. */ while ((len = Tcl_Gets(chan, &lineString)) == 0) ; if (len < 0) { break; } line = Tcl_DStringValue(&lineString); if (line[0] != 'R') { break; } for (Tcl_DStringSetLength(&lineString, 0); (len = Tcl_Gets(chan, &lineString)) >= 0; Tcl_DStringSetLength(&lineString, 0)) { unsigned char* p; int to, from; if (len < 5) { continue; } p = (unsigned char*) Tcl_DStringValue(&lineString); to = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8) + (staticHex[p[2]] << 4) + staticHex[p[3]]; if (to == 0) { continue; } for (p += 5, len -= 5; len >= 0 && *p; p += 5, len -= 5) { from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8) + (staticHex[p[2]] << 4) + staticHex[p[3]]; if (from == 0) { |
︙ | ︙ | |||
1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 | encType.encodingName = name; encType.toUtfProc = TableToUtfProc; encType.fromUtfProc = TableFromUtfProc; encType.freeProc = TableFreeProc; encType.nullSize = (type == ENCODING_DOUBLEBYTE) ? 2 : 1; encType.clientData = (ClientData) dataPtr; return Tcl_CreateEncoding(&encType); } /* *------------------------------------------------------------------------- * * LoadEscapeEncoding -- * | > | | | | | | | 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 | encType.encodingName = name; encType.toUtfProc = TableToUtfProc; encType.fromUtfProc = TableFromUtfProc; encType.freeProc = TableFreeProc; encType.nullSize = (type == ENCODING_DOUBLEBYTE) ? 2 : 1; encType.clientData = (ClientData) dataPtr; return Tcl_CreateEncoding(&encType); } /* *------------------------------------------------------------------------- * * LoadEscapeEncoding -- * * Helper function for LoadEncodingTable(). Loads a state machine that * converts between Unicode and some other encoding. * * File contains text data that describes the escape sequences that are * used to choose an encoding and the associated names for the * sub-encodings. * * Results: * The return value is the new encoding, or NULL if the encoding could * not be created (because the file contained invalid data). * * Side effects: * None. * *------------------------------------------------------------------------- */ |
︙ | ︙ | |||
1730 1731 1732 1733 1734 1735 1736 | Tcl_DStringInit(&escapeData); while (1) { int argc; CONST char **argv; char *line; Tcl_DString lineString; | | | | 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 | Tcl_DStringInit(&escapeData); while (1) { int argc; CONST char **argv; char *line; Tcl_DString lineString; Tcl_DStringInit(&lineString); if (Tcl_Gets(chan, &lineString) < 0) { break; } line = Tcl_DStringValue(&lineString); if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) { continue; } if (argc >= 2) { if (strcmp(argv[0], "name") == 0) { ; } else if (strcmp(argv[0], "init") == 0) { strncpy(init, argv[1], sizeof(init)); |
︙ | ︙ | |||
1758 1759 1760 1761 1762 1763 1764 | strncpy(est.sequence, argv[1], sizeof(est.sequence)); est.sequence[sizeof(est.sequence) - 1] = '\0'; est.sequenceLen = strlen(est.sequence); strncpy(est.name, argv[0], sizeof(est.name)); est.name[sizeof(est.name) - 1] = '\0'; | > | > > | | > | | 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 | strncpy(est.sequence, argv[1], sizeof(est.sequence)); est.sequence[sizeof(est.sequence) - 1] = '\0'; est.sequenceLen = strlen(est.sequence); strncpy(est.name, argv[0], sizeof(est.name)); est.name[sizeof(est.name) - 1] = '\0'; /* * To avoid infinite recursion in [encoding system iso2022-*] */ Tcl_GetEncoding(NULL, est.name); est.encodingPtr = NULL; Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); } } ckfree((char *) argv); Tcl_DStringFree(&lineString); } size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable) + Tcl_DStringLength(&escapeData); dataPtr = (EscapeEncodingData *) ckalloc(size); dataPtr->initLen = strlen(init); strcpy(dataPtr->init, init); dataPtr->finalLen = strlen(final); strcpy(dataPtr->final, final); dataPtr->numSubTables = Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable); memcpy((VOID *) dataPtr->subTables, (VOID *) Tcl_DStringValue(&escapeData), (size_t) Tcl_DStringLength(&escapeData)); Tcl_DStringFree(&escapeData); memset(dataPtr->prefixBytes, 0, sizeof(dataPtr->prefixBytes)); for (i = 0; i < dataPtr->numSubTables; i++) { dataPtr->prefixBytes[UCHAR(dataPtr->subTables[i].sequence[0])] = 1; |
︙ | ︙ | |||
1807 1808 1809 1810 1811 1812 1813 | } /* *------------------------------------------------------------------------- * * BinaryProc -- * | | | | | | | | | 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 | } /* *------------------------------------------------------------------------- * * BinaryProc -- * * The default conversion when no other conversion is specified. No * translation is done; source bytes are copied directly to destination * bytes. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: * None. * *------------------------------------------------------------------------- */ static int BinaryProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* Not used. */ CONST char *src; /* Source string (unknown encoding). */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ Tcl_EncodingState *statePtr;/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string is * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. */ int *dstWrotePtr; /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ |
︙ | ︙ | |||
1866 1867 1868 1869 1870 1871 1872 | *dstCharsPtr = srcLen; for ( ; --srcLen >= 0; ) { *dst++ = *src++; } return result; } | < | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | 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 | *dstCharsPtr = srcLen; for ( ; --srcLen >= 0; ) { *dst++ = *src++; } return result; } /* *------------------------------------------------------------------------- * * UtfExtToUtfIntProc -- * * Convert from UTF-8 to UTF-8. While converting null-bytes from the * Tcl's internal representation (0xc0, 0x80) to the official * representation (0x00). See UtfToUtfProc for details. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: * None. * *------------------------------------------------------------------------- */ static int UtfIntToUtfExtProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* Not used. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ Tcl_EncodingState *statePtr;/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string * is stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length * if there was a problem converting some * source characters. */ int *dstWrotePtr; /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr, 1); } /* *------------------------------------------------------------------------- * * UtfExtToUtfIntProc -- * * Convert from UTF-8 to UTF-8 while converting null-bytes from * the official representation (0x00) to Tcl's internal * representation (0xc0, 0x80). See UtfToUtfProc for details. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: * None. * *------------------------------------------------------------------------- */ static int UtfExtToUtfIntProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* Not used. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ Tcl_EncodingState *statePtr;/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string is * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length * if there was a problem converting some * source characters. */ int *dstWrotePtr; /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr, 0); } /* *------------------------------------------------------------------------- * * UtfToUtfProc -- * * Convert from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 translation * is not a no-op, because it will turn a stream of improperly formed * UTF-8 into a properly formed stream. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: * None. * *------------------------------------------------------------------------- */ static int UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr, pureNullMode) ClientData clientData; /* Not used. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ Tcl_EncodingState *statePtr;/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string is * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This may * be less than the original source length if * there was a problem converting some source * characters. */ int *dstWrotePtr; /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ int pureNullMode; /* Convert embedded nulls from internal * representation to real null-bytes or vice * versa. */ { CONST char *srcStart, *srcEnd, *srcClose; char *dstStart, *dstEnd; int result, numChars; Tcl_UniChar ch; result = TCL_OK; srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { srcClose -= TCL_UTF_MAX; } |
︙ | ︙ | |||
2046 2047 2048 2049 2050 2051 2052 | result = TCL_CONVERT_MULTIBYTE; break; } if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } | | < | | > | < | | > | 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 | result = TCL_CONVERT_MULTIBYTE; break; } if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && pureNullMode == 0)) { /* * Copy 7bit chatacters, but skip null-bytes when we are in input * mode, so that they get converted to 0xc080. */ *dst++ = *src++; } else if (pureNullMode == 1 && UCHAR(*src) == 0xc0 && UCHAR(*(src+1)) == 0x80) { /* * Convert 0xc080 to real nulls when we are in output mode. */ *dst++ = 0; src += 2; } else { src += Tcl_UtfToUniChar(src, &ch); dst += Tcl_UniCharToUtf(ch, dst); } } |
︙ | ︙ | |||
2089 2090 2091 2092 2093 2094 2095 | * * Side effects: * None. * *------------------------------------------------------------------------- */ | | | | | | | > > | 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 | * * Side effects: * None. * *------------------------------------------------------------------------- */ static int UnicodeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* Not used. */ CONST char *src; /* Source string in Unicode. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ Tcl_EncodingState *statePtr;/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string is * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length * if there was a problem converting some * source characters. */ int *dstWrotePtr; /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { CONST Tcl_UniChar *wSrc, *wSrcStart, *wSrcEnd; char *dstEnd, *dstStart; int result, numChars; result = TCL_OK; if ((srcLen % sizeof(Tcl_UniChar)) != 0) { result = TCL_CONVERT_MULTIBYTE; srcLen /= sizeof(Tcl_UniChar); srcLen *= sizeof(Tcl_UniChar); } wSrc = (Tcl_UniChar *) src; wSrcStart = (Tcl_UniChar *) src; wSrcEnd = (Tcl_UniChar *) (src + srcLen); dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; for (numChars = 0; wSrc < wSrcEnd; numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } /* * Special case for 1-byte utf chars for speed. */ if (*wSrc && *wSrc < 0x80) { *dst++ = (char) *wSrc; } else { dst += Tcl_UniCharToUtf(*wSrc, dst); } wSrc++; } |
︙ | ︙ | |||
2174 2175 2176 2177 2178 2179 2180 | * * Side effects: * None. * *------------------------------------------------------------------------- */ | | | > | | | | | | 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 | * * Side effects: * None. * *------------------------------------------------------------------------- */ static int UtfToUnicodeProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* TableEncodingData that specifies * encoding. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ Tcl_EncodingState *statePtr;/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string is * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length * if there was a problem converting some * source characters. */ int *dstWrotePtr; /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { CONST char *srcStart, *srcEnd, *srcClose; Tcl_UniChar *wDst, *wDstStart, *wDstEnd; int result, numChars; srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { srcClose -= TCL_UTF_MAX; } |
︙ | ︙ | |||
2231 2232 2233 2234 2235 2236 2237 | result = TCL_CONVERT_MULTIBYTE; break; } if (wDst > wDstEnd) { result = TCL_CONVERT_NOSPACE; break; | | > | 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 | result = TCL_CONVERT_MULTIBYTE; break; } if (wDst > wDstEnd) { result = TCL_CONVERT_NOSPACE; break; } src += TclUtfToUniChar(src, wDst); wDst++; } *srcReadPtr = src - srcStart; *dstWrotePtr = (char *) wDst - (char *) wDstStart; *dstCharsPtr = numChars; return result; } /* |
︙ | ︙ | |||
2258 2259 2260 2261 2262 2263 2264 | * * Side effects: * None. * *------------------------------------------------------------------------- */ | | | | | | | 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 | * * Side effects: * None. * *------------------------------------------------------------------------- */ static int TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* TableEncodingData that specifies * encoding. */ CONST char *src; /* Source string in specified encoding. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ Tcl_EncodingState *statePtr;/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string is * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length * if there was a problem converting some * source characters. */ |
︙ | ︙ | |||
2294 2295 2296 2297 2298 2299 2300 | CONST char *srcStart, *srcEnd; char *dstEnd, *dstStart, *prefixBytes; int result, byte, numChars; Tcl_UniChar ch; unsigned short **toUnicode; unsigned short *pageZero; TableEncodingData *dataPtr; | | | | | | | 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 | CONST char *srcStart, *srcEnd; char *dstEnd, *dstStart, *prefixBytes; int result, byte, numChars; Tcl_UniChar ch; unsigned short **toUnicode; unsigned short *pageZero; TableEncodingData *dataPtr; srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; dataPtr = (TableEncodingData *) clientData; toUnicode = dataPtr->toUnicode; prefixBytes = dataPtr->prefixBytes; pageZero = toUnicode[0]; result = TCL_OK; for (numChars = 0; src < srcEnd; numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } byte = *((unsigned char *) src); if (prefixBytes[byte]) { src++; if (src >= srcEnd) { src--; result = TCL_CONVERT_MULTIBYTE; break; |
︙ | ︙ | |||
2342 2343 2344 2345 2346 2347 2348 | * Special case for 1-byte utf chars for speed. */ if (ch && ch < 0x80) { *dst++ = (char) ch; } else { dst += Tcl_UniCharToUtf(ch, dst); } | | > | 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 | * Special case for 1-byte utf chars for speed. */ if (ch && ch < 0x80) { *dst++ = (char) ch; } else { dst += Tcl_UniCharToUtf(ch, dst); } src++; } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; return result; } /* |
︙ | ︙ | |||
2367 2368 2369 2370 2371 2372 2373 | * * Side effects: * None. * *------------------------------------------------------------------------- */ | | | | | | | | | | 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 | * * Side effects: * None. * *------------------------------------------------------------------------- */ static int TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* TableEncodingData that specifies * encoding. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ Tcl_EncodingState *statePtr;/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string is * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length * if there was a problem converting some * source characters. */ int *dstWrotePtr; /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { CONST char *srcStart, *srcEnd, *srcClose; char *dstStart, *dstEnd, *prefixBytes; Tcl_UniChar ch; int result, len, word, numChars; TableEncodingData *dataPtr; unsigned short **fromUnicode; result = TCL_OK; dataPtr = (TableEncodingData *) clientData; prefixBytes = dataPtr->prefixBytes; fromUnicode = dataPtr->fromUnicode; srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { srcClose -= TCL_UTF_MAX; } |
︙ | ︙ | |||
2433 2434 2435 2436 2437 2438 2439 | result = TCL_CONVERT_MULTIBYTE; break; } len = TclUtfToUniChar(src, &ch); #if TCL_UTF_MAX > 3 /* | | | > | | > | | | 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 | result = TCL_CONVERT_MULTIBYTE; break; } len = TclUtfToUniChar(src, &ch); #if TCL_UTF_MAX > 3 /* * This prevents a crash condition. More evaluation is required for * full support of int Tcl_UniChar. [Bug 1004065] */ if (ch & 0xffff0000) { word = 0; } else #endif word = fromUnicode[(ch >> 8)][ch & 0xff]; if ((word == 0) && (ch != 0)) { if (flags & TCL_ENCODING_STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } word = dataPtr->fallback; } if (prefixBytes[(word >> 8)] != 0) { if (dst + 1 > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } dst[0] = (char) (word >> 8); dst[1] = (char) word; dst += 2; } else { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } dst[0] = (char) word; dst++; } src += len; } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; return result; } /* *--------------------------------------------------------------------------- * * TableFreeProc -- * * This procedure is invoked when an encoding is deleted. It deletes the * memory used by the TableEncodingData. * * Results: * None. * * Side effects: * Memory freed. * |
︙ | ︙ | |||
2524 2525 2526 2527 2528 2529 2530 | * * Side effects: * None. * *------------------------------------------------------------------------- */ | | | | | | | 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 | * * Side effects: * None. * *------------------------------------------------------------------------- */ static int EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* EscapeEncodingData that specifies * encoding. */ CONST char *src; /* Source string in specified encoding. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ Tcl_EncodingState *statePtr;/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string is * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This * may be less than the original source length * if there was a problem converting some * source characters. */ |
︙ | ︙ | |||
2584 2585 2586 2587 2588 2589 2590 | if (flags & TCL_ENCODING_START) { state = 0; } for (numChars = 0; src < srcEnd; ) { int byte, hi, lo, ch; | | | | | | | | > < | | | > > < | | | > | > | | | 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 | if (flags & TCL_ENCODING_START) { state = 0; } for (numChars = 0; src < srcEnd; ) { int byte, hi, lo, ch; if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } byte = *((unsigned char *) src); if (prefixBytes[byte]) { unsigned int left, len, longest; int checked, i; EscapeSubTable *subTablePtr; /* * Saw the beginning of an escape sequence. */ left = srcEnd - src; len = dataPtr->initLen; longest = len; checked = 0; if (len <= left) { checked++; if ((len > 0) && (memcmp(src, dataPtr->init, len) == 0)) { /* * If we see initialization string, skip it, even if we're * not at the beginning of the buffer. */ src += len; continue; } } len = dataPtr->finalLen; if (len > longest) { longest = len; } if (len <= left) { checked++; if ((len > 0) && (memcmp(src, dataPtr->final, len) == 0)) { /* * If we see finalization string, skip it, even if we're * not at the end of the buffer. */ src += len; continue; } } subTablePtr = dataPtr->subTables; for (i = 0; i < dataPtr->numSubTables; i++) { len = subTablePtr->sequenceLen; if (len > longest) { longest = len; } if (len <= left) { checked++; if ((len > 0) && (memcmp(src, subTablePtr->sequence, len) == 0)) { state = i; encodingPtr = NULL; subTablePtr = NULL; src += len; break; } } subTablePtr++; } if (subTablePtr == NULL) { /* * A match was found, the escape sequence was consumed, and * the state was updated. */ continue; } /* * We have a split-up or unrecognized escape sequence. If we * checked all the sequences, then it's a syntax error, otherwise * we need more bytes to determine a match. */ if ((checked == dataPtr->numSubTables + 2) || (flags & TCL_ENCODING_END)) { if ((flags & TCL_ENCODING_STOPONERROR) == 0) { /* * Skip the unknown escape sequence. |
︙ | ︙ | |||
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 | TableEncodingData *tableDataPtr; encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; tablePrefixBytes = tableDataPtr->prefixBytes; tableToUnicode = tableDataPtr->toUnicode; } if (tablePrefixBytes[byte]) { src++; if (src >= srcEnd) { src--; result = TCL_CONVERT_MULTIBYTE; break; } hi = byte; lo = *((unsigned char *) src); } else { hi = 0; lo = byte; } ch = tableToUnicode[hi][lo]; dst += Tcl_UniCharToUtf(ch, dst); src++; numChars++; } *statePtr = (Tcl_EncodingState) state; | > > | 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 | TableEncodingData *tableDataPtr; encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; tablePrefixBytes = tableDataPtr->prefixBytes; tableToUnicode = tableDataPtr->toUnicode; } if (tablePrefixBytes[byte]) { src++; if (src >= srcEnd) { src--; result = TCL_CONVERT_MULTIBYTE; break; } hi = byte; lo = *((unsigned char *) src); } else { hi = 0; lo = byte; } ch = tableToUnicode[hi][lo]; dst += Tcl_UniCharToUtf(ch, dst); src++; numChars++; } *statePtr = (Tcl_EncodingState) state; |
︙ | ︙ | |||
2734 2735 2736 2737 2738 2739 2740 | * * Side effects: * None. * *------------------------------------------------------------------------- */ | | | | | | | | | | | | | 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 | * * Side effects: * None. * *------------------------------------------------------------------------- */ static int EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* EscapeEncodingData that specifies * encoding. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ Tcl_EncodingState *statePtr;/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst; /* Output buffer in which converted string is * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the * source string that were converted. This may * be less than the original source length if * there was a problem converting some source * characters. */ int *dstWrotePtr; /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { EscapeEncodingData *dataPtr; Encoding *encodingPtr; CONST char *srcStart, *srcEnd, *srcClose; char *dstStart, *dstEnd; int state, result, numChars; TableEncodingData *tableDataPtr; char *tablePrefixBytes; unsigned short **tableFromUnicode; result = TCL_OK; dataPtr = (EscapeEncodingData *) clientData; srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { |
︙ | ︙ | |||
2798 2799 2800 2801 2802 2803 2804 | if (flags & TCL_ENCODING_START) { state = 0; if (dst + dataPtr->initLen > dstEnd) { *srcReadPtr = 0; *dstWrotePtr = 0; return TCL_CONVERT_NOSPACE; } | | < | | | | | | > > | 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 | if (flags & TCL_ENCODING_START) { state = 0; if (dst + dataPtr->initLen > dstEnd) { *srcReadPtr = 0; *dstWrotePtr = 0; return TCL_CONVERT_NOSPACE; } memcpy((VOID *)dst, (VOID *)dataPtr->init, (size_t)dataPtr->initLen); dst += dataPtr->initLen; } else { state = (int) *statePtr; } encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; tablePrefixBytes = tableDataPtr->prefixBytes; tableFromUnicode = tableDataPtr->fromUnicode; for (numChars = 0; src < srcEnd; numChars++) { unsigned int len; int word; Tcl_UniChar ch; if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the * last UTF-8 character in the source buffer hasn't been cut off. */ result = TCL_CONVERT_MULTIBYTE; break; } len = TclUtfToUniChar(src, &ch); word = tableFromUnicode[(ch >> 8)][ch & 0xff]; if ((word == 0) && (ch != 0)) { int oldState; EscapeSubTable *subTablePtr; oldState = state; for (state = 0; state < dataPtr->numSubTables; state++) { encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xff]; if (word != 0) { break; } } if (word == 0) { state = oldState; if (flags & TCL_ENCODING_STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; word = tableDataPtr->fallback; } tablePrefixBytes = tableDataPtr->prefixBytes; tableFromUnicode = tableDataPtr->fromUnicode; /* * The state variable has the value of oldState when word is 0. * In this case, the escape sequense should not be copied to dst * because the current character set is not changed. */ if (state != oldState) { subTablePtr = &dataPtr->subTables[state]; if ((dst + subTablePtr->sequenceLen) > dstEnd) { /* * If there is no space to write the escape sequence, the * state variable must be changed to the value of oldState * variable because this escape sequence must be written * in the next conversion. */ state = oldState; result = TCL_CONVERT_NOSPACE; break; } memcpy((VOID *) dst, (VOID *) subTablePtr->sequence, (size_t) subTablePtr->sequenceLen); dst += subTablePtr->sequenceLen; |
︙ | ︙ | |||
2894 2895 2896 2897 2898 2899 2900 | } else { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } dst[0] = (char) word; dst++; | | | 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 | } else { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } dst[0] = (char) word; dst++; } src += len; } if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) { unsigned int len = dataPtr->subTables[0].sequenceLen; if (dst + dataPtr->finalLen + (state?len:0) > dstEnd) { result = TCL_CONVERT_NOSPACE; |
︙ | ︙ | |||
2926 2927 2928 2929 2930 2931 2932 | } /* *--------------------------------------------------------------------------- * * EscapeFreeProc -- * | | | 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 | } /* *--------------------------------------------------------------------------- * * EscapeFreeProc -- * * This procedure is invoked when an EscapeEncodingData encoding is * deleted. It deletes the memory used by the encoding. * * Results: * None. * * Side effects: * Memory freed. |
︙ | ︙ | |||
2971 2972 2973 2974 2975 2976 2977 | * encoding (of type TextEncodingData) that represents the specified * state. * * Results: * The return value is the encoding. * * Side effects: | | | | | > | > | | | | 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 | * encoding (of type TextEncodingData) that represents the specified * state. * * Results: * The return value is the encoding. * * Side effects: * If the encoding that represents the specified state has not already * been used by this EscapeEncoding, it will be loaded and cached in the * dataPtr. * *--------------------------------------------------------------------------- */ static Encoding * GetTableEncoding(dataPtr, state) EscapeEncodingData *dataPtr;/* Contains names of encodings. */ int state; /* Index in dataPtr of desired Encoding. */ { EscapeSubTable *subTablePtr; Encoding *encodingPtr; subTablePtr = &dataPtr->subTables[state]; encodingPtr = subTablePtr->encodingPtr; if (encodingPtr == NULL) { encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name); if ((encodingPtr == NULL) || (encodingPtr->toUtfProc != TableToUtfProc)) { Tcl_Panic("EscapeToUtfProc: invalid sub table"); } subTablePtr->encodingPtr = encodingPtr; } return encodingPtr; } /* *--------------------------------------------------------------------------- * * unilen -- * * A helper function for the Tcl_ExternalToUtf functions. This function * is similar to strlen for double-byte characters: it returns the number * of bytes in a 0x0000 terminated string. * * Results: * As above. * * Side effects: * None. * |
︙ | ︙ | |||
3035 3036 3037 3038 3039 3040 3041 | } /* *------------------------------------------------------------------------- * * InitializeEncodingSearchPath -- * | | | | | | | < | | | | > | | > > < | < < < < < < < | < < | | | < < < < < < < < < < < < < < < < < < < < < < | 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 | } /* *------------------------------------------------------------------------- * * InitializeEncodingSearchPath -- * * This is the fallback routine that sets the default value of the * encoding search path if the application has not set one via a call to * TclSetEncodingSearchPath() by the first time the search path is needed * to load encoding data. * * The default encoding search path is produced by taking each directory * in the library path, appending a subdirectory named "encoding", and if * the resulting directory exists, adding it to the encoding search path. * * Results: * None. * * Side effects: * Sets the encoding search path to an initial value. * *------------------------------------------------------------------------- */ static void InitializeEncodingSearchPath(valuePtr, lengthPtr, encodingPtr) char **valuePtr; int *lengthPtr; Tcl_Encoding *encodingPtr; { char *bytes; int i, numDirs, numBytes; Tcl_Obj *libPath, *encodingObj = Tcl_NewStringObj("encoding", -1); Tcl_Obj *searchPath = Tcl_NewObj(); Tcl_IncrRefCount(encodingObj); Tcl_IncrRefCount(searchPath); libPath = TclGetLibraryPath(); Tcl_IncrRefCount(libPath); Tcl_ListObjLength(NULL, libPath, &numDirs); for (i = 0; i < numDirs; i++) { Tcl_Obj *directory, *path; Tcl_StatBuf stat; Tcl_ListObjIndex(NULL, libPath, i, &directory); path = Tcl_FSJoinToPath(directory, 1, &encodingObj); Tcl_IncrRefCount(path); if ((0 == Tcl_FSStat(path, &stat)) && S_ISDIR(stat.st_mode)) { Tcl_ListObjAppendElement(NULL, searchPath, path); } Tcl_DecrRefCount(path); } Tcl_DecrRefCount(libPath); Tcl_DecrRefCount(encodingObj); *encodingPtr = libraryPath.encoding; if (*encodingPtr) { ((Encoding *)(*encodingPtr))->refCount++; } bytes = Tcl_GetStringFromObj(searchPath, &numBytes); *lengthPtr = numBytes; *valuePtr = ckalloc((unsigned int) numBytes + 1); memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t) numBytes + 1); Tcl_DecrRefCount(searchPath); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclEnv.c.
|
| | | | | | | | | > > > > > | | | | | | | | | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | /* * tclEnv.c -- * * Tcl support for environment variables, including a setenv function. * This file contains the generic portion of the environment module. It * is primarily responsible for keeping the "env" arrays in sync with the * system environment variables. * * 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.22.2.3 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.h" TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ */ static int cacheSize = 0; /* Number of env strings in environCache. */ static char **environCache = NULL; /* Array containing all of the environment * strings that Tcl has allocated. */ #ifndef USE_PUTENV static char **ourEnviron = NULL;/* Cache of the array that we allocate. * We need to track this in case another * subsystem swaps around the environ array * like we do. */ static int environSize = 0; /* Non-zero means that the environ array was * malloced and has this many total entries * allocated to it (not all may be in use at * once). Zero means that the environment * array is in its original static state. */ #endif /* * For MacOS X */ #if defined(__APPLE__) && defined(__DYNAMIC__) #include <crt_externs.h> char **environ = NULL; #endif /* * Declarations for local functions 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)); #if defined (__CYGWIN__) && defined(__WIN32__) static void TclCygwinPutenv _ANSI_ARGS_((CONST char *string)); #endif /* *---------------------------------------------------------------------- * * TclSetupEnv -- * * This function is invoked for an interpreter to make environment * variables accessible from that interpreter via the "env" associative * array. * * Results: * None. * * Side effects: * The interpreter is added to a list of interpreters managed by us, so * that its view of envariables can be kept consistent with the view in * other interpreters. If this is the first call to TclSetupEnv, then * additional initialization happens, such as copying the environment to * dynamically-allocated space for ease of management. * *---------------------------------------------------------------------- */ void TclSetupEnv(interp) Tcl_Interp *interp; /* Interpreter whose "env" array is to be |
︙ | ︙ | |||
93 94 95 96 97 98 99 | * For MacOS X */ #if defined(__APPLE__) && defined(__DYNAMIC__) environ = *_NSGetEnviron(); #endif /* | | | | | | | | | | | | | | | | | | | | | | | | > > > > > | | | | | | | | | | | | | | < | | | | | | | > | > > | | | | < > | | | | | < | | | | | | | | | | | < | | | | | < | | | | | | | > > > > > > > > > > | | | | > | > > | 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 | * For MacOS X */ #if defined(__APPLE__) && defined(__DYNAMIC__) environ = *_NSGetEnviron(); #endif /* * Synchronize the values in the environ array with the contents of the * Tcl "env" variable. To do this: * 1) Remove the trace that fires when the "env" var is unset. * 2) Unset the "env" variable. * 3) If there are no environ variables, create an empty "env" array. * Otherwise populate the array with current values. * 4) Add a trace that synchronizes the "env" array. */ Tcl_UntraceVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, (ClientData) NULL); Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); if (environ[0] == NULL) { Tcl_Obj *varNamePtr; varNamePtr = Tcl_NewStringObj("env", -1); Tcl_IncrRefCount(varNamePtr); TclArraySet(interp, varNamePtr, NULL); Tcl_DecrRefCount(varNamePtr); } else { Tcl_MutexLock(&envMutex); for (i = 0; environ[i] != NULL; i++) { p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString); p2 = strchr(p1, '='); if (p2 == NULL) { /* * This condition seem to happen occasionally under some * versions of Solaris; ignore the entry. */ continue; } p2++; p2[-1] = '\0'; Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY); Tcl_DStringFree(&envString); } Tcl_MutexUnlock(&envMutex); } Tcl_TraceVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, (ClientData) NULL); } /* *---------------------------------------------------------------------- * * TclSetEnv -- * * Set an environment variable, replacing an existing value or creating a * new variable if there doesn't exist a variable by the given name. * This function is intended to be a stand-in for the UNIX "setenv" * function so that applications using that function will interface * properly to Tcl. To make it a stand-in, the Makefile must define * "TclSetEnv" to "setenv". * * Results: * None. * * Side effects: * The environ array gets updated. * *---------------------------------------------------------------------- */ void TclSetEnv(name, value) CONST char *name; /* Name of variable whose value is to be set * (UTF-8). */ CONST char *value; /* New value for variable (UTF-8). */ { Tcl_DString envString; int index, length, nameLength; char *p, *oldValue; CONST char *p2; /* * Figure out where the entry is going to go. If the name doesn't already * exist, enlarge the array if necessary to make room. If the name exists, * free its old entry. */ Tcl_MutexLock(&envMutex); index = TclpFindVariable(name, &length); if (index == -1) { #ifndef USE_PUTENV /* * We need to handle the case where the environment may be changed * outside our control. environSize is only valid if the current * environment is the one we allocated. [Bug 979640] */ if ((ourEnviron != environ) || ((length + 2) > environSize)) { char **newEnviron; newEnviron = (char **) ckalloc((unsigned) ((length + 5) * sizeof(char *))); memcpy((VOID *) newEnviron, (VOID *) environ, length*sizeof(char *)); if ((environSize != 0) && (ourEnviron != NULL)) { ckfree((char *) ourEnviron); } environ = ourEnviron = newEnviron; environSize = length + 5; #if defined(__APPLE__) && defined(__DYNAMIC__) { char ***e = _NSGetEnviron(); *e = environ; } #endif /* __APPLE__ && __DYNAMIC__ */ } index = length; environ[index + 1] = NULL; #endif /* USE_PUTENV */ oldValue = NULL; nameLength = strlen(name); } else { CONST char *env; /* * Compare the new value to the existing value. If they're the same * then quit immediately (e.g. don't rewrite the value or propagate it * to other interpreters). Otherwise, when there are N interpreters * there will be N! propagations of the same value among the * interpreters. */ env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString); if (strcmp(value, (env + length + 1)) == 0) { Tcl_DStringFree(&envString); Tcl_MutexUnlock(&envMutex); return; } Tcl_DStringFree(&envString); oldValue = environ[index]; nameLength = length; } /* * Create a new entry. Build a complete UTF string that contains a * "name=value" pattern. Then convert the string to the native encoding, * and set the environ array value. */ p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2)); strcpy(p, name); p[nameLength] = '='; strcpy(p+nameLength+1, value); p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString); /* * Copy the native string to heap memory. */ p = (char *) ckrealloc(p, (unsigned) (strlen(p2) + 1)); strcpy(p, p2); Tcl_DStringFree(&envString); #ifdef USE_PUTENV /* * Update the system environment. */ putenv(p); index = TclpFindVariable(name, &length); #else environ[index] = p; #endif /* * Watch out for versions of putenv that copy the string (e.g. VC++). In * this case we need to free the string immediately. Otherwise update the * string in the cache. */ if ((index != -1) && (environ[index] == p)) { ReplaceString(oldValue, p); #ifdef HAVE_PUTENV_THAT_COPIES } else { /* * This putenv() copies instead of taking ownership. */ ckfree(p); #endif } Tcl_MutexUnlock(&envMutex); if (!strcmp(name, "HOME")) { /* * If the user's home directory has changed, we must invalidate the * filesystem cache, because '~' expansions will now be incorrect. */ Tcl_FSMountsChanged(NULL); } } /* *---------------------------------------------------------------------- * * Tcl_PutEnv -- * * Set an environment variable. Similar to setenv except that the * information is passed in a single string of the form NAME=value, * rather than as separate name strings. This function is intended to be * a stand-in for the UNIX "putenv" function so that applications using * that function will interface properly to Tcl. To make it a stand-in, * the Makefile will define "Tcl_PutEnv" to "putenv". * * Results: * None. * * Side effects: * The environ array gets updated, as do all of the interpreters that we * manage. * *---------------------------------------------------------------------- */ int Tcl_PutEnv(assignment) CONST char *assignment; /* Info about environment variable in the form * NAME=value. (native) */ { Tcl_DString nameString; CONST char *name; char *value; if (assignment == NULL) { return 0; } /* * First convert the native string to UTF. Then separate the string into * name and value parts, and call TclSetEnv to do all of the real work. */ name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString); value = strchr(name, '='); if ((value != NULL) && (value != name)) { value[0] = '\0'; TclSetEnv(name, value+1); } Tcl_DStringFree(&nameString); return 0; } /* *---------------------------------------------------------------------- * * TclUnsetEnv -- * * Remove an environment variable, updating the "env" arrays in all * interpreters managed by us. This function is intended to replace the * UNIX "unsetenv" function (but to do this the Makefile must be modified * to redefine "TclUnsetEnv" to "unsetenv". * * Results: * None. * * Side effects: * Interpreters are updated, as is environ. * *---------------------------------------------------------------------- */ void TclUnsetEnv(name) CONST char *name; /* Name of variable to remove (UTF-8). */ { char *oldValue; int length; int index; #ifdef USE_PUTENV_FOR_UNSET Tcl_DString envString; char *string; #else char **envPtr; #endif Tcl_MutexLock(&envMutex); index = TclpFindVariable(name, &length); /* * First make sure that the environment variable exists to avoid doing * needless work and to avoid recursion on the unset. */ if (index == -1) { Tcl_MutexUnlock(&envMutex); return; } /* * Remember the old value so we can free it if Tcl created the string. */ oldValue = environ[index]; /* * Update the system environment. This must be done before we update the * interpreters or we will recurse. */ #ifdef USE_PUTENV_FOR_UNSET /* * For those platforms that support putenv to unset, Linux indicates * that no = should be included, and Windows requires it. */ #ifdef WIN32 string = ckalloc((unsigned int) length+2); memcpy((VOID *) string, (VOID *) name, (size_t) length); string[length] = '='; string[length+1] = '\0'; #else string = ckalloc((unsigned int) length+1); memcpy((VOID *) string, (VOID *) name, (size_t) length); string[length] = '\0'; #endif Tcl_UtfToExternalDString(NULL, string, -1, &envString); string = ckrealloc(string, (unsigned) (Tcl_DStringLength(&envString)+1)); strcpy(string, Tcl_DStringValue(&envString)); Tcl_DStringFree(&envString); putenv(string); /* * Watch out for versions of putenv that copy the string (e.g. VC++). In * this case we need to free the string immediately. Otherwise update the * string in the cache. */ if (environ[index] == string) { ReplaceString(oldValue, string); #ifdef HAVE_PUTENV_THAT_COPIES } else { /* * This putenv() copies instead of taking ownership. */ ckfree(string); #endif } #else for (envPtr = environ+index+1; ; envPtr++) { envPtr[-1] = *envPtr; if (*envPtr == NULL) { |
︙ | ︙ | |||
452 453 454 455 456 457 458 | * * TclGetEnv -- * * Retrieve the value of an environment variable. * * Results: * The result is a pointer to a string specifying the value of the | | | | | | | | | 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 | * * TclGetEnv -- * * Retrieve the value of an environment variable. * * Results: * The result is a pointer to a string specifying the value of the * environment variable, or NULL if that environment variable does not * exist. Storage for the result string is allocated in valuePtr; the * caller must call Tcl_DStringFree() when the result is no longer * needed. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * TclGetEnv(name, valuePtr) CONST char *name; /* Name of environment variable to find * (UTF-8). */ Tcl_DString *valuePtr; /* Uninitialized or free DString in which the * value of the environment variable is * stored. */ { int length, index; CONST char *result; Tcl_MutexLock(&envMutex); index = TclpFindVariable(name, &length); result = NULL; if (index != -1) { Tcl_DString envStr; result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr); result += length; if (*result == '=') { result++; Tcl_DStringInit(valuePtr); Tcl_DStringAppend(valuePtr, result, -1); result = Tcl_DStringValue(valuePtr); |
︙ | ︙ | |||
501 502 503 504 505 506 507 | } /* *---------------------------------------------------------------------- * * EnvTraceProc -- * | | | | | | < | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * EnvTraceProc -- * * This function is invoked whenever an environment variable is read, * modified or deleted. It propagates the change to the global "environ" * array. * * Results: * Always returns NULL to indicate success. * * Side effects: * Environment variable changes get propagated. If the whole "env" array * is deleted, then we stop managing things for this interpreter (usually * this happens because the whole interpreter is being deleted). * *---------------------------------------------------------------------- */ /* 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. */ if (flags & TCL_TRACE_ARRAY) { TclSetupEnv(interp); return NULL; } /* * If name2 is NULL, then return and do nothing. */ if (name2 == NULL) { return NULL; } /* * If a value is being set, call TclSetEnv to do all of the work. */ if (flags & TCL_TRACE_WRITES) { CONST char *value; value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY); TclSetEnv(name2, value); } /* * If a value is being read, call TclGetEnv to do all of the work. */ |
︙ | ︙ | |||
587 588 589 590 591 592 593 | } /* *---------------------------------------------------------------------- * * ReplaceString -- * | | | | | | | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * ReplaceString -- * * Replace one string with another in the environment variable cache. * The cache keeps track of all of the environment variables that Tcl has * modified so they can be freed later. * * Results: * None. * * Side effects: * May free the old string. * *---------------------------------------------------------------------- */ static void ReplaceString(oldStr, newStr) CONST char *oldStr; /* Old environment string. */ char *newStr; /* New environment string. */ { int i; char **newCache; /* * Check to see if the old value was allocated by Tcl. If so, it needs to * be deallocated to avoid memory leaks. Note that this algorithm is O(n), * not O(1). This will result in n-squared behavior if lots of environment * changes are being made. */ for (i = 0; i < cacheSize; i++) { if ((environCache[i] == oldStr) || (environCache[i] == NULL)) { break; } } if (i < cacheSize) { /* * Replace or delete the old value. */ if (environCache[i]) { ckfree(environCache[i]); } if (newStr) { environCache[i] = newStr; } else { for (; i < cacheSize-1; i++) { environCache[i] = environCache[i+1]; } environCache[cacheSize-1] = NULL; } } else { int allocatedSize = (cacheSize + 5) * sizeof(char *); /* * We need to grow the cache in order to hold the new string. */ newCache = (char **) ckalloc((unsigned) allocatedSize); (VOID *) memset(newCache, (int) 0, (size_t) allocatedSize); if (environCache) { memcpy((VOID *) newCache, (VOID *) environCache, (size_t) (cacheSize * sizeof(char*))); ckfree((char *) environCache); } environCache = newCache; environCache[cacheSize] = newStr; environCache[cacheSize+1] = NULL; cacheSize += 5; } } /* *---------------------------------------------------------------------- * * TclFinalizeEnvironment -- * * This function releases any storage allocated by this module that isn't * still in use by the global environment. Any strings that are still in * the environment will be leaked. * * Results: * None. * * Side effects: * May deallocate storage. * *---------------------------------------------------------------------- */ void TclFinalizeEnvironment() { /* * For now we just deallocate the cache array and none of the environment * strings. This may leak more memory that strictly necessary, since some * of the strings may no longer be in the environment. However, * determining which ones are ok to delete is n-squared, and is pretty * unlikely, so we don't bother. */ if (environCache) { ckfree((char *) environCache); environCache = NULL; cacheSize = 0; #ifndef USE_PUTENV environSize = 0; #endif } } #if defined(__CYGWIN__) && defined(__WIN32__) #include <windows.h> |
︙ | ︙ | |||
715 716 717 718 719 720 721 | static void TclCygwinPutenv(str) const char *str; { char *name, *value; | > | | > > | | | < > > | | | > | > > | > | > | | > > | | | | > | > > | | | | | | > > > > > > > > | 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 | static void TclCygwinPutenv(str) const char *str; { char *name, *value; /* * Get the name and value, so that we can change the environment variable * for Windows. */ name = (char *) alloca(strlen(str) + 1); strcpy(name, str); for (value=name ; *value!='=' && *value!='\0' ; ++value) { /* Empty body */ } if (*value == '\0') { /* Can't happen. */ return; } *value = '\0'; ++value; if (*value == '\0') { value = NULL; } /* * Set the cygwin environment variable. */ #undef putenv if (value == NULL) { unsetenv(name); } else { putenv(str); } /* * Before changing the environment variable in Windows, if this is PATH, * we need to convert the value back to a Windows style path. * * FIXME: The calling program may know it is running under windows, and * may have set the path to a Windows path, or, worse, appended or * prepended a Windows path to PATH. */ if (strcmp(name, "PATH") != 0) { /* * If this is Path, eliminate any PATH variable, to prevent any * confusion. */ if (strcmp(name, "Path") == 0) { SetEnvironmentVariable("PATH", (char *) NULL); unsetenv("PATH"); } SetEnvironmentVariable(name, value); } else { char *buf; /* * Eliminate any Path variable, to prevent any confusion. */ SetEnvironmentVariable("Path", (char *) NULL); unsetenv("Path"); if (value == NULL) { buf = NULL; } else { int size; size = cygwin_posix_to_win32_path_list_buf_size(value); buf = (char *) alloca(size + 1); cygwin_posix_to_win32_path_list(value, buf); } SetEnvironmentVariable(name, buf); } } #endif /* __CYGWIN__ && __WIN32__ */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclEvent.c.
1 2 3 4 | /* * tclEvent.c -- * * This file implements some general event related interfaces including | | | | | | | | | < | | | | | | | | | 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 | /* * 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. * Copyright (c) 2004 by Zoran Vasiljevic. * * 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.54.2.8 2005/08/25 15:46:30 dgp Exp $ */ #include "tclInt.h" /* * The data structure below is used to report background errors. One such * structure is allocated for each error; it holds information about the * interpreter and the error until an idle handler command can be invoked. */ typedef struct BgError { Tcl_Obj *errorMsg; /* Copy of the error message (the interp's * result when the error occurred). */ Tcl_Obj *returnOpts; /* Active return options when the error * occurred */ struct BgError *nextPtr; /* Next in list of all pending error reports * for this interpreter, or NULL for end of * list. */ } BgError; /* * One of the structures below is associated with the "tclBgError" assoc data * for each interpreter. It keeps track of the head and tail of the list of * pending background errors for the interpreter. */ typedef struct ErrAssocData { Tcl_Interp *interp; /* Interpreter in which error occurred. */ Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */ BgError *firstBgPtr; /* First in list of all background errors * waiting to be processed for this |
︙ | ︙ | |||
55 56 57 58 59 60 61 | * For each exit handler created with a call to Tcl_CreateExitHandler * there is a structure of the following type: */ typedef struct ExitHandler { Tcl_ExitProc *proc; /* Procedure to call when process exits. */ ClientData clientData; /* One word of information to pass to proc. */ | | | | | < | | | | | | | | | | | < | | < | 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 | * For each exit handler created with a call to Tcl_CreateExitHandler * there is a structure of the following type: */ typedef struct ExitHandler { Tcl_ExitProc *proc; /* Procedure to call when process exits. */ ClientData clientData; /* One word of information to pass to proc. */ struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this * application, or NULL for end of list. */ } ExitHandler; /* * There is both per-process and per-thread exit handlers. The first list is * controlled by a mutex. The other is in thread local storage. */ static ExitHandler *firstExitPtr = NULL; /* First in list of all exit handlers for * application. */ TCL_DECLARE_MUTEX(exitMutex) /* * This variable is set to 1 when Tcl_Finalize is called, and at the end of * its work, it is reset to 0. The variable is checked by TclInExit() to allow * different behavior for exit-time processing, e.g. in closing of files and * pipes. */ static int inFinalize = 0; static int subsystemsInitialized = 0; /* * This variable contains the application wide exit handler. It will be * called by Tcl_Exit instead of the C-runtime exit if this variable is set * to a non-NULL value. */ static Tcl_ExitProc *appExitPtr = NULL; typedef struct ThreadSpecificData { ExitHandler *firstExitPtr; /* First in list of all exit handlers for this * thread. */ int inExit; /* True when this thread is exiting. This is * used as a hack to decide to close the * standard channels. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #ifdef TCL_THREADS typedef struct { Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ } ThreadClientData; static Tcl_ThreadCreateType NewThreadProc _ANSI_ARGS_(( ClientData clientData)); #endif /* * Prototypes for procedures referenced only in this file: */ static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); 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 commands * that are invoked in "background" (e.g. from event or timer bindings). * * Results: * None. * * Side effects: * A handler command is invoked later as an idle handler to process the * error, passing it the interp result and return options. * *---------------------------------------------------------------------- */ void Tcl_BackgroundError(interp) Tcl_Interp *interp; /* Interpreter in which an error has |
︙ | ︙ | |||
171 172 173 174 175 176 177 | } /* *---------------------------------------------------------------------- * * HandleBgErrors -- * | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * HandleBgErrors -- * * This procedure is invoked as an idle handler to process all of the * accumulated background errors. * * Results: * None. * * Side effects: * Depends on what actions the handler command takes for the errors. * *---------------------------------------------------------------------- */ static void HandleBgErrors(clientData) ClientData clientData; /* Pointer to ErrAssocData structure. */ { ErrAssocData *assocPtr = (ErrAssocData *) clientData; Tcl_Interp *interp = assocPtr->interp; BgError *errPtr; /* * Not bothering to save/restore the interp state. Assume that any code * that has interp state it needs to keep will make its own * Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent() * that could lead us here. */ Tcl_Preserve((ClientData) assocPtr); Tcl_Preserve((ClientData) interp); while (assocPtr->firstBgPtr != NULL) { int code, prefixObjc; Tcl_Obj **prefixObjv, **tempObjv; errPtr = assocPtr->firstBgPtr; Tcl_IncrRefCount(assocPtr->cmdPrefix); Tcl_ListObjGetElements(NULL, assocPtr->cmdPrefix, &prefixObjc, &prefixObjv); tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; tempObjv[prefixObjc+1] = errPtr->returnOpts; Tcl_AllowExceptions(interp); code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL); |
︙ | ︙ | |||
257 258 259 260 261 262 263 | "error in background error handler:\n", -1); if (valuePtr) { Tcl_WriteObj(errChannel, valuePtr); } else { Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); } Tcl_WriteChars(errChannel, "\n", 1); | | | | | < | | | | | | | | | > | > | | | | | | < | | | > | | | | < | | | | | 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 | "error in background error handler:\n", -1); if (valuePtr) { Tcl_WriteObj(errChannel, valuePtr); } else { Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); } Tcl_WriteChars(errChannel, "\n", 1); Tcl_Flush(errChannel); } } } assocPtr->lastBgPtr = NULL; Tcl_Release((ClientData) interp); Tcl_Release((ClientData) assocPtr); } /* *---------------------------------------------------------------------- * * TclDefaultBgErrorHandlerObjCmd -- * * This procedure is invoked to process the "::tcl::Bgerror" Tcl command. * It is the default handler command registered with [interp bgerror] for * the sake of compatibility with older Tcl releases. * * Results: * A standard Tcl object result. * * Side effects: * Depends on what actions the "bgerror" command takes for the errors. * *---------------------------------------------------------------------- */ int TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Obj *keyPtr, *valuePtr; Tcl_Obj *tempObjv[2]; int code; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "msg options"); return TCL_ERROR; } /* * Restore important state variables to what they were at the time the * error occurred. * * Need to set the variables, not the interp fields, because Tcl_EvalObjv * calls Tcl_ResetResult which would destroy anything we write to the * interp fields. */ keyPtr = Tcl_NewStringObj("-errorcode", -1); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); if (valuePtr) { Tcl_SetVar2Ex(interp, "errorCode", NULL, valuePtr, TCL_GLOBAL_ONLY); } keyPtr = Tcl_NewStringObj("-errorinfo", -1); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); if (valuePtr) { Tcl_SetVar2Ex(interp, "errorInfo", NULL, valuePtr, TCL_GLOBAL_ONLY); } /* * Create and invoke the bgerror command. */ tempObjv[0] = Tcl_NewStringObj("bgerror", -1); Tcl_IncrRefCount(tempObjv[0]); tempObjv[1] = objv[1]; Tcl_AllowExceptions(interp); code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL); if (code == TCL_ERROR) { /* * If the interpreter is safe, we look for a hidden command named * "bgerror" and call that with the error information. Otherwise, * simply ignore the error. The rationale is that this could be an * error caused by a malicious applet trying to cause an infinite * barrage of error messages. The hidden "bgerror" command can be used * by a security policy to interpose on such attacks and e.g. kill the * applet after a few attempts. */ if (Tcl_IsSafe(interp)) { Tcl_ResetResult(interp); TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN); } else { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel != (Tcl_Channel) NULL) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); if (Tcl_FindCommand(interp, "bgerror", NULL, TCL_GLOBAL_ONLY) == NULL) { if (valuePtr) { Tcl_WriteObj(errChannel, valuePtr); Tcl_WriteChars(errChannel, "\n", -1); } } else { Tcl_WriteChars(errChannel, "bgerror failed to handle background error.\n", -1); Tcl_WriteChars(errChannel, " Original error: ", -1); Tcl_WriteObj(errChannel, objv[1]); Tcl_WriteChars(errChannel, "\n", -1); Tcl_WriteChars(errChannel, " Error in bgerror: ", -1); Tcl_WriteObj(errChannel, resultPtr); Tcl_WriteChars(errChannel, "\n", -1); } Tcl_DecrRefCount(resultPtr); Tcl_Flush(errChannel); } } code = TCL_OK; } Tcl_DecrRefCount(tempObjv[0]); Tcl_ResetResult(interp); return code; } /* *---------------------------------------------------------------------- * * TclSetBgErrorHandler -- * * This procedure sets the command prefix to be used to handle background * errors in interp. * * Results: * None. * * Side effects: * Error handler is registered. * |
︙ | ︙ | |||
431 432 433 434 435 436 437 | } /* *---------------------------------------------------------------------- * * TclGetBgErrorHandler -- * | | | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 | } /* *---------------------------------------------------------------------- * * TclGetBgErrorHandler -- * * This procedure retrieves the command prefix currently used to handle * background errors in interp. * * Results: * A (Tcl_Obj *) to a list of words (command prefix). * * Side effects: * None. * |
︙ | ︙ | |||
463 464 465 466 467 468 469 | } /* *---------------------------------------------------------------------- * * BgErrorDeleteProc -- * | | | | < | | | 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 | } /* *---------------------------------------------------------------------- * * BgErrorDeleteProc -- * * This procedure is associated with the "tclBgError" assoc data for an * interpreter; it is invoked when the interpreter is deleted in order to * free the information assoicated with any pending error reports. * * Results: * None. * * Side effects: * Background error information is freed: if there were any pending error * reports, they are cancelled. * *---------------------------------------------------------------------- */ static void BgErrorDeleteProc(clientData, interp) ClientData clientData; /* Pointer to ErrAssocData structure. */ |
︙ | ︙ | |||
510 511 512 513 514 515 516 | * Arrange for a given procedure to be invoked just before the * application exits. * * Results: * None. * * Side effects: | | | | 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 | * Arrange for a given procedure to be invoked just before the * application exits. * * Results: * None. * * Side effects: * Proc will be invoked with clientData as argument when the application * exits. * *---------------------------------------------------------------------- */ void Tcl_CreateExitHandler(proc, clientData) Tcl_ExitProc *proc; /* Procedure to invoke. */ |
︙ | ︙ | |||
537 538 539 540 541 542 543 | } /* *---------------------------------------------------------------------- * * Tcl_DeleteExitHandler -- * | | | | | < | 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 | } /* *---------------------------------------------------------------------- * * Tcl_DeleteExitHandler -- * * This procedure cancels an existing exit handler matching proc and * clientData, if such a handler exits. * * Results: * None. * * Side effects: * If there is an exit handler corresponding to proc and clientData then * it is cancelled; if no such handler exists then nothing happens. * *---------------------------------------------------------------------- */ void Tcl_DeleteExitHandler(proc, clientData) Tcl_ExitProc *proc; /* Procedure that was previously registered. */ |
︙ | ︙ | |||
581 582 583 584 585 586 587 | } /* *---------------------------------------------------------------------- * * Tcl_CreateThreadExitHandler -- * | | | | | | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 | } /* *---------------------------------------------------------------------- * * Tcl_CreateThreadExitHandler -- * * Arrange for a given procedure to be invoked just before the current * thread exits. * * Results: * None. * * Side effects: * Proc will be invoked with clientData as argument when the application * exits. * *---------------------------------------------------------------------- */ void Tcl_CreateThreadExitHandler(proc, clientData) Tcl_ExitProc *proc; /* Procedure to invoke. */ |
︙ | ︙ | |||
614 615 616 617 618 619 620 | } /* *---------------------------------------------------------------------- * * Tcl_DeleteThreadExitHandler -- * | | | | | < | 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 | } /* *---------------------------------------------------------------------- * * Tcl_DeleteThreadExitHandler -- * * This procedure cancels an existing exit handler matching proc and * clientData, if such a handler exits. * * Results: * None. * * Side effects: * If there is an exit handler corresponding to proc and clientData then * it is cancelled; if no such handler exists then nothing happens. * *---------------------------------------------------------------------- */ void Tcl_DeleteThreadExitHandler(proc, clientData) Tcl_ExitProc *proc; /* Procedure that was previously registered. */ |
︙ | ︙ | |||
656 657 658 659 660 661 662 | } /* *---------------------------------------------------------------------- * * Tcl_SetExitProc -- * | | | | < | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_SetExitProc -- * * This procedure sets the application wide exit handler that will be * called by Tcl_Exit in place of the C-runtime exit. If the application * wide exit handler is NULL, the C-runtime exit will be used instead. * * Results: * The previously set application wide exit handler. * * Side effects: * Sets the application wide exit handler to the specified value. * *---------------------------------------------------------------------- */ Tcl_ExitProc * Tcl_SetExitProc(proc) Tcl_ExitProc *proc; /* new exit handler for app or NULL */ { Tcl_ExitProc *prevExitProc; /* * Swap the old exit proc for the new one, saving the old one for our * return value. */ Tcl_MutexLock(&exitMutex); prevExitProc = appExitPtr; appExitPtr = proc; Tcl_MutexUnlock(&exitMutex); |
︙ | ︙ | |||
700 701 702 703 704 705 706 | * * This procedure is called to terminate the application. * * Results: * None. * * Side effects: | | < | | | > | | | < | | | | | | | | | > > > | | | > > | > | | > | | | | < | 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 | * * This procedure is called to terminate the application. * * Results: * None. * * Side effects: * All existing exit handlers are invoked, then the application ends. * *---------------------------------------------------------------------- */ void Tcl_Exit(status) int status; /* Exit status for application; typically * 0 for normal return, 1 for error return. */ { Tcl_ExitProc *currentAppExitPtr; Tcl_MutexLock(&exitMutex); currentAppExitPtr = appExitPtr; Tcl_MutexUnlock(&exitMutex); if (currentAppExitPtr) { /* * Warning: this code SHOULD NOT return, as there is code that depends * on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone * returns, so critical is this dependcy. */ currentAppExitPtr((ClientData) status); Tcl_Panic("AppExitProc returned unexpectedly"); } else { /* use default handling */ Tcl_Finalize(); TclpExit(status); Tcl_Panic("OS exit failed!"); } } /* *------------------------------------------------------------------------- * * TclInitSubsystems -- * * Initialize various subsytems in Tcl. This should be called the first * time an interp is created, or before any of the subsystems are used. * This function ensures an order for the initialization of subsystems: * * 1. that cannot be initialized in lazy order because they are mutually * dependent. * * 2. so that they can be finalized in a known order w/o causing the * subsequent re-initialization of a subsystem in the act of shutting * down another. * * Results: * None. * * Side effects: * Varied, see the respective initialization routines. * *------------------------------------------------------------------------- */ void TclInitSubsystems() { if (inFinalize != 0) { Tcl_Panic("TclInitSubsystems called while finalizing"); } if (subsystemsInitialized == 0) { /* * Double check inside the mutex. There are definitly calls back into * this routine from some of the procedures below. */ TclpInitLock(); if (subsystemsInitialized == 0) { /* * Have to set this bit here to avoid deadlock with the routines * below us that call into TclInitSubsystems. */ subsystemsInitialized = 1; /* * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. */ TclInitThreadStorage(); /* Creates master hash table for * thread local storage */ #if USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif #ifdef TCL_MEM_DEBUG TclInitDbCkalloc(); /* Process wide mutex init */ #endif TclpInitPlatform(); /* Creates signal handler(s) */ TclInitDoubleConversion(); /* Initializes constants for * converting to/from double. */ TclInitObjSubsystem(); /* Register obj types, create * mutexes. */ TclInitIOSubsystem(); /* Inits a tsd key (noop). */ TclInitEncodingSubsystem(); /* Process wide encoding init. */ TclpSetInterfaces(); TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ } TclpInitUnlock(); } TclInitNotifier(); } /* *---------------------------------------------------------------------- * * Tcl_Finalize -- * * Shut down Tcl. First calls registered exit handlers, then carefully * shuts down various subsystems. Called by Tcl_Exit or when the Tcl * shared library is being unloaded. * * Results: * None. * * Side effects: * Varied, see the respective finalization routines. * |
︙ | ︙ | |||
836 837 838 839 840 841 842 | * Invoke exit handlers first. */ Tcl_MutexLock(&exitMutex); inFinalize = 1; for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { /* | | | < | | | | | | | | | < | > | | > | > > > > > > > > > > > > | | | < > | | | | < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | < < | | > > > > > > > | 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 | * Invoke exit handlers first. */ Tcl_MutexLock(&exitMutex); inFinalize = 1; for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { /* * Be careful to remove the handler from the list before invoking its * callback. This protects us against double-freeing if the callback * should call Tcl_DeleteExitHandler on itself. */ firstExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); (*exitPtr->proc)(exitPtr->clientData); ckfree((char *) exitPtr); Tcl_MutexLock(&exitMutex); } firstExitPtr = NULL; Tcl_MutexUnlock(&exitMutex); TclpInitLock(); if (subsystemsInitialized != 0) { subsystemsInitialized = 0; /* * Ensure the thread-specific data is initialised as it is used in * Tcl_FinalizeThread() */ (void) TCL_TSD_INIT(&dataKey); /* * Clean up after the current thread now, after exit handlers. In * particular, the testexithandler command sets up something that * writes to standard output, which gets closed. Note that there is * no thread-local storage after this call. */ Tcl_FinalizeThread(); /* * Now finalize the Tcl execution environment. Note that this must be * done after the exit handlers, because there are order dependencies. */ TclFinalizeCompilation(); TclFinalizeExecution(); TclFinalizeEnvironment(); /* * Finalizing the filesystem must come after anything which might * conceivably interact with the 'Tcl_FS' API. */ TclFinalizeFilesystem(); /* * Undo all Tcl_ObjType registrations, and reset the master list * of free Tcl_Obj's. After this returns, no more Tcl_Obj's should * be allocated or freed. * * Note in particular that TclFinalizeObjects() must follow * TclFinalizeFilesystem() because TclFinalizeFilesystem free's * the Tcl_Obj that holds the path of the current working directory. */ TclFinalizeObjects(); /* * We must be sure the encoding finalization doesn't need to examine * the filesystem in any way. Since it only needs to clean up * internal data structures, this is fine. */ TclFinalizeEncodingSubsystem(); Tcl_SetPanicProc(NULL); /* * Repeat finalization of the thread local storage once more. Although * this step is already done by the Tcl_FinalizeThread call above, * series of events happening afterwards may re-initialize TSD slots. * Those need to be finalized again, otherwise we're leaking memory * chunks. Very important to note is that things happening afterwards * should not reference anything which may re-initialize TSD's. This * includes freeing Tcl_Objs's, among other things. * * This fixes the Tcl Bug #990552. */ TclFinalizeThreadData(); /* * Now we can free constants for conversions to/from double. */ TclFinalizeDoubleConversion(); /* * There have been several bugs in the past that cause exit handlers * to be established during Tcl_Finalize processing. Such exit * handlers leave malloc'ed memory, and Tcl_FinalizeThreadAlloc or * Tcl_FinalizeMemorySubsystem will result in a corrupted heap. The * result can be a mysterious crash on process exit. Check here that * nobody's done this. */ if (firstExitPtr != NULL) { Tcl_Panic("exit handlers were created during Tcl_Finalize"); } TclFinalizePreserve(); /* * Free synchronization objects. There really should only be one * thread alive at this moment. */ TclFinalizeSynchronization(); #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) TclFinalizeThreadAlloc(); #endif /* * We defer unloading of packages until very late to avoid memory * access issues. Both exit callbacks and synchronization variables * may be stored in packages. * * Note that TclFinalizeLoad unloads packages in the reverse of the * order they were loaded in (i.e. last to be loaded is the first to * be unloaded). This can be important for correct unloading when * dependencies exist. * * Once load has been finalized, we will have deleted any temporary * copies of shared libraries and can therefore reset the filesystem * to its original state. */ TclFinalizeLoad(); TclResetFilesystem(); /* * At this point, there should no longer be any ckalloc'ed memory. */ TclFinalizeMemorySubsystem(); inFinalize = 0; } TclFinalizeLock(); } /* *---------------------------------------------------------------------- * * Tcl_FinalizeThread -- * * Runs the exit handlers to allow Tcl to clean up its state about a * particular thread. * * Results: * None. * * Side effects: * Varied, see the respective finalization routines. * *---------------------------------------------------------------------- */ void Tcl_FinalizeThread() { ExitHandler *exitPtr; /* * We use TclThreadDataKeyGet here, rather than Tcl_GetThreadData, * because we don't want to initialize the data block if it hasn't * been initialized already. */ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); if (tsdPtr != NULL) { tsdPtr->inExit = 1; for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; |
︙ | ︙ | |||
993 994 995 996 997 998 999 | TclFinalizeNotifier(); TclFinalizeAsync(); } /* * Blow away all thread local storage blocks. * | | | | | | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 | TclFinalizeNotifier(); TclFinalizeAsync(); } /* * Blow away all thread local storage blocks. * * Note that Tcl API allows creation of threads which do not use any Tcl * interp or other Tcl subsytems. Those threads might, however, use thread * local storage, so we must unconditionally finalize it. * * Fix [Bug #571002] */ TclFinalizeThreadData(); } /* *---------------------------------------------------------------------- * * TclInExit -- * |
︙ | ︙ | |||
1058 1059 1060 1061 1062 1063 1064 | } /* *---------------------------------------------------------------------- * * Tcl_VwaitObjCmd -- * | | | | 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 | } /* *---------------------------------------------------------------------- * * Tcl_VwaitObjCmd -- * * This procedure is invoked to process the "vwait" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
1082 1083 1084 1085 1086 1087 1088 | int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int done, foundEvent; char *nameString; if (objc != 2) { | | > > | | | 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 | int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int done, foundEvent; char *nameString; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } nameString = Tcl_GetString(objv[1]); if (Tcl_TraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, (ClientData) &done) != TCL_OK) { return TCL_ERROR; }; done = 0; foundEvent = 1; while (!done && foundEvent) { foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); if (Tcl_LimitExceeded(interp)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "limit exceeded", NULL); return TCL_ERROR; } } Tcl_UntraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, (ClientData) &done); /* * Clear out the interpreter's result, since it may have been set by event * handlers. */ Tcl_ResetResult(interp); if (!foundEvent) { Tcl_AppendResult(interp, "can't wait for variable \"", nameString, "\": would wait forever", (char *) NULL); return TCL_ERROR; |
︙ | ︙ | |||
1137 1138 1139 1140 1141 1142 1143 | } /* *---------------------------------------------------------------------- * * Tcl_UpdateObjCmd -- * | | | | 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 | } /* *---------------------------------------------------------------------- * * Tcl_UpdateObjCmd -- * * This procedure is invoked to process the "update" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
1170 1171 1172 1173 1174 1175 1176 | flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; } else if (objc == 2) { if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum updateOptions) optionIndex) { | | | | < | | | < | > > | | | | 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 | flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; } else if (objc == 2) { if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum updateOptions) optionIndex) { case REGEXP_IDLETASKS: flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; default: Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); } } else { Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); return TCL_ERROR; } while (Tcl_DoOneEvent(flags) != 0) { if (Tcl_LimitExceeded(interp)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "limit exceeded", NULL); return TCL_ERROR; } } /* * Must clear the interpreter's result because event handlers could have * executed commands. */ Tcl_ResetResult(interp); return TCL_OK; } #ifdef TCL_THREADS /* *----------------------------------------------------------------------------- * * NewThreadProc -- * * Bootstrap function of a new Tcl thread. |
︙ | ︙ | |||
1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 | Tcl_Free((char*)clientData); /* Allocated in Tcl_CreateThread() */ (*threadProc)(threadClientData); TCL_THREAD_CREATE_RETURN; } #endif /* *---------------------------------------------------------------------- * * Tcl_CreateThread -- * | > | | | | | | | | | > > > > > > > > | 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 | Tcl_Free((char*)clientData); /* Allocated in Tcl_CreateThread() */ (*threadProc)(threadClientData); TCL_THREAD_CREATE_RETURN; } #endif /* *---------------------------------------------------------------------- * * Tcl_CreateThread -- * * This procedure creates a new thread. This actually belongs to the * tclThread.c file but since we use some private data structures local * to this file, it is placed here. * * Results: * TCL_OK if the thread could be created. The thread ID is returned in a * parameter. * * Side effects: * A new thread is created. * *---------------------------------------------------------------------- */ int Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags) Tcl_ThreadId *idPtr; /* Return, the ID of the thread */ Tcl_ThreadCreateProc proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ int stackSize; /* Size of stack for the new thread */ int flags; /* Flags controlling behaviour of the * new thread. */ { #ifdef TCL_THREADS ThreadClientData *cdPtr; cdPtr = (ThreadClientData *) Tcl_Alloc(sizeof(ThreadClientData)); cdPtr->proc = proc; cdPtr->clientData = clientData; return TclpThreadCreate(idPtr, NewThreadProc, (ClientData)cdPtr, stackSize, flags); #else return TCL_ERROR; #endif /* TCL_THREADS */ } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclExecute.c.
|
| | | < > > | | | > < | > > > > > > > > > > > | | < > < < < < < < < < < < < < < < | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | /* * 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. * Copyright (c) 2002-2005 by Miguel Sofer. * Copyright (c) 2005 by Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclExecute.c,v 1.167.2.57 2005/10/08 06:43:18 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" #include "tommath.h" #include <math.h> #include <float.h> /* * Hack to determine whether we may expect IEEE floating point. The hack is * formally incorrect in that non-IEEE platforms might have the same precision * and range, but VAX, IBM, and Cray do not; are there any other floating * point units that we might care about? */ #if ( FLT_RADIX == 2 ) && ( DBL_MANT_DIG == 53 ) && ( DBL_MAX_EXP == 1024 ) #define IEEE_FLOATING_POINT #endif /* * 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 define errno here. */ #ifdef TCL_GENERIC_ONLY # ifndef NO_FLOAT_H # include <float.h> # else /* NO_FLOAT_H */ # ifndef NO_VALUES_H # include <values.h> # endif /* !NO_VALUES_H */ # endif /* !NO_FLOAT_H */ # define NO_ERRNO_H #endif /* !TCL_GENERIC_ONLY */ #if 0 #ifdef NO_ERRNO_H int errno; # define EDOM 33 # define ERANGE 34 #endif #endif /* * A mask (should be 2**n-1) that is used to work out when the bytecode engine * should call Tcl_AsyncReady() to see whether there is a signal that needs * handling. */ #ifndef ASYNC_CHECK_COUNT_MASK # define ASYNC_CHECK_COUNT_MASK 63 #endif /* !ASYNC_CHECK_COUNT_MASK */ |
︙ | ︙ | |||
106 107 108 109 110 111 112 | "+", "-", "*", "/", "%", "+", "-", "~", "!", "BUILTIN FUNCTION", "FUNCTION", "", "", "", "", "", "", "", "", "eq", "ne" }; /* * Mapping from Tcl result codes to strings; used for error and debugging | | < < < < < < < < < | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | "+", "-", "*", "/", "%", "+", "-", "~", "!", "BUILTIN FUNCTION", "FUNCTION", "", "", "", "", "", "", "", "", "eq", "ne" }; /* * Mapping from Tcl result codes to strings; used for error and debugging * messages. */ #ifdef TCL_COMPILE_DEBUG static char *resultStrings[] = { "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" }; #endif /* * These are used by evalstats to monitor object usage in Tcl. */ #ifdef TCL_COMPILE_STATS long tclObjsAlloced = 0; long tclObjsFreed = 0; #define TCL_MAX_SHARED_OBJ_STATS 5 long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* TCL_COMPILE_STATS */ /* * 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 * resultHandling: 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, resultHandling) \ if (nCleanup == 0) {\ if (resultHandling != 0) {\ if ((resultHandling) > 0) {\ PUSH_OBJECT(objResultPtr);\ } else {\ *(++tosPtr) = objResultPtr;\ }\ } \ pc += (pcAdjustment);\ goto cleanup0;\ } else if (resultHandling != 0) {\ if ((resultHandling) > 0) {\ Tcl_IncrRefCount(objResultPtr);\ }\ pc += (pcAdjustment);\ switch (nCleanup) {\ case 1: goto cleanup1_pushObjResultPtr;\ case 2: goto cleanup2_pushObjResultPtr;\ default: Tcl_Panic("ERROR: bad usage of macro NEXT_INST_F");\ }\ } else {\ pc += (pcAdjustment);\ switch (nCleanup) {\ case 1: goto cleanup1;\ case 2: goto cleanup2;\ default: Tcl_Panic("ERROR: bad usage of macro NEXT_INST_F");\ }\ } #define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ pc += (pcAdjustment);\ cleanup = (nCleanup);\ if (resultHandling) {\ if ((resultHandling) > 0) {\ Tcl_IncrRefCount(objResultPtr);\ |
︙ | ︙ | |||
205 206 207 208 209 210 211 | * to TclExecuteByteCode. */ #define CACHE_STACK_INFO() \ tosPtr = eePtr->tosPtr #define DECACHE_STACK_INFO() \ | | > | | | | | | | | | | | | | | | | | | | | | | > | | | | | > > | < > | | 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 | * to TclExecuteByteCode. */ #define CACHE_STACK_INFO() \ tosPtr = eePtr->tosPtr #define DECACHE_STACK_INFO() \ eePtr->tosPtr = tosPtr;\ checkInterp = 1 /* * 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 decremented * before the caller had a chance to, e.g., store it in a variable. It is the * caller's responsibility to decrement the ref count when it is finished with * an object. * * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT * macro. The actual parameter might be an expression with side effects, and * this ensures that it will be executed only once. */ #define PUSH_OBJECT(objPtr) \ Tcl_IncrRefCount(*(++tosPtr) = (objPtr)) #define POP_OBJECT() \ *(tosPtr--) /* * Macros used to trace instruction execution. The macros TRACE, * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. O2S is * only used in TRACE* calls to get a string from an object. */ #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ if (traceInstructions) { \ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ (tosPtr - eePtr->stackPtr), \ (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, \ (tosPtr - eePtr->stackPtr), \ (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 */ #if 0 /* * Macro to read a string containing either a wide or an int and decide which * it is while decoding it at the same time. This enforces the policy that * integer constants between LONG_MIN and LONG_MAX (inclusive) are represented * by normal longs, and integer constants outside that range are represented * by wide ints. * * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never * generates an error message. * */ #define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \ if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ (objPtr)->typePtr = &tclIntType; \ (objPtr)->internalRep.longValue = (longVar) \ = Tcl_WideAsLong(wideVar); \ } #define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \ &(wideVar)); \ if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ (objPtr)->typePtr = &tclIntType; \ (objPtr)->internalRep.longValue = (longVar) \ = Tcl_WideAsLong(wideVar); \ } #endif /* * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from an obj. */ #if 0 #define FORCE_LONG(objPtr, longVar, wideVar) \ if ((objPtr)->typePtr == &tclWideIntType) { \ (longVar) = Tcl_WideAsLong(wideVar); \ } #define IS_INTEGER_TYPE(typePtr) \ ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType || (typePtr) == &tclBignumType) #define IS_NUMERIC_TYPE(typePtr) \ (IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType) #define W0 Tcl_LongAsWide(0) /* * For tracing that uses wide values. */ |
︙ | ︙ | |||
333 334 335 336 337 338 339 340 341 342 343 344 345 346 | #define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \ if (((typePtr) == &tclIntType) || ((typePtr) == &tclWideIntType)) { \ (doubleVar) = (double) (objPtr)->internalRep.longValue; \ } else { \ (doubleVar) = (objPtr)->internalRep.doubleValue; \ } #endif /* TCL_WIDE_INT_IS_LONG */ /* * Declarations for local procedures to this file: */ static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp, ByteCode *codePtr)); | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < < < < < < < < < | | | | | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | | | | | > > > > > | 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 | #define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \ if (((typePtr) == &tclIntType) || ((typePtr) == &tclWideIntType)) { \ (doubleVar) = (double) (objPtr)->internalRep.longValue; \ } else { \ (doubleVar) = (objPtr)->internalRep.doubleValue; \ } #endif /* TCL_WIDE_INT_IS_LONG */ #endif /* * Macro used in this file to save a function call for common uses of * TclGetNumberFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * ClientData *ptrPtr, int *tPtr); */ #ifdef TCL_WIDE_INT_IS_LONG #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_LONG, \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.longValue)), TCL_OK) : \ ((objPtr)->typePtr == &tclDoubleType) \ ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #else #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_LONG, \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.longValue)), TCL_OK) : \ ((objPtr)->typePtr == &tclWideIntType) \ ? (*(tPtr) = TCL_NUMBER_WIDE, \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ ((objPtr)->typePtr == &tclDoubleType) \ ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #endif /* * Macro used in this file to save a function call for common uses of * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * int *boolPtr); */ #define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ ((((objPtr)->typePtr == &tclIntType) \ || ((objPtr)->typePtr == &tclIntType)) \ ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) /* * Macro used in this file to save a function call for common uses of * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * Tcl_WideInt *wideIntPtr); */ #ifdef TCL_WIDE_INT_IS_LONG #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = (Tcl_WideInt) \ ((objPtr)->internalRep.longValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) #else #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclWideIntType) \ ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ ((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = (Tcl_WideInt) \ ((objPtr)->internalRep.longValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) #endif static Tcl_ObjType dictIteratorType = { "dictIterator", NULL, NULL, NULL, NULL }; /* * Declarations for local procedures to this file: */ static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp, ByteCode *codePtr)); #ifdef TCL_COMPILE_STATS static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); #endif /* TCL_COMPILE_STATS */ #ifdef TCL_COMPILE_DEBUG static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc)); #endif /* TCL_COMPILE_DEBUG */ static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc, int catchOnly, ByteCode* codePtr)); static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, ByteCode* codePtr, int *lengthPtr)); static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr)); static void IllegalExprOperandType _ANSI_ARGS_(( Tcl_Interp *interp, unsigned char *pc, Tcl_Obj *opndPtr)); static void InitByteCodeExecution _ANSI_ARGS_(( Tcl_Interp *interp)); #ifdef TCL_COMPILE_DEBUG static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr)); static char * StringForResultCode _ANSI_ARGS_((int result)); static void ValidatePcAndStackTop _ANSI_ARGS_(( ByteCode *codePtr, unsigned char *pc, int stackTop, int stackLowerBound, int checkStack)); #endif /* TCL_COMPILE_DEBUG */ #if 0 static Tcl_WideInt ExponWide _ANSI_ARGS_((Tcl_WideInt w, Tcl_WideInt w2, int *errExpon)); static long ExponLong _ANSI_ARGS_((long i, long i2, int *errExpon)); #endif /* *---------------------------------------------------------------------- * * InitByteCodeExecution -- * * This procedure is called once to initialize the Tcl bytecode * interpreter. * * Results: * None. * * Side effects: * This procedure initializes the array of instruction names. If * compiling with the TCL_COMPILE_STATS flag, it initializes the array * that counts the executions of each instruction and it creates the * "evalstats" command. It also establishes the link between the Tcl * "tcl_traceExec" and C "tclTraceExec" variables. * *---------------------------------------------------------------------- */ static void InitByteCodeExecution(interp) Tcl_Interp *interp; /* Interpreter for which the Tcl variable * "tcl_traceExec" is linked to control * instruction tracing. */ { #ifdef TCL_COMPILE_DEBUG if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, TCL_LINK_INT) != TCL_OK) { Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); } #endif #ifdef TCL_COMPILE_STATS Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); #endif /* TCL_COMPILE_STATS */ } /* *---------------------------------------------------------------------- * * TclCreateExecEnv -- * * This procedure creates a new execution environment for Tcl bytecode * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv is * typically created once for each Tcl interpreter (Interp structure) and * recursively passed to TclExecuteByteCode to execute ByteCode sequences * for nested commands. * * Results: * A newly allocated ExecEnv is returned. This points to an empty * evaluation stack of the standard initial size. * * Side effects: * The bytecode interpreter is also initialized here, as this procedure * will be called before any call to TclExecuteByteCode. * *---------------------------------------------------------------------- */ #define TCL_STACK_INITIAL_SIZE 2000 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->tosPtr = stackPtr - 1; eePtr->endPtr = stackPtr + (TCL_STACK_INITIAL_SIZE - 2); TclNewBooleanObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); TclNewBooleanObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); Tcl_MutexLock(&execMutex); if (!execInitialized) { TclInitAuxDataTypeTable(); InitByteCodeExecution(interp); execInitialized = 1; } |
︙ | ︙ | |||
540 541 542 543 544 545 546 | * * Frees the storage for an ExecEnv. * * Results: * None. * * Side effects: | | | > > | | | | | 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 | * * Frees the storage for an ExecEnv. * * Results: * None. * * Side effects: * Storage for an ExecEnv and its contained storage (e.g. the evaluation * stack) is freed. * *---------------------------------------------------------------------- */ void TclDeleteExecEnv(eePtr) ExecEnv *eePtr; /* Execution environment to free. */ { if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) { ckfree((char *) (eePtr->stackPtr-1)); } else { Tcl_Panic("ERROR: freeing an execEnv whose stack is still in use.\n"); } TclDecrRefCount(eePtr->constants[0]); TclDecrRefCount(eePtr->constants[1]); ckfree((char *) eePtr); } /* *---------------------------------------------------------------------- * * TclFinalizeExecution -- * * Finalizes the execution environment setup so that it can be later * reinitialized. * * Results: * None. * * Side effects: * After this call, the next time TclCreateExecEnv will be called it will * call InitByteCodeExecution. * *---------------------------------------------------------------------- */ void TclFinalizeExecution() { |
︙ | ︙ | |||
603 604 605 606 607 608 609 | * The size of the evaluation stack is doubled. * *---------------------------------------------------------------------- */ static void GrowEvaluationStack(eePtr) | | | | | | | | | | | < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | < | | | | | | | | | | | > | | > | | > | | > | | | | < | | < | 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 | * The size of the evaluation stack is doubled. * *---------------------------------------------------------------------- */ static void GrowEvaluationStack(eePtr) register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation * stack to enlarge. */ { /* * The current Tcl stack elements are stored from *(eePtr->stackPtr) to * *(eePtr->endPtr) (inclusive). */ int currElems = (eePtr->endPtr - eePtr->stackPtr + 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->endPtr = newStackPtr + (newElems - 2); /* index of last usable item */ eePtr->tosPtr += (newStackPtr - oldStackPtr); newStackPtr[-1] = (Tcl_Obj *) ((char *) 1); } /* *-------------------------------------------------------------- * * TclStackAlloc -- * * Allocate memory from the execution stack; it has to be returned later * with a call to TclStackFree * * Results: * A pointer to the first byte allocated, or panics if the allocation did * not succeed. * * Side effects: * The execution stack may be grown. * *-------------------------------------------------------------- */ char * TclStackAlloc(interp, numBytes) Tcl_Interp *interp; int numBytes; { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr = iPtr->execEnvPtr; int numWords; Tcl_Obj **tosPtr = eePtr->tosPtr; char **stackRefCountPtr; /* * Add two words to store * - a pointer to the used execution stack * - the number of words reserved * These will be used later by TclStackFree. */ numWords = (numBytes + 3*sizeof(void *) - 1)/sizeof(void *); while ((tosPtr + numWords) > eePtr->endPtr) { GrowEvaluationStack(eePtr); tosPtr = eePtr->tosPtr; } /* * Increase the stack's reference count, to make sure it is not freed * prematurely. */ stackRefCountPtr = (char **) (eePtr->stackPtr-1); ++*stackRefCountPtr; /* * Reserve the space in the exec stack, and store the data for freeing. */ eePtr->tosPtr += numWords; *(eePtr->tosPtr-1) = (Tcl_Obj *) stackRefCountPtr; *(eePtr->tosPtr) = (Tcl_Obj *) numWords; return (char *) (tosPtr+1); } void TclStackFree(interp) Tcl_Interp *interp; { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr = iPtr->execEnvPtr; char **stackRefCountPtr; stackRefCountPtr = (char **) *(eePtr->tosPtr-1); eePtr->tosPtr -= (int) *(eePtr->tosPtr); --*stackRefCountPtr; if (*stackRefCountPtr == (char *) 0) { ckfree((VOID *) stackRefCountPtr); } } /* *-------------------------------------------------------------- * * Tcl_ExprObj -- * * Evaluate an expression in a Tcl_Obj. * * Results: * A standard Tcl object result. If the result is other than TCL_OK, then * the interpreter's result contains an error message. If the result is * TCL_OK, then a pointer to the expression's result value object is * stored in resultPtrPtr. In that case, the object's ref count is * incremented to reflect the reference returned to the caller; the * caller is then responsible for the resulting object and must, for * example, decrement the ref count when it is finished with the object. * * Side effects: * Any side effects caused by subcommands in the expression, if any. The * interpreter result is not modified unless there is an error. * *-------------------------------------------------------------- */ int Tcl_ExprObj(interp, objPtr, resultPtrPtr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ register Tcl_Obj *objPtr; /* Points to Tcl object containing expression * to evaluate. */ Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression * result is stored if no errors occur. */ { Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ LiteralTable *localTablePtr = &(compEnv.localLitTable); register ByteCode *codePtr = NULL; /* Tcl Internal type of bytecode. Initialized * to avoid compiler warning. */ AuxData *auxDataPtr; LiteralEntry *entryPtr; Tcl_Obj *saveObjPtr, *resultPtr; char *string; int length, i, result; /* * First handle some common expressions specially. */ string = Tcl_GetStringFromObj(objPtr, &length); if (length == 1) { if (*string == '0') { TclNewBooleanObj(resultPtr, 0); Tcl_IncrRefCount(resultPtr); *resultPtrPtr = resultPtr; return TCL_OK; } else if (*string == '1') { TclNewBooleanObj(resultPtr, 1); Tcl_IncrRefCount(resultPtr); *resultPtrPtr = resultPtr; return TCL_OK; } } else if ((length == 2) && (*string == '!')) { if (*(string+1) == '0') { TclNewBooleanObj(resultPtr, 1); Tcl_IncrRefCount(resultPtr); *resultPtrPtr = resultPtr; return TCL_OK; } else if (*(string+1) == '1') { TclNewBooleanObj(resultPtr, 0); Tcl_IncrRefCount(resultPtr); *resultPtrPtr = resultPtr; return TCL_OK; } } /* * Get the ByteCode from the object. If it exists, make sure it hasn't * been invalidated by, e.g., someone redefining a command with a compile * procedure (this might make the compiled code wrong). If necessary, * convert the object to be a ByteCode object and compile it. Also, if * the code was compiled in/for a different interpreter, we recompile it. * * Precompiled expressions, however, are immutable and therefore they are * not recompiled, even if the epoch has changed. */ if (objPtr->typePtr == &tclByteCodeType) { codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch)) { if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { |
︙ | ︙ | |||
758 759 760 761 762 763 764 | } } if (objPtr->typePtr != &tclByteCodeType) { TclInitCompileEnv(interp, &compEnv, string, length); result = TclCompileExpr(interp, string, length, &compEnv); /* | | | | | 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 | } } if (objPtr->typePtr != &tclByteCodeType) { TclInitCompileEnv(interp, &compEnv, string, length); result = TclCompileExpr(interp, string, length, &compEnv); /* * Free the compilation environment's literal table bucket array if it * was dynamically allocated. */ if (localTablePtr->buckets != localTablePtr->staticBuckets) { ckfree((char *) localTablePtr->buckets); } if (result != TCL_OK) { /* * Compilation errors. Free storage allocated for compilation. */ #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(&compEnv); |
︙ | ︙ | |||
795 796 797 798 799 800 801 | auxDataPtr++; } TclFreeCompileEnv(&compEnv); return result; } /* | | | | | | | | | | | | | | | | | | | | | | | < | 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 | auxDataPtr++; } TclFreeCompileEnv(&compEnv); return result; } /* * Successful compilation. If the expression yielded no instructions, * push an zero object as the expression's result. */ if (compEnv.codeNext == compEnv.codeStart) { TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1), &compEnv); } /* * Add a "done" instruction as the last instruction and change the * object into a ByteCode object. Ownership of the literal objects and * aux data items is given to the ByteCode object. */ TclEmitOpcode(INST_DONE, &compEnv); TclInitByteCodeObj(objPtr, &compEnv); TclFreeCompileEnv(&compEnv); codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile == 2) { TclPrintByteCodeObj(interp, objPtr); } #endif /* TCL_COMPILE_DEBUG */ } /* * Execute the expression after first saving the interpreter's result. */ saveObjPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(saveObjPtr); Tcl_ResetResult(interp); /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. */ codePtr->refCount++; result = TclExecuteByteCode(interp, codePtr); codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); objPtr->typePtr = NULL; objPtr->internalRep.otherValuePtr = NULL; } /* * If the expression evaluated successfully, store a pointer to its value * object in resultPtrPtr then restore the old interpreter result. We * increment the object's ref count to reflect the reference that we are * returning to the caller. We also decrement the ref count of the * interpreter's result object after calling Tcl_SetResult since we next * store into that field directly. */ if (result == TCL_OK) { *resultPtrPtr = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->objResultPtr); Tcl_SetObjResult(interp, saveObjPtr); } TclDecrRefCount(saveObjPtr); return result; } /* *---------------------------------------------------------------------- * * TclCompEvalObj -- * * This procedure evaluates the script contained in a Tcl_Obj by first * compiling it and then passing it to TclExecuteByteCode. * * Results: * The return value is one of the return codes defined in tcl.h (such as * TCL_OK), and interp->objResultPtr refers to a Tcl object that either * contains the result of executing the code or an error message. * * Side effects: * Almost certainly, depending on the ByteCode's instructions. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
908 909 910 911 912 913 914 | if (iPtr->varFramePtr != NULL) { namespacePtr = iPtr->varFramePtr->nsPtr; } else { namespacePtr = iPtr->globalNsPtr; } | | | | < | | | < | | | < | | | | | | | | | 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 | 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) { iPtr->numLevels--; return result; } codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; } else { /* * Make sure the Bytecode hasn't been invalidated by, e.g., someone * redefining a command with a compile procedure (this might make the * compiled code wrong). The object needs to be recompiled if it was * compiled in/for a 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)) |
︙ | ︙ | |||
985 986 987 988 989 990 991 992 993 | iPtr->numLevels--; return result; } /* *---------------------------------------------------------------------- * * TclExecuteByteCode -- * | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | < | | | | | | | | < | | | > > | | < | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | > > | | > | < | | | > > | | | | | | | > > | | > > > > > > > > > > > > > > | | | | | | | | > > > | | > > > > > > > > > > | | < | | | | | | < | | | > > | > > > | | | > > > | | | > > | | | > > > > > > > > > > > > > > > > | | < | | | < | | < | | | | | | | | < | | | | | | | | | | < | | | | | | | | | | < | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | < | | | | < | | | > | | | | | < | | | | | | | < | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | < | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | > | | < < | | | < < | | | | | | | < | | | | < | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | < | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | > | > | | > | | > > | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | > > > > | | | | | | | | | | | | | | | | > | > > > > | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | > | > > > > | | | | | | | | | | < | | | | | > | | | | | | | | > | > > > > | | | | | | | | | | | | | < | > | | | < | | | | | | | | > | < | | | | | | | | | | | | | | | > | < | | | | | | | | | | | | | | | | | | > > > > > > > > | | | | | > | > | | | | | | | | | | | | > | | | < | < < | | | < < | < < < | < < < < | > > > | | < > | > > | > | > < < | < < | < < < < < < < < < < < < < | < | < < | | > | < < | | | < | | < < | | | | | | | < | | | | | | | < | > | | < | | | | | | < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < | < < | | | | | | | < < < < < < < < < < < < < < < < < < < < | < | | | | | | | < < < < < < | | | < < < < < | | < | | | | > | | | | | | | | < | | | | | | | | | | | | | | | | < | | | | | | > | | | | | | > | | | | | | | | | | | > | | | | | < | > | | > | | > | < > | | < | < | | | | | < | | | | | | | | | | < | | | | | | 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 | iPtr->numLevels--; return result; } /* *---------------------------------------------------------------------- * * TclIncrObj -- * * Increment an integeral value in a Tcl_Obj by an integeral value * held in another Tcl_Obj. Caller is responsible for making sure * we can update the first object. * * Results: * TCL_ERROR if either object is non-integer, and TCL_OK otherwise. On * error, an error message is left in the interpreter (if it is not NULL, * of course). * * Side effects: * valuePtr gets the new incrmented value. * *---------------------------------------------------------------------- */ int TclIncrObj(interp, valuePtr, incrPtr) Tcl_Interp *interp; Tcl_Obj *valuePtr; Tcl_Obj *incrPtr; { ClientData ptr1, ptr2; int type1, type2; mp_int value, incr; if (Tcl_IsShared(valuePtr)) { Tcl_Panic("shared object passed to TclIncrObj"); } if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { /* Produce error message (reparse?!) */ return Tcl_GetIntFromObj(interp, valuePtr, &type1); } if ((GetNumberFromObj(NULL, incrPtr, &ptr2, &type2) != TCL_OK) || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { /* Produce error message (reparse?!) */ Tcl_GetIntFromObj(interp, incrPtr, &type1); Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } do {if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, sum; TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, incrPtr, &w2); sum = w1 + w2; #ifndef NO_WIDE_TYPE if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) #endif { /* Check for overflow */ if (((w1 < 0) && (w2 < 0) && (sum > 0)) || ((w1 > 0) && (w2 > 0) && (sum < 0))) { break; } } Tcl_SetWideIntObj(valuePtr, sum); return TCL_OK; }} while (0); Tcl_GetBignumAndClearObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); mp_add(&value, &incr, &value); mp_clear(&incr); Tcl_SetBignumObj(valuePtr, &value); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclExecuteByteCode -- * * This procedure executes the instructions of a ByteCode structure. It * returns when a "done" instruction is executed or an error occurs. * * Results: * The return value is one of the return codes defined in tcl.h (such as * TCL_OK), and interp->objResultPtr refers to a Tcl object that either * contains the result of executing the code or an error message. * * Side effects: * Almost certainly, depending on the ByteCode's instructions. * *---------------------------------------------------------------------- */ static int TclExecuteByteCode(interp, codePtr) Tcl_Interp *interp; /* Token for command interpreter. */ ByteCode *codePtr; /* The bytecode sequence to interpret. */ { /* * Compiler cast directive - not a real variable. * Interp *iPtr = (Interp *) interp; */ #define iPtr ((Interp *) interp) /* * Constants: variables that do not change during the execution, used * sporadically. */ ExecEnv *eePtr; /* Points to the execution environment. */ int initStackTop; /* Stack top at start of execution. */ int initCatchTop; /* Catch stack top at start of execution. */ Var *compiledLocals; Namespace *namespacePtr; /* * Globals: variables that store state, must remain valid at all times. */ int catchTop; register Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation stack. */ register unsigned char *pc = codePtr->codeStart; /* The current program counter. */ int instructionCount = 0; /* Counter that is used to work out when to * call Tcl_AsyncReady() */ Tcl_Obj *expandNestList = NULL; int checkInterp = 0; /* Indicates when a check of interp readyness * is necessary. Set by DECACHE_STACK_INFO() */ /* * Transfer variables - needed only between opcodes, but not while * executing an instruction. */ register int cleanup; Tcl_Obj *objResultPtr; /* * Result variable - needed only when going to checkForcatch or other * error handlers; also used as local in some opcodes. */ int result = TCL_OK; /* Return code returned after execution. */ /* * Locals - variables that are used within opcodes or bounded sections of * the file (jumps between opcodes within a family). * NOTE: These are now defined locally where needed. */ #ifdef TCL_COMPILE_DEBUG int traceInstructions = (tclTraceExec == 3); char cmdNameBuf[21]; #endif /* * The execution uses a unified stack: first the catch stack, immediately * above it the execution stack. * * Make sure the catch stack is large enough to hold the maximum number of * catch commands that could ever be executing at the same time (this will * be no more than the exception range array's depth). Make sure the * execution stack is large enough to execute this ByteCode. */ eePtr = iPtr->execEnvPtr; initCatchTop = eePtr->tosPtr - eePtr->stackPtr; catchTop = initCatchTop; tosPtr = eePtr->tosPtr + codePtr->maxExceptDepth; while ((tosPtr + codePtr->maxStackDepth) > eePtr->endPtr) { GrowEvaluationStack(eePtr); tosPtr = eePtr->tosPtr + codePtr->maxExceptDepth; } initStackTop = tosPtr - eePtr->stackPtr; #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { PrintByteCodeInfo(codePtr); fprintf(stdout, " Starting stack top=%d\n", initStackTop); fflush(stdout); } #endif #ifdef TCL_COMPILE_STATS iPtr->stats.numExecutions++; #endif if (iPtr->varFramePtr != NULL) { namespacePtr = iPtr->varFramePtr->nsPtr; compiledLocals = iPtr->varFramePtr->compiledLocals; } else { namespacePtr = iPtr->globalNsPtr; compiledLocals = NULL; } /* * 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. */ { Tcl_Obj *valuePtr; cleanupV_pushObjResultPtr: switch (cleanup) { case 0: *(++tosPtr) = (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 = *tosPtr; TclDecrRefCount(valuePtr); } *tosPtr = 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 /* * Skip the stack depth check if an expansion is in progress */ ValidatePcAndStackTop(codePtr, pc, (tosPtr - eePtr->stackPtr), initStackTop, /*checkStack*/ (expandNestList == NULL)); if (traceInstructions) { fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (tosPtr - eePtr->stackPtr)); TclPrintInstruction(codePtr, pc); fflush(stdout); } #endif /* TCL_COMPILE_DEBUG */ #ifdef TCL_COMPILE_STATS iPtr->stats.instructionCount[*pc]++; #endif /* * Check for asynchronous handlers [Bug 746722]; we do the check every * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). */ if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { if (Tcl_AsyncReady()) { int localResult; DECACHE_STACK_INFO(); localResult = Tcl_AsyncInvoke(interp, result); CACHE_STACK_INFO(); if (localResult == TCL_ERROR) { result = localResult; goto checkForCatch; } } if (Tcl_LimitReady(interp)) { int localResult; DECACHE_STACK_INFO(); localResult = Tcl_LimitCheck(interp); CACHE_STACK_INFO(); if (localResult == TCL_ERROR) { result = localResult; goto checkForCatch; } } } switch (*pc) { case INST_RETURN_IMM: { int code = TclGetInt4AtPtr(pc+1); int level = TclGetUInt4AtPtr(pc+5); Tcl_Obj *returnOpts; TRACE(("%u %u => ", code, level)); returnOpts = POP_OBJECT(); result = TclProcessReturn(interp, code, level, returnOpts); Tcl_DecrRefCount(returnOpts); if (result != TCL_OK) { Tcl_SetObjResult(interp, *tosPtr); cleanup = 1; goto processExceptionReturn; } TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", O2S(objResultPtr))); NEXT_INST_F(9, 0, 0); } case INST_RETURN_STK: TRACE(("=> ")); objResultPtr = POP_OBJECT(); result = Tcl_SetReturnOptions(interp, POP_OBJECT()); if (result != TCL_OK) { Tcl_SetObjResult(interp, objResultPtr); Tcl_DecrRefCount(objResultPtr); cleanup = 0; goto processExceptionReturn; } TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", O2S(objResultPtr))); NEXT_INST_F(1, 0, -1); case INST_DONE: if (tosPtr <= eePtr->stackPtr + initStackTop) { tosPtr--; 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". */ Tcl_SetObjResult(interp, *tosPtr); #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: #if !TCL_COMPILE_DEBUG instPush1Peephole: #endif PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), *tosPtr); pc += 2; #if !TCL_COMPILE_DEBUG /* * Runtime peephole optimisation: check if we are pushing again. */ if (*pc == INST_PUSH1) { goto instPush1Peephole; } #endif NEXT_INST_F(0, 0, 0); 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: { Tcl_Obj *valuePtr; TRACE_WITH_OBJ(("=> discarding "), *tosPtr); valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); /* * Runtime peephole optimisation: an INST_POP is scheduled at the end * of most commands. If the next instruction is an INST_START_CMD, * fall through to it. */ pc++; #if !TCL_COMPILE_DEBUG if (*pc == INST_START_CMD) { goto instStartCmdPeephole; } #endif NEXT_INST_F(0, 0, 0); } case INST_START_CMD: #if !TCL_COMPILE_DEBUG instStartCmdPeephole: #endif /* * Remark that if the interpreter is marked for deletion its * compileEpoch is modified, so that the epoch check also verifies * that the interp is not deleted. If no outside call has been made * since the last check, it is safe to omit the check. */ iPtr->cmdCount++; if (!checkInterp || (((codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsEpoch == namespacePtr->resolverEpoch)) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED))) { #if !TCL_COMPILE_DEBUG /* * Peephole optimisations: check if there are several * INST_START_CMD in a row. Many commands start by pushing a * literal argument or command name; optimise that case too. */ while (*(pc += 5) == INST_START_CMD) { iPtr->cmdCount++; } if (*pc == INST_PUSH1) { goto instPush1Peephole; } NEXT_INST_F(0, 0, 0); #else NEXT_INST_F(5, 0, 0); #endif } else { char *bytes; int length, opnd; Tcl_Obj *newObjResultPtr; bytes = GetSrcInfoForPc(pc, codePtr, &length); DECACHE_STACK_INFO(); result = Tcl_EvalEx(interp, bytes, length, 0); CACHE_STACK_INFO(); if (result != TCL_OK) { cleanup = 0; goto processExceptionReturn; } opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = Tcl_GetObjResult(interp); TclNewObj(newObjResultPtr); Tcl_IncrRefCount(newObjResultPtr); iPtr->objResultPtr = newObjResultPtr; NEXT_INST_V(opnd, 0, -1); } case INST_DUP: objResultPtr = *tosPtr; TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); case INST_OVER: { int opnd; opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = *(tosPtr - opnd); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(5, 0, 1); } case INST_CONCAT1: { int opnd, length, appendLen = 0; char *bytes, *p; Tcl_Obj **currPtr; opnd = TclGetUInt1AtPtr(pc+1); /* * Compute the length to be appended. */ for (currPtr = tosPtr - (opnd-2); currPtr <= tosPtr; currPtr++) { bytes = Tcl_GetStringFromObj(*currPtr, &length); if (bytes != NULL) { appendLen += length; } } /* * If nothing is to be appended, just return the first object by * dropping all the others from the stack; this saves both the * computation and copy of the string rep of the first object, * enabling the fast '$x[set x {}]' idiom for 'K $x [set x{}]'. */ if (appendLen == 0) { TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, (opnd-1), 0); } /* * If the first object is shared, we need a new obj for the result; * otherwise, we can reuse the first object. In any case, make sure * it has enough room to accomodate all the concatenated bytes. Note * that if it is unshared its bytes are already copied by * Tcl_SetObjectLength, so that we set the loop parameters to avoid * copying them again: p points to the end of the already copied * bytes, currPtr to the second object. */ objResultPtr = *(tosPtr-(opnd-1)); bytes = Tcl_GetStringFromObj(objResultPtr, &length); #if !TCL_COMPILE_DEBUG if (!Tcl_IsShared(objResultPtr)) { Tcl_SetObjLength(objResultPtr, (length + appendLen)); p = TclGetString(objResultPtr) + length; currPtr = tosPtr - (opnd - 2); } else { #endif p = (char *) ckalloc((unsigned) (length + appendLen + 1)); TclNewObj(objResultPtr); objResultPtr->bytes = p; objResultPtr->length = length + appendLen; currPtr = tosPtr - (opnd - 1); #if !TCL_COMPILE_DEBUG } #endif /* * Append the remaining characters. */ for (; currPtr <= tosPtr; currPtr++) { bytes = Tcl_GetStringFromObj(*currPtr, &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_EXPAND_START: { /* * Push an element to the expandNestList. This records the current * tosPtr - i.e., the point in the stack where the expanded command * starts. * * Use a Tcl_Obj as linked list element; slight mem waste, but faster * allocation than ckalloc. This also abuses the Tcl_Obj structure, as * we do not define a special tclObjType for it. It is not dangerous * as the obj is never passed anywhere, so that all manipulations are * performed here and in INST_INVOKE_EXPANDED (in case of an expansion * error, also in INST_EXPAND_STKTOP). */ Tcl_Obj *objPtr; TclNewObj(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) (tosPtr - eePtr->stackPtr); objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) expandNestList; expandNestList = objPtr; NEXT_INST_F(1, 0, 0); } case INST_EXPAND_STKTOP: { int objc, length, i; Tcl_Obj **objv, *valuePtr, *objPtr; /* * Make sure that the element at stackTop is a list; if not, remove * the element from the expand link list and leave. */ valuePtr = *tosPtr; if (Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { result = TCL_ERROR; TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), Tcl_GetObjResult(interp)); objPtr = expandNestList; expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; TclDecrRefCount(objPtr); goto checkForCatch; } tosPtr--; /* * Make sure there is enough room in the stack to expand this list * *and* process the rest of the command (at least up to the next * argument expansion or command end). The operand is the current * stack depth, as seen by the compiler. */ length = objc + codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1); while ((tosPtr + length) > eePtr->endPtr) { DECACHE_STACK_INFO(); GrowEvaluationStack(eePtr); CACHE_STACK_INFO(); } /* * Expand the list at stacktop onto the stack; free the list. */ for (i = 0; i < objc; i++) { PUSH_OBJECT(objv[i]); } TclDecrRefCount(valuePtr); NEXT_INST_F(5, 0, 0); } { /* * INVOCATION BLOCK */ int objc, pcAdjustment; case INST_INVOKE_EXPANDED: { Tcl_Obj *objPtr; objPtr = expandNestList; expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; objc = tosPtr - eePtr->stackPtr - (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1; TclDecrRefCount(objPtr); } if (objc == 0) { /* * Nothing was expanded, return {}. */ TclNewObj(objResultPtr); NEXT_INST_F(1, 0, 1); } pcAdjustment = 1; goto doInvocation; case INST_INVOKE_STK4: objc = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; goto doInvocation; case INST_INVOKE_STK1: objc = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; doInvocation: { Tcl_Obj **objv = (tosPtr - (objc-1)); int length; char *bytes; /* * We keep the stack reference count as a (char *), as that works * nicely as a portable pointer-sized counter. */ char **preservedStackRefCountPtr; #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { int i; 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 **) (eePtr->stackPtr-1); ++*preservedStackRefCountPtr; /* * Reset the instructionCount variable, since we're about to check * for async stuff anyway while processing TclEvalObjvInternal. */ instructionCount = 1; /* * Finally, let TclEvalObjvInternal handle the command. */ DECACHE_STACK_INFO(); Tcl_ResetResult(interp); 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) { Tcl_Obj *objPtr; /* * 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); /* * Reset the interp's result to avoid possible duplications of * large objects [Bug 781585]. We do not call Tcl_ResetResult * to avoid any side effects caused by the resetting of * errorInfo and errorCode [Bug 804681], which are not needed * here. We chose instead to manipulate the interp's object * result directly. * * Note that the result object is now in objResultPtr, it * keeps the refCount it had in its role of * iPtr->objResultPtr. */ TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; NEXT_INST_V(pcAdjustment, objc, -1); } else { cleanup = objc; 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! */ Tcl_Obj *objPtr; objPtr = *tosPtr; 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)); /* * Reset the interp's result to avoid possible duplications of * large objects [Bug 781585]. We do not call Tcl_ResetResult to * avoid any side effects caused by the resetting of errorInfo and * errorCode [Bug 804681], which are not needed here. We chose * instead to manipulate the interp's object result directly. * * Note that the result object is now in objResultPtr, it keeps * the refCount it had in its role of iPtr->objResultPtr. */ TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; NEXT_INST_F(1, 1, -1); } else { cleanup = 1; goto processExceptionReturn; } } case INST_EXPR_STK: { Tcl_Obj *objPtr, *valuePtr; objPtr = *tosPtr; DECACHE_STACK_INFO(); Tcl_ResetResult(interp); result = Tcl_ExprObj(interp, objPtr, &valuePtr); CACHE_STACK_INFO(); if (result != TCL_OK) { TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), Tcl_GetObjResult(interp)); goto checkForCatch; } 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. */ { int opnd, pcAdjustment; char *part1, *part2; Var *varPtr, *arrayPtr; Tcl_Obj *objPtr; case INST_LOAD_SCALAR1: opnd = TclGetUInt1AtPtr(pc+1); varPtr = &(compiledLocals[opnd]); part1 = varPtr->name; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { /* * 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 = &(compiledLocals[opnd]); part1 = varPtr->name; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { /* * 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(*tosPtr); /* element name */ objPtr = *(tosPtr - 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 = *tosPtr; /* 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 (TclIsVarDirectReadable(varPtr) && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) { /* * 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(*tosPtr); arrayPtr = &(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 (TclIsVarDirectReadable(varPtr) && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) { /* * 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. */ { int opnd, pcAdjustment, storeFlags; char *part1, *part2; Var *varPtr, *arrayPtr; Tcl_Obj *objPtr, *valuePtr; case INST_LAPPEND_STK: valuePtr = *tosPtr; /* 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 = *tosPtr; /* value to append */ part2 = TclGetString(*(tosPtr - 1)); storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT | TCL_TRACE_READS); goto doStoreStk; case INST_APPEND_STK: valuePtr = *tosPtr; /* value to append */ part2 = NULL; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreStk; case INST_APPEND_ARRAY_STK: valuePtr = *tosPtr; /* value to append */ part2 = TclGetString(*(tosPtr - 1)); storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreStk; case INST_STORE_ARRAY_STK: valuePtr = *tosPtr; part2 = TclGetString(*(tosPtr - 1)); storeFlags = TCL_LEAVE_ERR_MSG; goto doStoreStk; case INST_STORE_STK: case INST_STORE_SCALAR_STK: valuePtr = *tosPtr; part2 = NULL; storeFlags = TCL_LEAVE_ERR_MSG; doStoreStk: objPtr = *(tosPtr - 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 = *tosPtr; part2 = TclGetString(*(tosPtr - 1)); arrayPtr = &(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 = *tosPtr; varPtr = &(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) && TclIsVarDirectWritable(varPtr) && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) { /* * 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 = *tosPtr; 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. */ /*TODO: Consider more untangling here; merge with LOAD and STORE ? */ { Tcl_Obj *objPtr, *incrPtr; int opnd, pcAdjustment; #if 0 int isWide; Tcl_WideInt w; #endif long i; char *part1, *part2; Var *varPtr, *arrayPtr; 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); #if 0 objPtr = *tosPtr; if (objPtr->typePtr == &tclIntType) { i = objPtr->internalRep.longValue; isWide = 0; } else if (objPtr->typePtr == &tclWideIntType) { i = 0; /* lint */ w = objPtr->internalRep.wideValue; isWide = 1; } else { i = 0; /* lint */ REQUIRE_WIDE_OR_INT(result, objPtr, i, w); if (result != TCL_OK) { TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ", opnd, O2S(objPtr)), Tcl_GetObjResult(interp)); Tcl_AddErrorInfo(interp, "\n (reading increment)"); goto checkForCatch; } isWide = (objPtr->typePtr == &tclWideIntType); } tosPtr--; TclDecrRefCount(objPtr); #else incrPtr = *tosPtr; tosPtr--; #endif 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); #if 0 isWide = 0; #else incrPtr = Tcl_NewIntObj(i); Tcl_IncrRefCount(incrPtr); #endif pcAdjustment = 2; doIncrStk: if ((*pc == INST_INCR_ARRAY_STK_IMM) || (*pc == INST_INCR_ARRAY_STK)) { part2 = TclGetString(*tosPtr); objPtr = *(tosPtr - 1); TRACE(("\"%.30s(%.30s)\" (by %ld) => ", O2S(objPtr), part2, i)); } else { part2 = NULL; objPtr = *tosPtr; 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; Tcl_DecrRefCount(incrPtr); goto checkForCatch; } cleanup = ((part2 == NULL)? 1 : 2); goto doIncrVar; case INST_INCR_ARRAY1_IMM: opnd = TclGetUInt1AtPtr(pc+1); i = TclGetInt1AtPtr(pc+2); #if 0 isWide = 0; #else incrPtr = Tcl_NewIntObj(i); Tcl_IncrRefCount(incrPtr); #endif pcAdjustment = 3; doIncrArray: part2 = TclGetString(*tosPtr); arrayPtr = &(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; Tcl_DecrRefCount(incrPtr); goto checkForCatch; } cleanup = 1; goto doIncrVar; case INST_INCR_SCALAR1_IMM: opnd = TclGetUInt1AtPtr(pc+1); i = TclGetInt1AtPtr(pc+2); #if 0 isWide = 0; #else incrPtr = Tcl_NewIntObj(i); Tcl_IncrRefCount(incrPtr); #endif pcAdjustment = 3; doIncrScalar: varPtr = &(compiledLocals[opnd]); part1 = varPtr->name; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } arrayPtr = NULL; part2 = NULL; cleanup = 0; TRACE(("%u %ld => ", opnd, i)); doIncrVar: #if 0 objPtr = varPtr->value.objPtr; if (TclIsVarDirectReadable(varPtr) && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) { if (objPtr->typePtr == &tclIntType && !isWide) { /* * No errors, no traces, the variable already has an integer * value: inline processing. */ i += objPtr->internalRep.longValue; if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* we know it is shared */ TclNewLongObj(objResultPtr, i); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { TclSetLongObj(objPtr, i); objResultPtr = objPtr; } goto doneIncr; } else if (objPtr->typePtr == &tclWideIntType && isWide) { /* * No errors, no traces, the variable already has a wide * integer value: inline processing. */ w += objPtr->internalRep.wideValue; if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* we know it is shared */ TclNewWideIntObj(objResultPtr, w); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { TclSetWideIntObj(objPtr, w); objResultPtr = objPtr; } goto doneIncr; } } DECACHE_STACK_INFO(); if (isWide) { objResultPtr = TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1, part2, w, TCL_LEAVE_ERR_MSG); } else { objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, i, TCL_LEAVE_ERR_MSG); } CACHE_STACK_INFO(); #else /* TODO: Restore no trace optimization */ DECACHE_STACK_INFO(); objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2, incrPtr, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); Tcl_DecrRefCount(incrPtr); #endif if (objResultPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); result = TCL_ERROR; goto checkForCatch; } #if 0 doneIncr: #endif 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: { int opnd; 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: { int opnd; opnd = TclGetInt4AtPtr(pc+1); TRACE(("%d => new pc %u\n", opnd, (unsigned int)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); } { int jmpOffset[2]; int b; Tcl_Obj *valuePtr; /* TODO: consider rewrite so we don't compute the offset we're * not going to take. */ case INST_JUMP_FALSE4: jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */ jmpOffset[1] = 5; /* TRUE offset*/ goto doCondJump; case INST_JUMP_TRUE4: jmpOffset[0] = 5; jmpOffset[1] = TclGetInt4AtPtr(pc+1); goto doCondJump; case INST_JUMP_FALSE1: jmpOffset[0] = TclGetInt1AtPtr(pc+1); jmpOffset[1] = 2; goto doCondJump; case INST_JUMP_TRUE1: jmpOffset[0] = 2; jmpOffset[1] = TclGetInt1AtPtr(pc+1); doCondJump: valuePtr = *tosPtr; /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for eePtr->constants */ result = TclGetBooleanFromObj(interp, valuePtr, &b); if (result != TCL_OK) { TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[ ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4)) ? 0 : 1]), Tcl_GetObjResult(interp)); goto checkForCatch; } #ifdef TCL_COMPILE_DEBUG if (b) { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1], O2S(valuePtr), (unsigned int)(pc+jmpOffset[1] - codePtr->codeStart))); } else { TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr))); } } else { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr))); } else { TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], O2S(valuePtr), (unsigned int)(pc + jmpOffset[1] - codePtr->codeStart))); } } #endif NEXT_INST_F(jmpOffset[b], 1, 0); } /* * These two instructions are now redundant: the complete logic of the LOR * and LAND is now handled by the expression compiler. */ case INST_LOR: case INST_LAND: { /* * Operands must be boolean or numeric. No int->double conversions are * performed. */ int i1, i2, iResult; Tcl_Obj *value2Ptr = *tosPtr; Tcl_Obj *valuePtr = *(tosPtr - 1); result = TclGetBooleanFromObj(NULL, valuePtr, &i1); if (result != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } result = TclGetBooleanFromObj(NULL, value2Ptr, &i2); if (result != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, value2Ptr); goto checkForCatch; } if (*pc == INST_LOR) { iResult = (i1 || i2); } else { iResult = (i1 && i2); } objResultPtr = eePtr->constants[iResult]; TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); NEXT_INST_F(1, 2, 1); } /* * --------------------------------------------------------- * 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. */ int opnd; opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = Tcl_NewListObj(opnd, (tosPtr - (opnd-1))); TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(5, opnd, 1); } case INST_LIST_LENGTH: { Tcl_Obj *valuePtr; int length; valuePtr = *tosPtr; result = Tcl_ListObjLength(interp, valuePtr, &length); if (result != TCL_OK) { TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), Tcl_GetObjResult(interp)); goto checkForCatch; } TclNewIntObj(objResultPtr, length); TRACE(("%.20s => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); } case INST_LIST_INDEX: { /*** lindex with objc == 3 ***/ Tcl_Obj *valuePtr, *value2Ptr; /* * Pop the two operands */ value2Ptr = *tosPtr; valuePtr = *(tosPtr - 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_IMM: { /*** lindex with objc==3 and index in bytecode stream ***/ int listc, idx, opnd; Tcl_Obj **listv; Tcl_Obj *valuePtr; /* * Pop the list and get the index */ valuePtr = *tosPtr; opnd = TclGetInt4AtPtr(pc+1); /* * Get the contents of the list, making sure that it really is a list * in the process. */ result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv); if (result != TCL_OK) { TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), Tcl_GetObjResult(interp)); goto checkForCatch; } /* * Select the list item based on the index. Negative operand means * end-based indexing. */ if (opnd < -1) { idx = opnd+1 + listc; } else { idx = opnd; } if (idx >= 0 && idx < listc) { objResultPtr = listv[idx]; } else { TclNewObj(objResultPtr); } TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), objResultPtr); NEXT_INST_F(5, 1, 1); } case INST_LIST_INDEX_MULTI: { /* * 'lindex' with multiple index args: * * Determine the count of index args. */ int numIdx, opnd; opnd = TclGetUInt4AtPtr(pc+1); numIdx = opnd-1; /* * Do the 'lindex' operation. */ objResultPtr = TclLindexFlat(interp, *(tosPtr - numIdx), numIdx, tosPtr - 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; Tcl_Obj *valuePtr, *value2Ptr; 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 = *tosPtr; /* * Compute the new variable value */ objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx, tosPtr - 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. */ Tcl_Obj *objPtr, *valuePtr, *value2Ptr; /* * 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 = *tosPtr; value2Ptr = *(tosPtr - 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); } case INST_LIST_RANGE_IMM: { /*** lrange with objc==4 and both indices in bytecode stream ***/ int listc, fromIdx, toIdx; Tcl_Obj **listv; Tcl_Obj *valuePtr; /* * Pop the list and get the indices */ valuePtr = *tosPtr; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); /* * Get the contents of the list, making sure that it really is a list * in the process. */ result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv); if (result != TCL_OK) { TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), fromIdx, toIdx), Tcl_GetObjResult(interp)); goto checkForCatch; } /* * Skip a lot of work if we're about to throw the result away (common * with uses of [lassign].) */ #ifndef TCL_COMPILE_DEBUG if (*(pc+9) == INST_POP) { NEXT_INST_F(10, 1, 0); } #endif |
︙ | ︙ | |||
2846 2847 2848 2849 2850 2851 2852 | toIdx = -1; } } else if (toIdx > listc) { toIdx = listc; } /* | | | | 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 | toIdx = -1; } } else if (toIdx > listc) { toIdx = listc; } /* * Check if we are referring to a valid, non-empty list range, and if * so, build the list of elements in that range. */ if (fromIdx<=toIdx && fromIdx<listc && toIdx>=0) { if (fromIdx<0) { fromIdx = 0; } if (toIdx >= listc) { toIdx = listc-1; |
︙ | ︙ | |||
2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 | int found, s1len, s2len, llen, i; Tcl_Obj *valuePtr, *value2Ptr, *o; char *s1, *s2; value2Ptr = *tosPtr; valuePtr = *(tosPtr - 1); s1 = Tcl_GetStringFromObj(valuePtr, &s1len); result = Tcl_ListObjLength(interp, value2Ptr, &llen); if (result != TCL_OK) { TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr), O2S(value2Ptr)), Tcl_GetObjResult(interp)); goto checkForCatch; } | > | 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 | int found, s1len, s2len, llen, i; Tcl_Obj *valuePtr, *value2Ptr, *o; char *s1, *s2; value2Ptr = *tosPtr; valuePtr = *(tosPtr - 1); /* TODO: Consider more efficient tests than strcmp() */ s1 = Tcl_GetStringFromObj(valuePtr, &s1len); result = Tcl_ListObjLength(interp, value2Ptr, &llen); if (result != TCL_OK) { TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr), O2S(value2Ptr)), Tcl_GetObjResult(interp)); goto checkForCatch; } |
︙ | ︙ | |||
2910 2911 2912 2913 2914 2915 2916 | if (*pc == INST_LIST_NOT_IN) { found = !found; } TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), found)); /* | | > | | | | < > | | | | | < | | | | | | | | | | < | > | | | | | | | | | | | > > > > > > | > > > > > | > > | > > | > > > > | | > > > > | | > > > | < | | | | < | | | | < | | < | | | | | | < | | | | | | > < | | < < < | | < | < < < < < | | < < > | | < < < | | < > | < | > > | < < > > > | < | < < < < < < < < < < < < < < < < | | | < < < < < | < | < < < < | | | < < | < < < < < < < < < | < < < < < < | > > | > > > > > > > > > > > > > > | < < < > > > | | < | < < < < < < | < < < > > > > > > > > > > > > | > > > > > > > | > > | | < | > | > > | > | > | < < < < < < < < < < < > > > | > > > > > > > | > | > | > > > | > > > > > > > > > | | < > | | | > | | | > > > | | | < | > | > > > > | | > | < | | | < | < < < < < < < | | < | < > > | > > > > | > | > > | > | | < > > | > > > > | > | | < < < < < < < < | < < | | < | | > | > | | > > < > > | > > > > > > > | | < > > > | > > > > | < | | | > | | | > > > | < < > | < < < | < < > > > > > > > > > | < | > | > > > | > > > > > > > > > > > | > > > > > > | | | | | | | | | | | < < < | < | | | | | | | | | | | | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | < | | | | < | > > > > > > > > > > > > > > > > > > > > > > | | | | | | > > > > > > > > | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | > > > > > > > | | | > | > > < < < < < < < < < < < < < < < < | < < < < < < < < < | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < < < | < | | < < > > > > | | | | | | < | | | < | | | | | | < | < | | | | | | | | | | | | | | | | | < < < < < < < | | | | | | | | | | | | < | | | | | | | | | | | | | | < | | | | | | < > | | > | > > > > > | > > > | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | < > | | > | > > > > > | > > > | | | | | | | | | | | | | | | | | | | < | < < < < < | > | | > | > > > | > > | | < < < < < < | < < < < | < < < < < | < < < | > > > > > > > | | > | | | | | > > > > > > > > | | < < < < < < < < | > | < > | < < | | < | > | > > | | < < < < < > | > > > > | > > > > > > | < > > > | < < < < < < < < < | > > | > > | < | | > > > > > | > > > | < < < < < > > | | < | < < < < < < < < < < < < | < < | | < | < > > > | < > > > | < < > < > > > | > > > | > > > > | > | < | < < < | < | | < < | > | > > | > | > > | | > > > > | | > > | < < | | < > | | > > > > > > > | < < < < < < > | < < < | | < > | < > | < | | < | < < < < < < | > > > > > > | > | > > | | | < | > > > > | < < < < | < > > | < < < < | < < < < < | | | | | > > > > > | > > | > > > | > > > | > > > | | < < | < < < | < < | < | > > | | < | < < < < > | < | | | < < | > > > | > > > > | < > | < > | < > > | < | | | > > > < < < | | > | > > > > > | < | > | | < < < < < < > | < | > | > > | > | < < | > | | < < | | < > | < > | > | < < | | | | | | | | | > | > | > | | | > > | | < | > | < < < < < < > > | | < | > > | < < < | | < < < < < | < < | < > > | < | | > | < | < < < < < > > > > > > > > > > > > > > > > > > | > > > | < | > | | < < < < < < < < < | < | < > > | > | | | | < | > > | | > > | > | | < < < | | < > | > > > > > > > > | < < < < < < < > > > | | | < | < | | | | | | | | | | | < | | | | | | | | | | | | | < | < | | | | | < > | > | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 | if (*pc == INST_LIST_NOT_IN) { found = !found; } TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), found)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. * We're saving the effort of pushing a boolean value only to pop it * for branching. */ pc++; #ifndef TCL_COMPILE_DEBUG switch (*pc) { case INST_JUMP_FALSE1: NEXT_INST_F((found ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); case INST_JUMP_TRUE1: NEXT_INST_F((found ? TclGetInt1AtPtr(pc+1) : 2), 2, 0); case INST_JUMP_FALSE4: NEXT_INST_F((found ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); case INST_JUMP_TRUE4: NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0); } #endif objResultPtr = eePtr->constants[found]; NEXT_INST_F(0, 2, 1); } /* * End of INST_LIST and related instructions. * --------------------------------------------------------- */ case INST_STR_EQ: case INST_STR_NEQ: { /* * String (in)equality check * TODO: Consider merging into INST_STR_CMP */ int iResult; Tcl_Obj *valuePtr, *value2Ptr; value2Ptr = *tosPtr; valuePtr = *(tosPtr - 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 = eePtr->constants[iResult]; NEXT_INST_F(0, 2, 1); } case INST_STR_CMP: { /* * String compare */ CONST char *s1, *s2; int s1len, s2len, iResult; Tcl_Obj *valuePtr, *value2Ptr; stringCompare: value2Ptr = *tosPtr; valuePtr = *(tosPtr - 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. If the char length == byte length, we can do a * memcmp. In benchmark testing this proved the most efficient * check between the unicode and string comparison operations. */ s1len = Tcl_GetCharLength(valuePtr); s2len = Tcl_GetCharLength(value2Ptr); if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) { iResult = memcmp(valuePtr->bytes, value2Ptr->bytes, (unsigned) ((s1len < s2len) ? s1len : s2len)); } else { iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr), Tcl_GetUnicode(value2Ptr), (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 * TODO: consider peephole opt. */ if (iResult == 0) { iResult = s1len - s2len; } if (*pc != INST_STR_CMP) { /* Take care of the opcodes that goto'ed into here */ switch (*pc) { case INST_EQ: iResult = (iResult == 0); break; case INST_NEQ: iResult = (iResult != 0); break; case INST_LT: iResult = (iResult < 0); break; case INST_GT: iResult = (iResult > 0); break; case INST_LE: iResult = (iResult <= 0); break; case INST_GE: iResult = (iResult >= 0); break; } } if (iResult < 0) { TclNewIntObj(objResultPtr, -1); TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), -1)); } else { objResultPtr = eePtr->constants[(iResult>0)]; TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), (iResult > 0))); } NEXT_INST_F(1, 2, 1); } case INST_STR_LEN: { int length; Tcl_Obj *valuePtr; valuePtr = *tosPtr; if (valuePtr->typePtr == &tclByteArrayType) { (void) Tcl_GetByteArrayFromObj(valuePtr, &length); } else { length = Tcl_GetCharLength(valuePtr); } TclNewIntObj(objResultPtr, length); TRACE(("%.20s => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); } case INST_STR_INDEX: { /* * String compare */ int index, length; char *bytes; Tcl_Obj *valuePtr, *value2Ptr; bytes = NULL; /* lint */ value2Ptr = *tosPtr; valuePtr = *(tosPtr - 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 if (valuePtr->bytes && length == valuePtr->length) { objResultPtr = Tcl_NewStringObj((CONST char *) (&valuePtr->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; Tcl_Obj *valuePtr, *value2Ptr; nocase = TclGetInt1AtPtr(pc+1); valuePtr = *tosPtr; /* String */ value2Ptr = *(tosPtr - 1); /* Pattern */ /* * Check that at least one of the objects is Unicode before promoting * both. */ if ((valuePtr->typePtr == &tclStringType) || (value2Ptr->typePtr == &tclStringType)) { Tcl_UniChar *ustring1, *ustring2; int length1, length2; ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1); ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); match = TclUniCharMatch(ustring1, length1, ustring2, length2, 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 * TODO: consider peephole opt. */ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); objResultPtr = eePtr->constants[match]; NEXT_INST_F(2, 2, 1); } case INST_EQ: case INST_NEQ: case INST_LT: case INST_GT: case INST_LE: case INST_GE: { Tcl_Obj *valuePtr = *(tosPtr - 1); Tcl_Obj *value2Ptr = *tosPtr; ClientData ptr1, ptr2; int iResult, compare, type1, type2; double d1, d2, tmp; long l1, l2; Tcl_WideInt w1, w2; mp_int big1, big2; if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { /* At least one non-numeric argument - compare as strings */ goto stringCompare; } if (type1 == TCL_NUMBER_NAN) { /* NaN first arg: NaN != to everything, other compares are false */ iResult = (*pc == INST_NEQ); goto foundResult; } if (valuePtr == value2Ptr) { compare = MP_EQ; goto convertComparison; } if (GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) { /* At least one non-numeric argument - compare as strings */ goto stringCompare; } if (type2 == TCL_NUMBER_NAN) { /* NaN 2nd arg: NaN != to everything, other compares are false */ iResult = (*pc == INST_NEQ); goto foundResult; } switch (type1) { case TCL_NUMBER_LONG: l1 = *((CONST long *)ptr1); switch (type2) { case TCL_NUMBER_LONG: l2 = *((CONST long *)ptr2); longCompare: compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); break; #ifndef NO_WIDE_TYPE case TCL_NUMBER_WIDE: w2 = *((CONST Tcl_WideInt *)ptr2); w1 = (Tcl_WideInt)l1; goto wideCompare; #endif case TCL_NUMBER_DOUBLE: d2 = *((CONST double *)ptr2); d1 = (double) l1; /* * If the double has a fractional part, or if the * long can be converted to double without loss of * precision, then compare as doubles. */ if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) || (l1 == (long) d1) || (modf(d2, &tmp) != 0.0)) { goto doubleCompare; } /* * Otherwise, to make comparision based on full precision, * need to convert the double to a suitably sized integer. * * Need this to get comparsions like * expr 20000000000000003 < 20000000000000004.0 * right. Converting the first argument to double * will yield two double values that are equivalent * within double precision. Converting the double to * an integer gets done exactly, then integer comparison * can tell the difference. */ if (d2 < (double)LONG_MIN) { compare = MP_GT; break; } if (d2 > (double)LONG_MAX) { compare = MP_LT; break; } l2 = (long) d2; goto longCompare; case TCL_NUMBER_BIG: if (Tcl_IsShared(value2Ptr)) { Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); } else { Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); } if (mp_cmp_d(&big2, 0) == MP_LT) { compare = MP_GT; } else { compare = MP_LT; } mp_clear(&big2); } break; #ifndef NO_WIDE_TYPE case TCL_NUMBER_WIDE: w1 = *((CONST Tcl_WideInt *)ptr1); switch (type2) { case TCL_NUMBER_WIDE: w2 = *((CONST Tcl_WideInt *)ptr2); wideCompare: compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); break; case TCL_NUMBER_LONG: l2 = *((CONST long *)ptr2); w2 = (Tcl_WideInt)l2; goto wideCompare; case TCL_NUMBER_DOUBLE: d2 = *((CONST double *)ptr2); d1 = (double) w1; if ((DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)) || (w1 == (Tcl_WideInt) d1) || (modf(d2, &tmp) != 0.0)) { goto doubleCompare; } if (d2 < (double)LLONG_MIN) { compare = MP_GT; break; } if (d2 > (double)LLONG_MAX) { compare = MP_LT; break; } w2 = (Tcl_WideInt) d2; goto wideCompare; case TCL_NUMBER_BIG: if (Tcl_IsShared(value2Ptr)) { Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); } else { Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); } if (mp_cmp_d(&big2, 0) == MP_LT) { compare = MP_GT; } else { compare = MP_LT; } mp_clear(&big2); } break; #endif case TCL_NUMBER_DOUBLE: d1 = *((CONST double *)ptr1); switch (type2) { case TCL_NUMBER_DOUBLE: d2 = *((CONST double *)ptr2); doubleCompare: compare = (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); break; case TCL_NUMBER_LONG: l2 = *((CONST long *)ptr2); d2 = (double) l2; if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) || (l2 == (long) d2) || (modf(d1, &tmp) != 0.0)) { goto doubleCompare; } if (d1 < (double)LONG_MIN) { compare = MP_LT; break; } if (d1 > (double)LONG_MAX) { compare = MP_GT; break; } l1 = (long) d1; goto longCompare; #ifndef NO_WIDE_TYPE case TCL_NUMBER_WIDE: w2 = *((CONST Tcl_WideInt *)ptr2); d2 = (double) w2; if ((DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)) || (w2 == (Tcl_WideInt) d2) || (modf(d1, &tmp) != 0.0)) { goto doubleCompare; } if (d1 < (double)LLONG_MIN) { compare = MP_LT; break; } if (d1 > (double)LLONG_MAX) { compare = MP_GT; break; } w1 = (Tcl_WideInt) d1; goto wideCompare; #endif case TCL_NUMBER_BIG: if (TclIsInfinite(d1)) { compare = (d1 > 0.0) ? MP_GT : MP_LT; break; } if (Tcl_IsShared(value2Ptr)) { Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); } else { Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); } if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { if (mp_cmp_d(&big2, 0) == MP_LT) { compare = MP_GT; } else { compare = MP_LT; } mp_clear(&big2); break; } if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) && (modf(d1, &tmp) != 0.0)) { d2 = TclBignumToDouble( &big2); mp_clear(&big2); goto doubleCompare; } TclInitBignumFromDouble(NULL, d1, &big1); goto bigCompare; } break; case TCL_NUMBER_BIG: if (Tcl_IsShared(valuePtr)) { Tcl_GetBignumFromObj(NULL, valuePtr, &big1); } else { Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1); } switch (type2) { #ifndef NO_WIDE_TYPE case TCL_NUMBER_WIDE: #endif case TCL_NUMBER_LONG: compare = mp_cmp_d(&big1, 0); mp_clear(&big1); break; case TCL_NUMBER_DOUBLE: d2 = *((CONST double *)ptr2); if (TclIsInfinite(d2)) { compare = (d2 > 0.0) ? MP_LT : MP_GT; mp_clear(&big1); break; } if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { compare = mp_cmp_d(&big1, 0); mp_clear(&big1); break; } if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) && (modf(d2, &tmp) != 0.0)) { d1 = TclBignumToDouble( &big1); mp_clear(&big1); goto doubleCompare; } TclInitBignumFromDouble(NULL, d2, &big2); goto bigCompare; case TCL_NUMBER_BIG: if (Tcl_IsShared(value2Ptr)) { Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); } else { Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); } bigCompare: compare = mp_cmp(&big1, &big2); mp_clear(&big1); mp_clear(&big2); } } /* Turn comparison outcome into appropriate result for opcode */ convertComparison: switch (*pc) { case INST_EQ: iResult = (compare == MP_EQ); break; case INST_NEQ: iResult = (compare != MP_EQ); break; case INST_LT: iResult = (compare == MP_LT); break; case INST_GT: iResult = (compare == MP_GT); break; case INST_LE: iResult = (compare != MP_GT); break; case INST_GE: iResult = (compare != MP_LT); break; } /* * Peep-hole optimisation: if you're about to jump, do jump from here. */ foundResult: 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 = eePtr->constants[iResult]; NEXT_INST_F(0, 2, 1); } case INST_LSHIFT: case INST_RSHIFT: { Tcl_Obj *value2Ptr = *tosPtr; Tcl_Obj *valuePtr = *(tosPtr - 1); ClientData ptr1, ptr2; int invalid, shift, type1, type2; long l; result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); if ((result != TCL_OK) || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { result = TCL_ERROR; TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); if ((result != TCL_OK) || (type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) { result = TCL_ERROR; TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, value2Ptr); goto checkForCatch; } /* reject negative shift argument */ switch (type2) { case TCL_NUMBER_LONG: invalid = (*((CONST long *)ptr2) < (long)0); break; #ifndef NO_WIDE_TYPE case TCL_NUMBER_WIDE: invalid = (*((CONST Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); break; #endif case TCL_NUMBER_BIG: /* TODO: const correctness ? */ invalid = (mp_cmp_d((mp_int *)ptr2, 0) == MP_LT); } if (invalid) { Tcl_SetObjResult(interp, Tcl_NewStringObj("negative shift argument", -1)); result = TCL_ERROR; goto checkForCatch; } /* Zero shifted any number of bits is still zero */ if ((type1 == TCL_NUMBER_LONG) && (*((CONST long *)ptr1) == (long)0)) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = eePtr->constants[0]; TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } if (*pc == INST_LSHIFT) { /* Large left shifts create integer overflow */ result = Tcl_GetIntFromObj(NULL, value2Ptr, &shift); if (result != TCL_OK) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) * in an mp_int, but since we're using mp_mul_2d() to do the * work, and it takes only an int argument, that's a good * place to draw the line. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); goto checkForCatch; } /* Handle shifts within the native long range */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if ((type1 == TCL_NUMBER_LONG) && (shift < CHAR_BIT*sizeof(long)) && (l = *((CONST long *)ptr1)) && !(((l>0) ? l : ~l) & -(1<<(CHAR_BIT*sizeof(long)-1-shift)))) { TclNewLongObj(objResultPtr, (l<<shift)); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } /* Handle shifts within the native wide range */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if ((type1 != TCL_NUMBER_BIG) && (shift < CHAR_BIT*sizeof(Tcl_WideInt))) { Tcl_WideInt w; TclGetWideIntFromObj(NULL, valuePtr, &w); if (!(((w>0) ? w : ~w) & -(((Tcl_WideInt)1) <<(CHAR_BIT*sizeof(Tcl_WideInt)-1-shift)))) { objResultPtr = Tcl_NewWideIntObj(w<<shift); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } } /* if ((type1 == TCL_NUMBER_LONG) && (shift < CHAR_BIT*sizeof(long)) && (l = *((CONST long *)ptr1)) && !(((l>0) ? l : ~l) & -(1<<(CHAR_BIT*sizeof(long)-1-shift)))) { TclNewLongObj(objResultPtr, (l<<shift)); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } */ } else { /* Quickly force large right shifts to 0 or -1 */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if ((type2 != TCL_NUMBER_LONG) || ( *((CONST long *)ptr2) > INT_MAX)) { /* * Again, technically, the value to be shifted could * be an mp_int so huge that a right shift by (INT_MAX+1) * bits could not take us to the result of 0 or -1, but * since we're using mp_div_2d to do the work, and it * takes only an int argument, we draw the line there. */ int zero; switch (type1) { case TCL_NUMBER_LONG: zero = (*((CONST long *)ptr1) > (long)0); break; #ifndef NO_WIDE_TYPE case TCL_NUMBER_WIDE: zero = (*((CONST Tcl_WideInt *)ptr1) > (Tcl_WideInt)0); break; #endif case TCL_NUMBER_BIG: /* TODO: const correctness ? */ zero = (mp_cmp_d((mp_int *)ptr1, 0) == MP_GT); } if (zero) { objResultPtr = eePtr->constants[0]; } else { TclNewIntObj(objResultPtr, -1); } TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } shift = (int)(*((CONST long *)ptr2)); /* Handle shifts within the native long range */ if (type1 == TCL_NUMBER_LONG) { long l = *((CONST long *)ptr1); if (shift >= CHAR_BIT*sizeof(long)) { if (l >= (long)0) { objResultPtr = eePtr->constants[0]; } else { TclNewIntObj(objResultPtr, -1); } } else { TclNewLongObj(objResultPtr, (l >> shift)); } TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } #ifndef NO_WIDE_TYPE /* Handle shifts within the native wide range */ if (type1 == TCL_NUMBER_WIDE) { Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr1); if (shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { if (w >= (Tcl_WideInt)0) { objResultPtr = eePtr->constants[0]; } else { TclNewIntObj(objResultPtr, -1); } } else { objResultPtr = Tcl_NewWideIntObj(w >> shift); } TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } #endif } { mp_int big, bigResult, bigRemainder; if (Tcl_IsShared(valuePtr)) { Tcl_GetBignumFromObj(NULL, valuePtr, &big); } else { Tcl_GetBignumAndClearObj(NULL, valuePtr, &big); } mp_init(&bigResult); if (*pc == INST_LSHIFT) { mp_mul_2d(&big, shift, &bigResult); } else { mp_init(&bigRemainder); mp_div_2d(&big, shift, &bigResult, &bigRemainder); if (mp_cmp_d(&bigRemainder, 0) == MP_LT) { /* Convert to Tcl's integer division rules */ mp_sub_d(&bigResult, 1, &bigResult); } mp_clear(&bigRemainder); } mp_clear(&big); if (!Tcl_IsShared(valuePtr)) { Tcl_SetBignumObj(valuePtr, &bigResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } objResultPtr = Tcl_NewBignumObj(&bigResult); } TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } case INST_BITOR: case INST_BITXOR: case INST_BITAND: { ClientData ptr1, ptr2; int type1, type2; Tcl_Obj *value2Ptr = *tosPtr; Tcl_Obj *valuePtr = *(tosPtr - 1); result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); if ((result != TCL_OK) || (type1 == TCL_NUMBER_NAN) || (type1 == TCL_NUMBER_DOUBLE)) { result = TCL_ERROR; TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); if ((result != TCL_OK) || (type2 == TCL_NUMBER_NAN) || (type2 == TCL_NUMBER_DOUBLE)) { result = TCL_ERROR; TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, value2Ptr); goto checkForCatch; } if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { mp_int big1, big2, bigResult; mp_int *Pos, *Neg, *Other; int numPos = 0; if (Tcl_IsShared(valuePtr)) { Tcl_GetBignumFromObj(NULL, valuePtr, &big1); } else { Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1); } if (Tcl_IsShared(value2Ptr)) { Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); } else { Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); } if (mp_cmp_d(&big1, 0) != MP_LT) { numPos++; Pos = &big1; if (mp_cmp_d(&big2, 0) != MP_LT) { numPos++; Other = &big2; } else { Neg = &big2; } } else { Neg = &big1; if (mp_cmp_d(&big2, 0) != MP_LT) { numPos++; Pos = &big2; } else { Other = &big2; } } mp_init(&bigResult); switch (*pc) { case INST_BITAND: switch (numPos) { case 2: /* Both arguments positive, base case */ mp_and(Pos, Other, &bigResult); break; case 1: /* One arg positive; one negative * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1)) */ mp_neg(Neg, Neg); mp_sub_d(Neg, 1, Neg); mp_xor(Pos, Neg, &bigResult); mp_and(Pos, &bigResult, &bigResult); break; case 0: /* Both arguments negative * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1 */ mp_neg(Neg, Neg); mp_sub_d(Neg, 1, Neg); mp_neg(Other, Other); mp_sub_d(Other, 1, Other); mp_or(Neg, Other, &bigResult); mp_neg(&bigResult, &bigResult); mp_sub_d(&bigResult, 1, &bigResult); break; } break; case INST_BITOR: switch (numPos) { case 2: /* Both arguments positive, base case */ mp_or(Pos, Other, &bigResult); break; case 1: /* One arg positive; one negative * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1 */ mp_neg(Neg, Neg); mp_sub_d(Neg, 1, Neg); mp_xor(Pos, Neg, &bigResult); mp_and(Neg, &bigResult, &bigResult); mp_neg(&bigResult, &bigResult); mp_sub_d(&bigResult, 1, &bigResult); break; case 0: /* Both arguments negative * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1 */ mp_neg(Neg, Neg); mp_sub_d(Neg, 1, Neg); mp_neg(Other, Other); mp_sub_d(Other, 1, Other); mp_and(Neg, Other, &bigResult); mp_neg(&bigResult, &bigResult); mp_sub_d(&bigResult, 1, &bigResult); break; } break; case INST_BITXOR: switch (numPos) { case 2: /* Both arguments positive, base case */ mp_xor(Pos, Other, &bigResult); break; case 1: /* One arg positive; one negative * P^N = ~(P^~N) = -(P^(-N-1))-1 */ mp_neg(Neg, Neg); mp_sub_d(Neg, 1, Neg); mp_xor(Pos, Neg, &bigResult); mp_neg(&bigResult, &bigResult); mp_sub_d(&bigResult, 1, &bigResult); break; case 0: /* Both arguments negative * a ^ b = (~a ^ ~b) = (-a-1^-b-1) */ mp_neg(Neg, Neg); mp_sub_d(Neg, 1, Neg); mp_neg(Other, Other); mp_sub_d(Other, 1, Other); mp_xor(Neg, Other, &bigResult); break; } break; } mp_clear(&big1); mp_clear(&big2); TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewBignumObj(&bigResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } Tcl_SetBignumObj(valuePtr, &bigResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } #ifndef NO_WIDE_TYPE if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { Tcl_WideInt wResult, w1, w2; TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); switch (*pc) { case INST_BITAND: wResult = w1 & w2; break; case INST_BITOR: wResult = w1 | w2; break; case INST_BITXOR: wResult = w1 ^ w2; } TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewWideIntObj(wResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } Tcl_SetWideIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } #endif { long lResult, l1 = *((CONST long *)ptr1); long l2 = *((CONST long *)ptr2); switch (*pc) { case INST_BITAND: lResult = l1 & l2; break; case INST_BITOR: lResult = l1 | l2; break; case INST_BITXOR: lResult = l1 ^ l2; } TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, lResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } TclSetLongObj(valuePtr, lResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } } #if 0 case INST_MOD: { /* * Only integers are allowed. We compute value op value2. */ long i = 0, i2 = 0, rem, neg_divisor = 0; long iResult = 0; /* Init. avoids compiler warning. */ Tcl_WideInt w, w2, wResult = W0; int doWide = 0; Tcl_Obj *valuePtr, *value2Ptr; value2Ptr = *tosPtr; valuePtr = *(tosPtr - 1); if (valuePtr->typePtr == &tclIntType) { i = valuePtr->internalRep.longValue; } else if (valuePtr->typePtr == &tclWideIntType) { TclGetWide(w,valuePtr); } else { /* try to convert to int */ REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); if (result != TCL_OK) { TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } } if (value2Ptr->typePtr == &tclIntType) { i2 = value2Ptr->internalRep.longValue; } else if (value2Ptr->typePtr == &tclWideIntType) { TclGetWide(w2,value2Ptr); } else { REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2); if (result != TCL_OK) { TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, value2Ptr); goto checkForCatch; } } do { /* * This code is tricky: C doesn't guarantee much about the * quotient or remainder, and results with a negative divisor are * not specified. Tcl guarantees that the remainder will have the * same sign as the divisor and a smaller absolute value. */ if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) { if (valuePtr->typePtr == &tclIntType) { TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2)); } else { TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); } goto divideByZero; } if (value2Ptr->typePtr == &tclIntType && i2 == 0) { if (valuePtr->typePtr == &tclIntType) { TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); } else { TRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2)); } goto divideByZero; } 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 ( w == LLONG_MIN && w2 == -1 ) { /* Integer overflow could happen with (LLONG_MIN % -1) * even though it is not possible in the code below. */ wRemainder = 0; } else if ( w == LLONG_MIN && w2 == LLONG_MAX ) { wRemainder = LLONG_MAX - 1; } else if ( w2 == LLONG_MIN ) { /* * In C, a modulus operation is not well defined when the * divisor is a negative number. So w % LLONG_MIN is not * well defined in the code below because -LLONG_MIN is * still a negative number. */ if (w == 0 || w == LLONG_MIN) { wRemainder = 0; } else if (w < 0) { wRemainder = w; } else { wRemainder = LLONG_MIN + w; } neg_divisor = 1; } else { if (w2 < 0) { w2 = -w2; w = -w; /* Note: -LLONG_MIN == LLONG_MIN */ neg_divisor = 1; } wRemainder = w % w2; /* * remainder is (remainder + divisor) when the remainder * is negative. Watch out for the special case of a * LLONG_MIN dividend and a negative divisor. Don't add * the divisor in that case because the remainder should * not be negative. */ if (wRemainder < 0 && !(neg_divisor && (w == LLONG_MIN))) { wRemainder += w2; } } if ((neg_divisor && (wRemainder > 0)) || (!neg_divisor && (wRemainder < 0))) { wRemainder = -wRemainder; } wResult = wRemainder; doWide = 1; break; } if ( i == LONG_MIN && i2 == -1 ) { /* * Integer overflow could happen with (LONG_MIN % -1) even * though it is not possible in the code below. */ rem = 0; } else if ( i == LONG_MIN && i2 == LONG_MAX ) { rem = LONG_MAX - 1; } else if ( i2 == LONG_MIN ) { /* * In C, a modulus operation is not well defined when the * divisor is a negative number. So i % LONG_MIN is not well * defined in the code below because -LONG_MIN is still a * negative number. */ if (i == 0 || i == LONG_MIN) { rem = 0; } else if (i < 0) { rem = i; } else { rem = LONG_MIN + i; } neg_divisor = 1; } else { if (i2 < 0) { i2 = -i2; i = -i; /* Note: -LONG_MIN == LONG_MIN */ neg_divisor = 1; } rem = i % i2; /* * remainder is (remainder + divisor) when the remainder is * negative. Watch out for the special case of a LONG_MIN * dividend and a negative divisor. Don't add the divisor in * that case because the remainder should not be negative. */ if (rem < 0 && !(neg_divisor && (i == LONG_MIN))) { rem += i2; } } if ((neg_divisor && (rem > 0)) || (!neg_divisor && (rem < 0))) { rem = -rem; } iResult = rem; } while (0); /* * Reuse the valuePtr object already on stack if possible. */ if (Tcl_IsShared(valuePtr)) { if (doWide) { TclNewWideIntObj(objResultPtr, wResult); TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); } else { TclNewLongObj(objResultPtr, iResult); TRACE(("%ld %ld => %ld\n", i, i2, iResult)); } NEXT_INST_F(1, 2, 1); } else { /* reuse the valuePtr object */ if (doWide) { TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); TclSetWideIntObj(valuePtr, wResult); } else { TRACE(("%ld %ld => %ld\n", i, i2, iResult)); TclSetLongObj(valuePtr, iResult); } NEXT_INST_F(1, 1, 0); } } #endif case INST_ADD: case INST_SUB: case INST_DIV: case INST_MULT: { ClientData ptr1, ptr2; int type1, type2; Tcl_Obj *value2Ptr = *tosPtr; Tcl_Obj *valuePtr = *(tosPtr - 1); result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); if ((result != TCL_OK) #ifndef ACCEPT_NAN || (type1 == TCL_NUMBER_NAN) #endif ) { result = TCL_ERROR; TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } #ifdef ACCEPT_NAN if (type1 == TCL_NUMBER_NAN) { /* NaN first argument -> result is also NaN */ NEXT_INST_F(1, 1, 0); } #endif result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); if ((result != TCL_OK) #ifndef ACCEPT_NAN || (type2 == TCL_NUMBER_NAN) #endif ) { result = TCL_ERROR; TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); IllegalExprOperandType(interp, pc, value2Ptr); goto checkForCatch; } #ifdef ACCEPT_NAN if (type2 == TCL_NUMBER_NAN) { /* NaN second argument -> result is also NaN */ objResultPtr = value2Ptr; NEXT_INST_F(1, 2, 1); } #endif if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { /* At least one of the values is floating-point, so perform * floating point calculations */ double d1, d2, dResult; Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); 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: #ifndef IEEE_FLOATING_POINT if (d2 == 0.0) { TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); goto divideByZero; } #endif /* * We presume that we are running with zero-divide unmasked if * we're on an IEEE box. Otherwise, this statement might cause * demons to fly out our noses. */ dResult = d1 / d2; break; } #ifndef ACCEPT_NAN /* * Check now for IEEE floating-point error. */ if (TclIsNaN(dResult)) { TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", O2S(valuePtr), O2S(value2Ptr))); TclExprFloatError(interp, dResult); result = TCL_ERROR; goto checkForCatch; } #endif TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { TclNewDoubleObj(objResultPtr, dResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } TclSetDoubleObj(valuePtr, dResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } if ((*pc == INST_MULT) && (sizeof(Tcl_WideInt) >= 2*sizeof(long)) && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { Tcl_WideInt w1, w2, wResult; TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); wResult = w1 * w2; TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewWideIntObj(wResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } Tcl_SetWideIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } if ((*pc != INST_MULT) && (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, wResult; TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); switch (*pc) { case INST_ADD: wResult = w1 + w2; #ifndef NO_WIDE_TYPE if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) #endif { /* Check for overflow */ if (((w1 < 0) && (w2 < 0) && (wResult > 0)) || ((w1 > 0) && (w2 > 0) && (wResult < 0))) { goto overflow; } } break; case INST_SUB: wResult = w1 - w2; #ifndef NO_WIDE_TYPE if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) #endif { /* Must check for overflow */ if (((w1 < 0) && (w2 > 0) && (wResult > 0)) || ((w1 > 0) && (w2 < 0) && (wResult < 0))) { goto overflow; } } break; case INST_DIV: if (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; } /* Need a bignum to represent (LLONG_MIN / -1) */ if ((w1 == LLONG_MIN) && (w2 == -1)) { goto overflow; } wResult = w1 / w2; /* Force Tcl's integer division rules */ /* TODO: examine for logic simplification */ if (((wResult < 0) || ((wResult == 0) && ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && ((wResult * w2) != w1)) { wResult -= 1; } break; } TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewWideIntObj(wResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } Tcl_SetWideIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } overflow: { mp_int big1, big2, bigResult, bigRemainder; TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { Tcl_GetBignumFromObj(NULL, valuePtr, &big1); } else { Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1); } if (Tcl_IsShared(value2Ptr)) { Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); } else { Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); } mp_init(&bigResult); switch (*pc) { case INST_ADD: mp_add(&big1, &big2, &bigResult); break; case INST_SUB: mp_sub(&big1, &big2, &bigResult); break; case INST_MULT: mp_mul(&big1, &big2, &bigResult); break; case INST_DIV: if (mp_iszero(&big2)) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); mp_clear(&big1); mp_clear(&big2); goto divideByZero; } mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); /* TODO: internals intrusion */ if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { /* Convert to Tcl's integer division rules */ mp_sub_d(&bigResult, 1, &bigResult); mp_add(&bigRemainder, &big2, &bigRemainder); } if (*pc == INST_MOD) { mp_copy(&bigRemainder, &bigResult); } mp_clear(&bigRemainder); break; } mp_clear(&big1); mp_clear(&big2); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewBignumObj(&bigResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } Tcl_SetBignumObj(valuePtr, &bigResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } } case INST_MOD: case INST_EXPON: { /* * Operands must be numeric and ints get converted to floats if * necessary. We compute value op value2. */ double d1, d2; double dResult = 0.0; /* Init. avoids compiler warning. */ Tcl_Obj *valuePtr,*value2Ptr; #if 0 Tcl_ObjType *t1Ptr, *t2Ptr; long i = 0, i2 = 0, quot; /* Init. avoids compiler warning. */ long iResult = 0; /* Init. avoids compiler warning. */ int doDouble = 0; /* 1 if doing floating arithmetic */ Tcl_WideInt w, w2, wquot; Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */ int doWide = 0; /* 1 if doing wide arithmetic. */ int length; value2Ptr = *tosPtr; valuePtr = *(tosPtr - 1); t1Ptr = valuePtr->typePtr; t2Ptr = value2Ptr->typePtr; if (t1Ptr == &tclIntType) { i = valuePtr->internalRep.longValue; } else if (t1Ptr == &tclWideIntType) { TclGetWide(w,valuePtr); } else if ((t1Ptr == &tclDoubleType) && (valuePtr->bytes == NULL)) { /* * We can only use the internal rep directly if there is no string * rep. Otherwise the string rep might actually look like an * integer, which is preferred. */ 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; } else if (t2Ptr == &tclWideIntType) { TclGetWide(w2,value2Ptr); } else if ((t2Ptr == &tclDoubleType) && (value2Ptr->bytes == NULL)) { /* * We can only use the internal rep directly if there is no string * rep. Otherwise the string rep might actually look like an * integer, which is preferred. */ 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 */ } else if (t1Ptr == &tclWideIntType) { d1 = Tcl_WideAsDouble(w); } else if (t2Ptr == &tclWideIntType) { d2 = Tcl_WideAsDouble(w2); } switch (*pc) { case INST_ADD: dResult = d1 + d2; break; case INST_SUB: dResult = d1 - d2; break; case INST_MULT: dResult = d1 * d2; break; case INST_EXPON: if (d1==0.0 && d2<0.0) { TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2)); goto exponOfZero; } dResult = pow(d1, d2); break; } /* * Check now for IEEE floating-point error. */ if (IS_NAN(dResult)) { TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", O2S(valuePtr), O2S(value2Ptr))); TclExprFloatError(interp, dResult); result = TCL_ERROR; goto checkForCatch; } } 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: /* * When performing integer division, protect against integer * overflow. Round towards zero when the quotient is positive, * otherwise round towards -Infinity. */ if (w2 == W0) { TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); goto divideByZero; } if (w == LLONG_MIN && w2 == -1) { /* Avoid integer overflow on (LLONG_MIN / -1) */ wquot = LLONG_MIN; } else { wquot = w / w2; /* * Round down to a smaller negative number if there is a * remainder and the quotient is negative or zero and the * signs don't match. Note that we don't use a modulus to * find the remainder since it is not well defined in C * when the divisor is negative. */ if (((wquot < 0) || ((wquot == 0) && ((w < 0 && w2 > 0) || (w > 0 && w2 < 0)))) && ((wquot * w2) != w)) { wquot -= 1; } } wResult = wquot; break; case INST_EXPON: { int errExpon; wResult = ExponWide(w, w2, &errExpon); if (errExpon) { TRACE((LLD" "LLD" => EXPONENT OF ZERO\n", w, w2)); goto exponOfZero; } break; } } } 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: /* * When performing integer division, protect against integer * overflow. Round towards zero when the quotient is positive, * otherwise round towards -Infinity. */ if (i2 == 0) { TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); goto divideByZero; } if (i == LONG_MIN && i2 == -1) { /* Avoid integer overflow on (LONG_MIN / -1) */ quot = LONG_MIN; } else { quot = i / i2; /* * Round down to a smaller negative number if there is a * remainder and the quotient is negative or zero and the * signs don't match. Note that we don't use a modulus to * find the remainder since it is not well defined in C * when the divisor is negative. */ if (((quot < 0) || ((quot == 0) && ((i<0 && i2>0) || (i>0 && i2<0)))) && ((quot * i2) != i)) { quot -= 1; } } iResult = quot; break; case INST_EXPON: { int errExpon; iResult = ExponLong(i, i2, &errExpon); if (errExpon) { TRACE(("%ld %ld => EXPONENT OF ZERO\n", i, i2)); goto exponOfZero; } break; } } } /* * Reuse the valuePtr object already on stack if possible. */ if (Tcl_IsShared(valuePtr)) { if (doDouble) { TclNewDoubleObj(objResultPtr, dResult); TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); } else if (doWide) { TclNewWideIntObj(objResultPtr, wResult); TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); } else { TclNewLongObj(objResultPtr, 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)); TclSetDoubleObj(valuePtr, dResult); } else if (doWide) { TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); TclSetWideIntObj(valuePtr, wResult); } else { TRACE(("%ld %ld => %ld\n", i, i2, iResult)); TclSetLongObj(valuePtr, iResult); } NEXT_INST_F(1, 1, 0); } #else value2Ptr = *tosPtr; valuePtr = *(tosPtr - 1); result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); if (result != TCL_OK) { #ifdef ACCEPT_NAN if (valuePtr->typePtr == &tclDoubleType) { /* NaN first argument -> result is also NaN */ result = TCL_OK; NEXT_INST_F(1, 1, 0); } #endif TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } result = Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); if (result != TCL_OK) { #ifdef ACCEPT_NAN if (value2Ptr->typePtr == &tclDoubleType) { /* NaN second argument -> result is also NaN */ objResultPtr = value2Ptr; result = TCL_OK; NEXT_INST_F(1, 2, 1); } #endif TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); IllegalExprOperandType(interp, pc, value2Ptr); goto checkForCatch; } if (valuePtr->typePtr == &tclDoubleType || value2Ptr->typePtr == &tclDoubleType) { /* At least one of the values is floating-point, so perform * floating point calculations */ switch (*pc) { case INST_EXPON: if (d1==0.0 && d2<0.0) { TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2)); goto exponOfZero; } dResult = pow(d1, d2); break; case INST_MOD: if (valuePtr->typePtr == &tclDoubleType) { TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); IllegalExprOperandType(interp, pc, valuePtr); } else { TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); IllegalExprOperandType(interp, pc, value2Ptr); } result = TCL_ERROR; goto checkForCatch; } #ifndef ACCEPT_NAN /* * Check now for IEEE floating-point error. */ if (TclIsNaN(dResult)) { TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", O2S(valuePtr), O2S(value2Ptr))); TclExprFloatError(interp, dResult); result = TCL_ERROR; goto checkForCatch; } #endif if (Tcl_IsShared(valuePtr)) { TclNewDoubleObj(objResultPtr, dResult); NEXT_INST_F(1, 2, 1); } TclSetDoubleObj(valuePtr, dResult); NEXT_INST_F(1, 1, 0); } else { /* Both values are some kind of integer */ /* TODO: optimize use of narrower native integers */ mp_int big1, big2, bigResult, bigRemainder; Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); mp_init(&bigResult); switch (*pc) { case INST_MOD: if (mp_iszero(&big2)) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); mp_clear(&big1); mp_clear(&big2); goto divideByZero; } mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { /* Convert to Tcl's integer division rules */ mp_sub_d(&bigResult, 1, &bigResult); mp_add(&bigRemainder, &big2, &bigRemainder); } if (*pc == INST_MOD) { mp_copy(&bigRemainder, &bigResult); } mp_clear(&bigRemainder); break; case INST_EXPON: if (mp_iszero(&big2)) { /* Anything to the zero power is 1 */ mp_clear(&big1); mp_clear(&big2); objResultPtr = eePtr->constants[1]; NEXT_INST_F(1, 2, 1); } if (mp_iszero(&big1)) { if (mp_cmp_d(&big2, 0) == MP_LT) { TRACE(("%s %s => EXPONENT OF ZERO\n", O2S(valuePtr), O2S(value2Ptr))); mp_clear(&big1); mp_clear(&big2); goto exponOfZero; } mp_clear(&big1); mp_clear(&big2); objResultPtr = eePtr->constants[0]; NEXT_INST_F(1, 2, 1); } if (mp_cmp_d(&big2, 0) == MP_LT) { switch (mp_cmp_d(&big1, 1)) { case MP_GT: objResultPtr = eePtr->constants[0]; break; case MP_EQ: objResultPtr = eePtr->constants[1]; break; case MP_LT: mp_add_d(&big1, 1, &big1); if (mp_cmp_d(&big1, 0) == MP_LT) { objResultPtr = eePtr->constants[0]; break; } mp_mod_2d(&big2, 1, &big2); if (mp_iszero(&big2)) { objResultPtr = eePtr->constants[1]; } else { TclNewIntObj(objResultPtr, -1); } } mp_clear(&big1); mp_clear(&big2); NEXT_INST_F(1, 2, 1); } if (big2.used > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("exponent too large", -1)); mp_clear(&big1); mp_clear(&big2); goto checkForCatch; } mp_expt_d(&big1, big2.dp[0], &bigResult); break; } mp_clear(&big1); mp_clear(&big2); TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewBignumObj(&bigResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } Tcl_SetBignumObj(valuePtr, &bigResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } #endif } case INST_LNOT: { int b; Tcl_Obj *valuePtr = *tosPtr; /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for eePtr->constants */ result = TclGetBooleanFromObj(NULL, valuePtr, &b); if (result != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } /* TODO: Consider peephole opt. */ objResultPtr = eePtr->constants[!b]; NEXT_INST_F(1, 1, 1); } case INST_BITNOT: { mp_int big; ClientData ptr; int type; Tcl_Obj *valuePtr = *tosPtr; result = GetNumberFromObj(NULL, valuePtr, &ptr, &type); if ((result != TCL_OK) || (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) { /* ... ~$NonInteger => raise an error */ result = TCL_ERROR; TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } if (type == TCL_NUMBER_LONG) { long l = *((CONST long *)ptr); if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, ~l); NEXT_INST_F(1, 1, 1); } TclSetLongObj(valuePtr, ~l); NEXT_INST_F(1, 0, 0); } #ifndef NO_WIDE_TYPE if (type == TCL_NUMBER_LONG) { Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewWideIntObj(~w); NEXT_INST_F(1, 1, 1); } Tcl_SetWideIntObj(valuePtr, ~w); NEXT_INST_F(1, 0, 0); } #endif if (Tcl_IsShared(valuePtr)) { Tcl_GetBignumFromObj(NULL, valuePtr, &big); } else { Tcl_GetBignumAndClearObj(NULL, valuePtr, &big); } /* ~a = - a - 1 */ mp_neg(&big, &big); mp_sub_d(&big, 1, &big); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewBignumObj(&big); NEXT_INST_F(1, 1, 1); } Tcl_SetBignumObj(valuePtr, &big); NEXT_INST_F(1, 0, 0); } case INST_UMINUS: { ClientData ptr; int type; Tcl_Obj *valuePtr = *tosPtr; result = GetNumberFromObj(NULL, valuePtr, &ptr, &type); if ((result != TCL_OK) #ifndef ACCEPT_NAN || (type == TCL_NUMBER_NAN) #endif ) { result = TCL_ERROR; TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } switch (type) { case TCL_NUMBER_DOUBLE: { double d; if (Tcl_IsShared(valuePtr)) { TclNewDoubleObj(objResultPtr, -(*((CONST double *)ptr))); NEXT_INST_F(1, 1, 1); } d = *((CONST double *)ptr); TclSetDoubleObj(valuePtr, -d); NEXT_INST_F(1, 0, 0); } case TCL_NUMBER_LONG: { long l = *((CONST long *)ptr); if (l != LONG_MIN) { if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, -l); NEXT_INST_F(1, 1, 1); } TclSetLongObj(valuePtr, -l); NEXT_INST_F(1, 0, 0); } /* FALLTHROUGH */ } #ifndef NO_WIDE_TYPE case TCL_NUMBER_WIDE: { Tcl_WideInt w; if (type == TCL_NUMBER_LONG) { w = (Tcl_WideInt)(*((CONST long *)ptr)); } else { w = *((CONST Tcl_WideInt *)ptr); } if (w != LLONG_MIN) { if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewWideIntObj(-w); NEXT_INST_F(1, 1, 1); } Tcl_SetWideIntObj(valuePtr, -w); NEXT_INST_F(1, 0, 0); } /* FALLTHROUGH */ } #endif case TCL_NUMBER_BIG: { mp_int big; switch (type) { #ifdef NO_WIDE_TYPE case TCL_NUMBER_LONG: TclBNInitBignumFromLong(&big, *((CONST long *)ptr)); break; #else case TCL_NUMBER_WIDE: TclBNInitBignumFromWideInt(&big, *((CONST Tcl_WideInt*)ptr)); break; #endif case TCL_NUMBER_BIG: if (Tcl_IsShared(valuePtr)) { Tcl_GetBignumFromObj(NULL, valuePtr, &big); } else { Tcl_GetBignumAndClearObj(NULL, valuePtr, &big); } } mp_neg(&big, &big); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewBignumObj(&big); NEXT_INST_F(1, 1, 1); } Tcl_SetBignumObj(valuePtr, &big); NEXT_INST_F(1, 0, 0); } case TCL_NUMBER_NAN: /* -NaN => NaN */ NEXT_INST_F(1, 0, 0); } } case INST_CALL_BUILTIN_FUNC1: { Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); } case INST_CALL_FUNC1: { Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found"); } case INST_UPLUS: case INST_TRY_CVT_TO_NUMERIC: { /* * Try to convert the topmost stack object to numeric object. * This is done in order to support [expr]'s policy of interpreting * operands if at all possible as numbers first, then strings. */ ClientData ptr; int type; Tcl_Obj *valuePtr = *tosPtr; if (GetNumberFromObj(NULL, valuePtr, &ptr, &type) != TCL_OK) { if (*pc == INST_UPLUS) { /* ... +$NonNumeric => raise an error */ result = TCL_ERROR; TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } else { /* ... TryConvertToNumeric($NonNumeric) is acceptable */ TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } } #ifndef ACCEPT_NAN if (type == TCL_NUMBER_NAN) { result = TCL_ERROR; if (*pc == INST_UPLUS) { /* ... +$NonNumeric => raise an error */ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); } else { /* Numeric conversion of NaN -> error */ TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", O2S(objResultPtr))); TclExprFloatError(interp, *((CONST double *)ptr)); } goto checkForCatch; } #endif /* * Ensure that the numeric value 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. */ if (valuePtr->bytes == NULL) { TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } if (Tcl_IsShared(valuePtr)) { /* * Here we do some surgery within the Tcl_Obj internals. * We want to copy the intrep, but not the string, so we * temporarily hide the string so we do not copy it. */ char *savedString = valuePtr->bytes; valuePtr->bytes = NULL; objResultPtr = Tcl_DuplicateObj(valuePtr); valuePtr->bytes = savedString; TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 1); } TclInvalidateStringRep(valuePtr); TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } case INST_BREAK: DECACHE_STACK_INFO(); Tcl_ResetResult(interp); CACHE_STACK_INFO(); result = TCL_BREAK; cleanup = 0; goto processExceptionReturn; case INST_CONTINUE: DECACHE_STACK_INFO(); Tcl_ResetResult(interp); CACHE_STACK_INFO(); result = TCL_CONTINUE; cleanup = 0; goto processExceptionReturn; case INST_FOREACH_START4: { /* * Initialize the temporary local var that holds the count of the * number of iterations of the loop body to -1. */ int opnd; ForeachInfo *infoPtr; int iterTmpIndex; Var *iterVarPtr; Tcl_Obj *oldValuePtr; opnd = TclGetUInt4AtPtr(pc+1); infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; iterTmpIndex = infoPtr->loopCtTemp; iterVarPtr = &(compiledLocals[iterTmpIndex]); oldValuePtr = iterVarPtr->value.objPtr; if (oldValuePtr == NULL) { TclNewLongObj(iterVarPtr->value.objPtr, -1); Tcl_IncrRefCount(iterVarPtr->value.objPtr); } else { TclSetLongObj(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: { /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. */ int opnd; ForeachInfo *infoPtr; ForeachVarList *varListPtr; int numLists; Tcl_Obj *listPtr,*valuePtr, *value2Ptr; Tcl_Obj **elements; Var *iterVarPtr, *listVarPtr; int iterNum, listTmpIndex, listLen, numVars; int varIndex, valIndex, continueLoop, j; long i; Var *varPtr; char *part1; opnd = TclGetUInt4AtPtr(pc+1); infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; /* * Increment the temp holding the loop iteration number. */ iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); valuePtr = iterVarPtr->value.objPtr; iterNum = (valuePtr->internalRep.longValue + 1); TclSetLongObj(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 (by calling Tcl_ListObjLength), but cannot rely * on that check remaining valid: one list could have been shimmered * as a side effect of setting a traced variable. */ 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; Tcl_ListObjGetElements(interp, listPtr, &listLen, &elements); valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { int setEmptyStr = 0; if (valIndex >= listLen) { setEmptyStr = 1; TclNewObj(valuePtr); } else { valuePtr = elements[valIndex]; } varIndex = varListPtr->varIndexes[j]; varPtr = &(compiledLocals[varIndex]); part1 = varPtr->name; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } if (TclIsVarDirectWritable(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. */ eePtr->stackPtr[++catchTop] = (Tcl_Obj *) (tosPtr - eePtr->stackPtr); TRACE(("%u => catchTop=%d, stackTop=%d\n", TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1), tosPtr - eePtr->stackPtr)); NEXT_INST_F(5, 0, 0); case INST_END_CATCH: catchTop--; result = TCL_OK; TRACE(("=> catchTop=%d\n", (catchTop - initCatchTop - 1))); NEXT_INST_F(1, 0, 0); case INST_PUSH_RESULT: objResultPtr = Tcl_GetObjResult(interp); TRACE_WITH_OBJ(("=> "), objResultPtr); /* * See the comments at INST_INVOKE_STK */ { Tcl_Obj *newObjResultPtr; TclNewObj(newObjResultPtr); Tcl_IncrRefCount(newObjResultPtr); iPtr->objResultPtr = newObjResultPtr; } NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: TclNewIntObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); case INST_PUSH_RETURN_OPTIONS: objResultPtr = Tcl_GetReturnOptions(interp, result); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); /* TODO: normalize "valPtr" to "valuePtr" */ { int opnd, opnd2, allocateDict; Tcl_Obj *dictPtr, *valPtr; Var *varPtr; char *part1; case INST_DICT_GET: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = *(tosPtr - opnd); if (opnd > 1) { dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, tosPtr - (opnd-1), DICT_PATH_READ); if (dictPtr == NULL) { TRACE_WITH_OBJ(( "%u => ERROR tracing dictionary path into \"%s\": ", opnd, O2S(*(tosPtr - opnd))), Tcl_GetObjResult(interp)); result = TCL_ERROR; cleanup = opnd + 1; goto checkForCatch; } } result = Tcl_DictObjGet(interp, dictPtr, *tosPtr, &objResultPtr); if (result != TCL_OK) { TRACE_WITH_OBJ(( "%u => ERROR reading leaf dictionary key \"%s\": ", opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); cleanup = opnd + 1; goto checkForCatch; } if (objResultPtr == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "key \"", TclGetString(*tosPtr), "\" not known in dictionary", NULL); TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); result = TCL_ERROR; cleanup = opnd + 1; goto checkForCatch; } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(5, opnd+1, 1); case INST_DICT_SET: case INST_DICT_UNSET: case INST_DICT_INCR_IMM: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); varPtr = &(compiledLocals[opnd2]); part1 = varPtr->name; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u %u => ", opnd, opnd2)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0); CACHE_STACK_INFO(); } if (dictPtr == NULL) { TclNewObj(dictPtr); allocateDict = 1; } else { allocateDict = Tcl_IsShared(dictPtr); if (allocateDict) { dictPtr = Tcl_DuplicateObj(dictPtr); } } switch (*pc) { case INST_DICT_SET: cleanup = opnd + 1; result = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, tosPtr-opnd, *tosPtr); break; case INST_DICT_INCR_IMM: cleanup = 1; opnd = TclGetInt4AtPtr(pc+1); result = Tcl_DictObjGet(interp, dictPtr, *tosPtr, &valPtr); if (result != TCL_OK) { break; } if (valPtr == NULL) { Tcl_DictObjPut(NULL, dictPtr, *tosPtr, Tcl_NewIntObj(opnd)); } else { Tcl_Obj *incrPtr = Tcl_NewIntObj(opnd); Tcl_IncrRefCount(incrPtr); if (Tcl_IsShared(valPtr)) { valPtr = Tcl_DuplicateObj(valPtr); Tcl_DictObjPut(NULL, dictPtr, *tosPtr, valPtr); } result = TclIncrObj(interp, valPtr, incrPtr); if (result == TCL_OK) { Tcl_InvalidateStringRep(dictPtr); } Tcl_DecrRefCount(incrPtr); } break; case INST_DICT_UNSET: cleanup = opnd; result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd, tosPtr - (opnd-1)); break; default: cleanup = 0; /* stop compiler warning */ Tcl_Panic("Should not happen!"); } if (result != TCL_OK) { if (allocateDict) { Tcl_DecrRefCount(dictPtr); } TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ",opnd,opnd2), Tcl_GetObjResult(interp)); goto checkForCatch; } if (TclIsVarDirectWritable(varPtr)) { if (allocateDict) { Tcl_Obj *oldValuePtr = varPtr->value.objPtr; Tcl_IncrRefCount(dictPtr); if (oldValuePtr != NULL) { Tcl_DecrRefCount(oldValuePtr); } else { TclSetVarScalar(varPtr); TclClearVarUndefined(varPtr); } varPtr->value.objPtr = dictPtr; } objResultPtr = dictPtr; } else { Tcl_IncrRefCount(dictPtr); DECACHE_STACK_INFO(); objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL, dictPtr, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); Tcl_DecrRefCount(dictPtr); if (objResultPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp)))); result = TCL_ERROR; goto checkForCatch; } } #ifndef TCL_COMPILE_DEBUG if (*(pc+9) == INST_POP) { NEXT_INST_V(10, cleanup, 0); } #endif TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(9, cleanup, 1); case INST_DICT_APPEND: case INST_DICT_LAPPEND: opnd = TclGetUInt4AtPtr(pc+1); cleanup = 2; varPtr = &(compiledLocals[opnd]); part1 = varPtr->name; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0); CACHE_STACK_INFO(); } if (dictPtr == NULL) { TclNewObj(dictPtr); allocateDict = 1; } else { allocateDict = Tcl_IsShared(dictPtr); if (allocateDict) { dictPtr = Tcl_DuplicateObj(dictPtr); } } result = Tcl_DictObjGet(interp, dictPtr, *(tosPtr - 1), &valPtr); if (result != TCL_OK) { if (allocateDict) { Tcl_DecrRefCount(dictPtr); } goto checkForCatch; } /* * Note that a non-existent key results in a NULL valPtr, which is a * case handled separately below. What we *can* say at this point is * that the write-back will always succeed. */ switch (*pc) { case INST_DICT_APPEND: if (valPtr == NULL) { valPtr = *tosPtr; } else { if (Tcl_IsShared(valPtr)) { valPtr = Tcl_DuplicateObj(valPtr); } Tcl_AppendObjToObj(valPtr, *tosPtr); } break; case INST_DICT_LAPPEND: /* * More complex because list-append can fail. */ if (valPtr == NULL) { valPtr = Tcl_NewListObj(1, tosPtr); } else if (Tcl_IsShared(valPtr)) { valPtr = Tcl_DuplicateObj(valPtr); result = Tcl_ListObjAppendElement(interp, valPtr, *tosPtr); if (result != TCL_OK) { Tcl_DecrRefCount(valPtr); if (allocateDict) { Tcl_DecrRefCount(dictPtr); } goto checkForCatch; } } else { result = Tcl_ListObjAppendElement(interp, valPtr, *tosPtr); if (result != TCL_OK) { if (allocateDict) { Tcl_DecrRefCount(dictPtr); } goto checkForCatch; } } break; default: Tcl_Panic("Should not happen!"); } Tcl_DictObjPut(NULL, dictPtr, *(tosPtr - 1), valPtr); if (TclIsVarDirectWritable(varPtr)) { if (allocateDict) { Tcl_Obj *oldValuePtr = varPtr->value.objPtr; Tcl_IncrRefCount(dictPtr); if (oldValuePtr != NULL) { Tcl_DecrRefCount(oldValuePtr); } else { TclSetVarScalar(varPtr); TclClearVarUndefined(varPtr); } varPtr->value.objPtr = dictPtr; } objResultPtr = dictPtr; } else { Tcl_IncrRefCount(dictPtr); DECACHE_STACK_INFO(); objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL, dictPtr, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); Tcl_DecrRefCount(dictPtr); if (objResultPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp)))); result = TCL_ERROR; goto checkForCatch; } } #ifndef TCL_COMPILE_DEBUG if (*(pc+9) == INST_POP) { NEXT_INST_F(6, 2, 0); } #endif TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(5, 2, 1); } { int opnd, done; Tcl_Obj *statePtr, *dictPtr, *keyPtr, *valuePtr, *emptyPtr; Var *varPtr; Tcl_DictSearch *searchPtr; case INST_DICT_FIRST: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = POP_OBJECT(); searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch)); result = Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, &valuePtr, &done); Tcl_DecrRefCount(dictPtr); if (result != TCL_OK) { ckfree((char *) searchPtr); cleanup = 0; goto checkForCatch; } TclNewObj(statePtr); statePtr->typePtr = &dictIteratorType; statePtr->internalRep.otherValuePtr = (void *) searchPtr; varPtr = compiledLocals + opnd; if (varPtr->value.objPtr == NULL) { TclSetVarScalar(compiledLocals + opnd); TclClearVarUndefined(compiledLocals + opnd); } else if (varPtr->value.objPtr->typePtr == &dictIteratorType) { Tcl_Panic("mis-issued dictFirst!"); } else { Tcl_DecrRefCount(varPtr->value.objPtr); } varPtr->value.objPtr = statePtr; Tcl_IncrRefCount(statePtr); goto pushDictIteratorResult; case INST_DICT_NEXT: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); statePtr = compiledLocals[opnd].value.objPtr; if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { Tcl_Panic("mis-issued dictNext!"); } searchPtr = (Tcl_DictSearch *) statePtr->internalRep.otherValuePtr; Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); pushDictIteratorResult: if (done) { TclNewObj(emptyPtr); PUSH_OBJECT(emptyPtr); PUSH_OBJECT(emptyPtr); } else { PUSH_OBJECT(valuePtr); PUSH_OBJECT(keyPtr); } TRACE_APPEND(("\"%.30s\" \"%.30s\" %d", O2S(*(tosPtr-1)), O2S(*tosPtr), done)); objResultPtr = eePtr->constants[done]; /*TODO: consider opt like INST_FOREACH_STEP4 */ NEXT_INST_F(5, 0, 1); case INST_DICT_DONE: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); statePtr = compiledLocals[opnd].value.objPtr; if (statePtr == NULL) { Tcl_Panic("mis-issued dictDone!"); } if (statePtr->typePtr == &dictIteratorType) { searchPtr = (Tcl_DictSearch *) statePtr->internalRep.otherValuePtr; Tcl_DictObjDone(searchPtr); ckfree((char *) searchPtr); } /* * Set the internal variable to an empty object to signify * that we don't hold an iterator. */ Tcl_DecrRefCount(statePtr); TclNewObj(emptyPtr); compiledLocals[opnd].value.objPtr = emptyPtr; Tcl_IncrRefCount(emptyPtr); NEXT_INST_F(5, 0, 0); } { int opnd, i, length, length2, allocdict; Tcl_Obj **keyPtrPtr, **varIdxPtrPtr, *dictPtr; Var *varPtr; char *part1; case INST_DICT_UPDATE_START: opnd = TclGetUInt4AtPtr(pc+1); varPtr = &(compiledLocals[opnd]); part1 = varPtr->name; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (dictPtr == NULL) { goto dictUpdateStartFailed; } } if (Tcl_ListObjGetElements(interp, *(tosPtr - 1), &length, &keyPtrPtr) != TCL_OK || Tcl_ListObjGetElements(interp, *tosPtr, &length2, &varIdxPtrPtr) != TCL_OK) { goto dictUpdateStartFailed; } if (length != length2) { Tcl_Panic("dictUpdateStart argument length mismatch"); } for (i=0 ; i<length ; i++) { Tcl_Obj *valPtr; int varIdx; if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i], &valPtr) != TCL_OK) { goto dictUpdateStartFailed; } Tcl_GetIntFromObj(NULL, varIdxPtrPtr[i], &varIdx); varPtr = &(compiledLocals[varIdx]); part1 = varPtr->name; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } DECACHE_STACK_INFO(); if (valPtr == NULL) { Tcl_UnsetVar(interp, part1, 0); } else if (TclPtrSetVar(interp, varPtr, NULL, part1, NULL, valPtr, TCL_LEAVE_ERR_MSG) == NULL) { CACHE_STACK_INFO(); dictUpdateStartFailed: cleanup = 2; result = TCL_ERROR; goto checkForCatch; } CACHE_STACK_INFO(); } NEXT_INST_F(5, 2, 0); case INST_DICT_UPDATE_END: opnd = TclGetUInt4AtPtr(pc+1); varPtr = &(compiledLocals[opnd]); part1 = varPtr->name; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0); CACHE_STACK_INFO(); } if (dictPtr == NULL) { NEXT_INST_F(5, 2, 0); } if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK || Tcl_ListObjGetElements(interp, *(tosPtr - 1), &length, &keyPtrPtr) != TCL_OK || Tcl_ListObjGetElements(interp, *tosPtr, &length2, &varIdxPtrPtr) != TCL_OK) { cleanup = 2; result = TCL_ERROR; goto checkForCatch; } allocdict = Tcl_IsShared(dictPtr); if (allocdict) { dictPtr = Tcl_DuplicateObj(dictPtr); } for (i=0 ; i<length ; i++) { Tcl_Obj *valPtr; int varIdx; Var *var2Ptr; char *part1a; Tcl_GetIntFromObj(NULL, varIdxPtrPtr[i], &varIdx); var2Ptr = &(compiledLocals[varIdx]); part1a = var2Ptr->name; while (TclIsVarLink(var2Ptr)) { var2Ptr = var2Ptr->value.linkPtr; } if (TclIsVarDirectReadable(var2Ptr)) { valPtr = var2Ptr->value.objPtr; } else { DECACHE_STACK_INFO(); valPtr = TclPtrGetVar(interp, var2Ptr, NULL, part1a, NULL, 0); CACHE_STACK_INFO(); } if (valPtr == NULL) { Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]); } else { Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valPtr); } } if (TclIsVarDirectWritable(varPtr)) { Tcl_IncrRefCount(dictPtr); Tcl_DecrRefCount(varPtr->value.objPtr); varPtr->value.objPtr = dictPtr; } else { DECACHE_STACK_INFO(); objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL, dictPtr, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (objResultPtr == NULL) { if (allocdict) { Tcl_DecrRefCount(dictPtr); } cleanup = 2; result = TCL_ERROR; goto checkForCatch; } } NEXT_INST_F(5, 2, 0); } default: Tcl_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_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", (char *) NULL); result = TCL_ERROR; goto checkForCatch; /* * Exponentiation of zero by negative number in an expression. Control * only reaches this point by "goto exponOfZero". */ exponOfZero: Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponentiation of zero by negative power", -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "exponentiation of zero by negative power", (char *) NULL); result = TCL_ERROR; goto checkForCatch; /* * Block for variables needed to process exception returns */ { 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. */ Tcl_Obj *valuePtr; char *bytes; int length; #if TCL_COMPILE_DEBUG int opnd; #endif /* * 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: opnd = TclGetUInt1AtPtr(pc+1); TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); break; case INST_INVOKE_STK4: opnd = TclGetUInt4AtPtr(pc+1); 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(*tosPtr))); 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)) { Tcl_Obj *objPtr = Tcl_GetObjResult(interp); TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", result, O2S(objPtr))); } else { Tcl_Obj *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; /* * Clear all expansions that may have started after the last * INST_BEGIN_CATCH. */ while ((expandNestList != NULL) && ((catchTop == initCatchTop) || ((ptrdiff_t) eePtr->stackPtr[catchTop] <= (ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) { Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2; TclDecrRefCount(expandNestList); expandNestList = objPtr; } /* * We must not catch an exceeded limit. Instead, it blows outwards * until we either hit another interpreter (presumably where the limit * is not exceeded) or we get to the top-level. */ if (Tcl_LimitExceeded(interp)) { #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... limit exceeded, returning %s\n", StringForResultCode(result)); } |
︙ | ︙ | |||
4903 4904 4905 4906 4907 4908 4909 | #endif goto abnormalReturn; } rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); if (rangePtr == NULL) { /* * This is only possible when compiling a [catch] that sends its | | | | | | | < | | | | | | | > | | | > > > > > > > > > > | 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 | #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 (tosPtr > ((ptrdiff_t) (eePtr->stackPtr[catchTop])) + eePtr->stackPtr) { 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 - initCatchTop - 1), (int) eePtr->stackPtr[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: { Tcl_Obj **initTosPtr = eePtr->stackPtr + initStackTop; while (tosPtr > initTosPtr) { Tcl_Obj *objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); } /* * Clear all expansions. */ while (expandNestList) { Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2; TclDecrRefCount(expandNestList); expandNestList = objPtr; } if (tosPtr < initTosPtr) { fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n", (unsigned int)(pc - codePtr->codeStart), (unsigned int) (tosPtr - eePtr->stackPtr), (unsigned int) initStackTop); Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top"); |
︙ | ︙ | |||
4976 4977 4978 4979 4980 4981 4982 | #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * * PrintByteCodeInfo -- * | | | | | | | | | | | | | 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 | #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * * PrintByteCodeInfo -- * * This procedure prints a summary about a bytecode object to stdout. It * is called by TclExecuteByteCode when starting to execute the bytecode * object if tclTraceExec has the value 2 or more. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void PrintByteCodeInfo(codePtr) register ByteCode *codePtr; /* The bytecode whose summary is printed to * stdout. */ { Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", (unsigned int) codePtr, codePtr->refCount, codePtr->compileEpoch, (unsigned int) iPtr, iPtr->compileEpoch); fprintf(stdout, " Source: "); TclPrintSource(stdout, codePtr->source, 60); fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", codePtr->numCommands, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS codePtr->numSrcBytes? ((float)codePtr->structureSize)/codePtr->numSrcBytes : #endif 0.0); #ifdef TCL_COMPILE_STATS fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", codePtr->structureSize, (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), codePtr->numCodeBytes, (codePtr->numLitObjects * sizeof(Tcl_Obj *)), (codePtr->numExceptRanges * sizeof(ExceptionRange)), |
︙ | ︙ | |||
5047 5048 5049 5050 5051 5052 5053 | * verify that the program counter and stack top are valid during * execution. * * Results: * None. * * Side effects: | | | | | | | | | | | | | 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 | * verify that the program counter and stack top are valid during * execution. * * Results: * None. * * Side effects: * Prints a message to stderr and panics if either the pc or stack top * are invalid. * *---------------------------------------------------------------------- */ #ifdef TCL_COMPILE_DEBUG static void ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, checkStack) register ByteCode *codePtr; /* The bytecode whose summary is printed to * stdout. */ unsigned char *pc; /* Points to first byte of a bytecode * instruction. The program counter. */ int stackTop; /* Current stack top. Must be between * stackLowerBound and stackUpperBound * (inclusive). */ int stackLowerBound; /* Smallest legal value for stackTop. */ int checkStack; /* 0 if the stack depth check should be * skipped. */ { int stackUpperBound = stackLowerBound + codePtr->maxStackDepth; /* Greatest legal value for stackTop. */ unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart); unsigned int codeStart = (unsigned int) codePtr->codeStart; unsigned int codeEnd = (unsigned int) (codePtr->codeStart + codePtr->numCodeBytes); unsigned char opCode = *pc; if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) { fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n", (unsigned int) pc); Tcl_Panic("TclExecuteByteCode execution failure: bad pc"); } if ((unsigned int) opCode > LAST_INST_OPCODE) { fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n", (unsigned int) opCode, relativePc); Tcl_Panic("TclExecuteByteCode execution failure: bad opcode"); } if (checkStack && ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) { int numChars; char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)", stackTop, relativePc, stackLowerBound, stackUpperBound); if (cmd != NULL) { Tcl_Obj *message = Tcl_NewStringObj("\n executing ", -1); Tcl_IncrRefCount(message); TclAppendLimitedToObj(message, cmd, numChars, 100, NULL); fprintf(stderr,"%s\n", Tcl_GetString(message)); |
︙ | ︙ | |||
5111 5112 5113 5114 5115 5116 5117 | #endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- * * IllegalExprOperandType -- * | | | | < > > | > > | | > | > | | | > | | < < < | < < < < < < | < < | < < < < > | < | < | < < < < < < | < < < | < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < | < | < < < < < < < < | | | | | | | | | | | | 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 | #endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- * * IllegalExprOperandType -- * * Used by TclExecuteByteCode to append an error message to the interp * result when an illegal operand type is detected by an expression * instruction. The argument opndPtr holds the operand object in error. * * Results: * None. * * Side effects: * An error message is appended to the interp result. * *---------------------------------------------------------------------- */ static void IllegalExprOperandType(interp, pc, opndPtr) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ unsigned char *pc; /* Points to the instruction being executed * when the illegal type was found. */ Tcl_Obj *opndPtr; /* Points to the operand holding the value * with the illegal type. */ { ClientData ptr; int type; unsigned char opcode = *pc; CONST char *description, *operator = operatorStrings[opcode - INST_LOR]; Tcl_Obj *msg = Tcl_NewObj(); if (opcode == INST_EXPON) { operator = "**"; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { int numBytes; CONST char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes); if (numBytes == 0) { description = "empty string"; } else if (TclCheckBadOctal(NULL, bytes)) { description = "invalid octal number"; } else { description = "non-numeric string"; } } else if (type == TCL_NUMBER_NAN) { description = "non-numeric floating-point value"; } else if (type == TCL_NUMBER_DOUBLE) { description = "floating-point value"; } else { /* TODO: No caller needs this. Eliminate? */ description = "(big) integer"; } TclObjPrintf(NULL, msg, "can't use %s as operand of \"%s\"", description, operator); Tcl_SetObjResult(interp, msg); } /* *---------------------------------------------------------------------- * * GetSrcInfoForPc -- * * Given a program counter value, finds the closest command in the * bytecode code unit's CmdLocation array and returns information about * that command's source: a pointer to its first byte and the number of * characters. * * Results: * If a command is found that encloses the program counter value, a * pointer to the command's source is returned and the length of the * source is stored at *lengthPtr. If multiple commands resulted in code * at pc, information about the closest enclosing command is returned. If * no matching command is found, NULL is returned and *lengthPtr is * unchanged. * * Side effects: * None. * *---------------------------------------------------------------------- */ static char * GetSrcInfoForPc(pc, codePtr, lengthPtr) unsigned char *pc; /* The program counter value for which to * return the closest command's source info. * This points to a bytecode instruction in * codePtr's code. */ ByteCode *codePtr; /* The bytecode sequence in which to look up * the command source for the pc. */ int *lengthPtr; /* If non-NULL, the location where the length * of the command's source should be stored. * If NULL, no length is stored. */ { register int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ |
︙ | ︙ | |||
5345 5346 5347 5348 5349 5350 5351 | srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; } else { srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } | | | | | | | | | < | | | | | | | | | < | | | | | | | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < | | | | | | < | > > | | | | | 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 6619 6620 6621 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 | srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; } else { srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } if (codeOffset > pcOffset) { /* best cmd already found */ break; } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */ int dist = (pcOffset - codeOffset); if (dist <= bestDist) { bestDist = dist; bestSrcOffset = srcOffset; bestSrcLength = srcLen; } } } if (bestDist == INT_MAX) { return NULL; } if (lengthPtr != NULL) { *lengthPtr = bestSrcLength; } return (codePtr->source + bestSrcOffset); } /* *---------------------------------------------------------------------- * * GetExceptRangeForPc -- * * Given a program counter value, return the closest enclosing * ExceptionRange. * * Results: * In the normal case, catchOnly is 0 (false) and this procedure returns * a pointer to the most closely enclosing ExceptionRange structure * regardless of whether it is a loop or catch exception range. This is * appropriate when processing a TCL_BREAK or TCL_CONTINUE, which will be * "handled" either by a loop exception range or a closer catch range. If * catchOnly is nonzero, this procedure ignores loop exception ranges and * returns a pointer to the closest catch range. If no matching * ExceptionRange is found that encloses pc, a NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ static ExceptionRange * GetExceptRangeForPc(pc, catchOnly, codePtr) unsigned char *pc; /* The program counter value for which to * search for a closest enclosing exception * range. This points to a bytecode * instruction in codePtr's code. */ int catchOnly; /* If 0, consider either loop or catch * ExceptionRanges in search. If nonzero * consider only catch ranges (and ignore any * closer loop ranges). */ 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; } /* *---------------------------------------------------------------------- * * GetOpcodeName -- * * This procedure is called by the TRACE and TRACE_WITH_OBJ macros used * in TclExecuteByteCode when debugging. It returns the name of the * bytecode instruction at a specified instruction pc. * * Results: * A character string for the instruction. * * Side effects: * None. * *---------------------------------------------------------------------- */ #ifdef TCL_COMPILE_DEBUG 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 */ /* *---------------------------------------------------------------------- * * TclExprFloatError -- * * This procedure is called when an error occurs during a floating-point * operation. It reads errno and sets interp->objResultPtr accordingly. * * Results: * interp->objResultPtr is set to hold an error message. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TclExprFloatError(interp, value) Tcl_Interp *interp; /* Where to store error message. */ double value; /* Value returned after error; used to * distinguish underflows from overflows. */ { CONST char *s; if ((errno == EDOM) || TclIsNaN(value)) { s = "domain error: argument not in valid range"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL); } else if ((errno == ERANGE) || TclIsInfinite(value)) { if (value == 0.0) { s = "floating-point value too small to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL); } else { s = "floating-point value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); } } else { Tcl_Obj *objPtr = Tcl_NewObj(); TclObjPrintf(NULL, objPtr, "unknown floating-point error, errno = %d", errno); Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", Tcl_GetString(objPtr), (char *) NULL); Tcl_SetObjResult(interp, objPtr); } } #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- * * TclLog2 -- * * Procedure used while collecting compilation statistics to determine * the log base 2 of an integer. * * Results: * Returns the log base 2 of the operand. If the argument is less than or * equal to zero, a zero is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclLog2(value) register int value; /* The integer for which to compute the log * base 2. */ { register int n = value; register int result = 0; while (n > 1) { n = n >> 1; result++; |
︙ | ︙ | |||
6345 6346 6347 6348 6349 6350 6351 | int numSharedMultX, numSharedOnce; int decadeHigh, minSizeDecade, maxSizeDecade, length, i; char *litTableStats; LiteralEntry *entryPtr; numInstructions = 0.0; for (i = 0; i < 256; i++) { | | | | | | | 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 | int numSharedMultX, numSharedOnce; int decadeHigh, minSizeDecade, maxSizeDecade, length, i; char *litTableStats; LiteralEntry *entryPtr; numInstructions = 0.0; for (i = 0; i < 256; i++) { if (statsPtr->instructionCount[i] != 0) { numInstructions += statsPtr->instructionCount[i]; } } totalLiteralBytes = sizeof(LiteralTable) + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *) + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)) + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)) + statsPtr->totalLitStringBytes; totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes; numCurrentByteCodes = statsPtr->numCompilations - statsPtr->numByteCodesFreed; currentHeaderBytes = numCurrentByteCodes * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))); literalMgmtBytes = sizeof(LiteralTable) + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) + (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); currentLiteralBytes = literalMgmtBytes + iPtr->literalTable.numEntries * sizeof(Tcl_Obj) + statsPtr->currentLitStringBytes; currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes; /* * Summary statistics, total and current source and ByteCode sizes. */ fprintf(stdout, "\n----------------------------------------------------------------\n"); fprintf(stdout, "Compilation and execution statistics for interpreter 0x%x\n", (unsigned int) iPtr); fprintf(stdout, "\nNumber ByteCodes executed %ld\n", statsPtr->numExecutions); fprintf(stdout, "Number ByteCodes compiled %ld\n", statsPtr->numCompilations); fprintf(stdout, " Mean executions/compile %.1f\n", ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations)); fprintf(stdout, "\nInstructions executed %.0f\n", numInstructions); fprintf(stdout, " Mean inst/compile %.0f\n", numInstructions / statsPtr->numCompilations); fprintf(stdout, " Mean inst/execution %.0f\n", numInstructions / statsPtr->numExecutions); |
︙ | ︙ | |||
6438 6439 6440 6441 6442 6443 6444 | fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n", (currentCodeBytes + statsPtr->currentSrcBytes), (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); /* * Tcl_IsShared statistics check * | | | < | 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 | fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n", (currentCodeBytes + statsPtr->currentSrcBytes), (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); /* * Tcl_IsShared statistics check * * This gives the refcount of each obj as Tcl_IsShared was called for it. * Shared objects must be duplicated before they can be modified. */ numSharedMultX = 0; fprintf(stdout, "\nTcl_IsShared object check (all objects):\n"); fprintf(stdout, " Object had refcount <=1 (not shared) %ld\n", tclObjsShared[1]); for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { |
︙ | ︙ | |||
6472 6473 6474 6475 6476 6477 6478 | numSharedOnce = 0; objBytesIfUnshared = 0.0; strBytesIfUnshared = 0.0; strBytesSharedMultX = 0.0; strBytesSharedOnce = 0.0; for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; | | | 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 | numSharedOnce = 0; objBytesIfUnshared = 0.0; strBytesIfUnshared = 0.0; strBytesSharedMultX = 0.0; strBytesSharedOnce = 0.0; for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { if (entryPtr->objPtr->typePtr == &tclByteCodeType) { numByteCodeLits++; } (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); strBytesIfUnshared += (entryPtr->refCount * (length+1)); |
︙ | ︙ | |||
6541 6542 6543 6544 6545 6546 6547 | sizeof(LiteralTable), iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), iPtr->literalTable.numEntries * sizeof(LiteralEntry)); /* * Breakdown of current ByteCode space requirements. */ | | | 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 7025 7026 7027 7028 | sizeof(LiteralTable), iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), iPtr->literalTable.numEntries * sizeof(LiteralEntry)); /* * Breakdown of current ByteCode space requirements. */ fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n"); fprintf(stdout, " Bytes Pct of Avg per\n"); fprintf(stdout, " total ByteCode\n"); fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n", statsPtr->currentByteCodeBytes, statsPtr->currentByteCodeBytes / numCurrentByteCodes); fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n", |
︙ | ︙ | |||
6576 6577 6578 6579 6580 6581 6582 | statsPtr->currentCmdMapBytes, ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes), statsPtr->currentCmdMapBytes / numCurrentByteCodes); /* * Detailed literal statistics. */ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | < | 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 7084 7085 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 7096 7097 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 7123 7124 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 | statsPtr->currentCmdMapBytes, ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes), statsPtr->currentCmdMapBytes / numCurrentByteCodes); /* * Detailed literal statistics. */ fprintf(stdout, "\nLiteral string sizes:\n"); fprintf(stdout, " Up to length Percentage\n"); maxSizeDecade = 0; for (i = 31; i >= 0; i--) { if (statsPtr->literalCount[i] > 0) { maxSizeDecade = i; break; } } sum = 0; for (i = 0; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->literalCount[i]; fprintf(stdout, " %10d %8.0f%%\n", decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated); } litTableStats = TclLiteralStats(globalTablePtr); fprintf(stdout, "\nCurrent literal table statistics:\n%s\n", litTableStats); ckfree((char *) litTableStats); /* * Source and ByteCode size distributions. */ fprintf(stdout, "\nSource sizes:\n"); fprintf(stdout, " Up to size Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->srcCount[i] > 0) { minSizeDecade = i; break; } } for (i = 31; i >= 0; i--) { if (statsPtr->srcCount[i] > 0) { maxSizeDecade = i; break; } } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->srcCount[i]; fprintf(stdout, " %10d %8.0f%%\n", decadeHigh, (sum * 100.0) / statsPtr->numCompilations); } fprintf(stdout, "\nByteCode sizes:\n"); fprintf(stdout, " Up to size Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->byteCodeCount[i] > 0) { minSizeDecade = i; break; } } for (i = 31; i >= 0; i--) { if (statsPtr->byteCodeCount[i] > 0) { maxSizeDecade = i; break; } } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->byteCodeCount[i]; fprintf(stdout, " %10d %8.0f%%\n", decadeHigh, (sum * 100.0) / statsPtr->numCompilations); } fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n"); fprintf(stdout, " Up to ms Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->lifetimeCount[i] > 0) { minSizeDecade = i; break; } } for (i = 31; i >= 0; i--) { if (statsPtr->lifetimeCount[i] > 0) { maxSizeDecade = i; break; } } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->lifetimeCount[i]; fprintf(stdout, " %12.3f %8.0f%%\n", decadeHigh / 1000.0, (sum * 100.0) / statsPtr->numByteCodesFreed); } /* * 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 fprintf(stdout, "\n----------------------------------------------------------------\n"); return TCL_OK; } #endif /* TCL_COMPILE_STATS */ #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * * StringForResultCode -- * * Procedure that returns a human-readable string representing a Tcl * result code such as TCL_ERROR. * * Results: * If the result code is one of the standard Tcl return codes, the result * is a string representing that code such as "TCL_ERROR". Otherwise, * the result string is that code formatted as a sequence of decimal * digit characters. Note that the resulting string must not be modified * by the caller. * * Side effects: * None. * *---------------------------------------------------------------------- */ static char * StringForResultCode(result) int result; /* The Tcl result code for which to generate a * string. */ { static char buf[TCL_INTEGER_SPACE]; if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) { return resultStrings[result]; } TclFormatInt(buf, result); return buf; } #endif /* TCL_COMPILE_DEBUG */ #if 0 /* *---------------------------------------------------------------------- * * ExponWide -- * * Procedure to return w**w2 as wide integer * * Results: * Return value is w to the power w2, unless the computation makes no * sense mathematically. In that case *errExpon is set to 1. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
6788 6789 6790 6791 6792 6793 6794 | if (w2 < 0) { return W0; } else if (w2 == 0) { return Tcl_LongAsWide(1); } } else if (w == -1) { return (w2 & 1) ? Tcl_LongAsWide(-1) : Tcl_LongAsWide(1); | | | | | | < | | | | | | | | | | | | | | | > | 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 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 | if (w2 < 0) { return W0; } else if (w2 == 0) { return Tcl_LongAsWide(1); } } else if (w == -1) { return (w2 & 1) ? Tcl_LongAsWide(-1) : Tcl_LongAsWide(1); } else if ((w == 1) || (w2 == 0)) { return Tcl_LongAsWide(1); } else if (w>1 && w2<0) { return W0; } /* * The general case. */ result = Tcl_LongAsWide(1); for (; w2>Tcl_LongAsWide(1) ; w*=w,w2/=2) { if (w2 & 1) { result *= w; } } return result * w; } /* *---------------------------------------------------------------------- * * ExponLong -- * * Procedure to return i**i2 as long integer * * Results: * Return value is i to the power i2, unless the computation makes no * sense mathematically. In that case *errExpon is set to 1. * * Side effects: * None. * *---------------------------------------------------------------------- */ static long ExponLong(i, i2, errExpon) long i; /* The value that must be exponentiated */ long i2; /* The exponent */ int *errExpon; /* Error code */ { long result; *errExpon = 0; /* * Check for possible errors and simple cases */ if (i == 0) { if (i2 < 0) { *errExpon = 1; return 0L; } else if (i2 > 0) { return 0L; } /* * By definition and analysis, 0**0 is 1. */ return 1L; } else if (i < -1) { if (i2 < 0) { return 0L; } else if (i2 == 0) { return 1L; } } else if (i == -1) { return (i2&1) ? -1L : 1L; } else if ((i == 1) || (i2 == 0)) { return 1L; } else if (i > 1 && i2 < 0) { return 0L; } /* * The general case */ result = 1; for (; i2>1 ; i*=i,i2/=2) { if (i2 & 1) { result *= i; } } return result * i; } #endif |
Changes to generic/tclFCmd.c.
1 2 3 | /* * tclFCmd.c * | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | /* * 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.29.2.3 2005/08/02 18:15:27 dgp Exp $ */ #include "tclInt.h" /* * Declarations for local functions defined in this file: */ static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, int copyFlag, int force)); static Tcl_Obj * FileBasename _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int copyFlag)); static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int *forcePtr)); /* *--------------------------------------------------------------------------- * * TclFileRenameCmd * * This function implements the "rename" subcommand of the "file" * command. Filename arguments need to be translated to native format * before being passed to platform-specific code that implements rename * functionality. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
57 58 59 60 61 62 63 | } /* *--------------------------------------------------------------------------- * * TclFileCopyCmd * | | | | < | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | } /* *--------------------------------------------------------------------------- * * TclFileCopyCmd * * This function implements the "copy" subcommand of the "file" command. * Filename arguments need to be translated to native format before being * passed to platform-specific code that implements copy functionality. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
85 86 87 88 89 90 91 | } /* *--------------------------------------------------------------------------- * * FileCopyRename -- * | | | | | | | | | 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 | } /* *--------------------------------------------------------------------------- * * FileCopyRename -- * * Performs the work of TclFileRenameCmd and TclFileCopyCmd. See * comments for those functions. * * Results: * See above. * * Side effects: * See above. * *--------------------------------------------------------------------------- */ static int FileCopyRename(interp, objc, objv, copyFlag) Tcl_Interp *interp; /* Used for error reporting. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ int copyFlag; /* If non-zero, copy source(s). Otherwise, * rename them. */ { int i, result, force; Tcl_StatBuf statBuf; Tcl_Obj *target; i = FileForceOption(interp, objc - 2, objv + 2, &force); if (i < 0) { return TCL_ERROR; } i += 2; if ((objc - i) < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", TclGetString(objv[0]), " ", TclGetString(objv[1]), " ?options? source ?source ...? target\"", (char *) NULL); return TCL_ERROR; } /* * If target doesn't exist or isn't a directory, try the copy/rename. * More than 2 arguments is only valid if the target is an existing |
︙ | ︙ | |||
147 148 149 150 151 152 153 | if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { if ((objc - i) > 2) { errno = ENOTDIR; Tcl_PosixError(interp); Tcl_AppendResult(interp, "error ", ((copyFlag) ? "copying" : "renaming"), ": target \"", | | | | | | | | | | | 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 | if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { if ((objc - i) > 2) { errno = ENOTDIR; Tcl_PosixError(interp); Tcl_AppendResult(interp, "error ", ((copyFlag) ? "copying" : "renaming"), ": target \"", TclGetString(target), "\" is not a directory", (char *) NULL); result = TCL_ERROR; } else { /* * Even though already have target == translated(objv[i+1]), pass * the original argument down, so if there's an error, the error * message will reflect the original arguments. */ result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag, force); } return result; } /* * Move each source file into target directory. Extract the basename from * each source, and append it to the end of the target path. */ for ( ; i<objc-1 ; i++) { Tcl_Obj *jargv[2]; Tcl_Obj *source, *newFileName; Tcl_Obj *temp; source = FileBasename(interp, objv[i]); if (source == NULL) { result = TCL_ERROR; break; } jargv[0] = objv[objc - 1]; jargv[1] = source; |
︙ | ︙ | |||
201 202 203 204 205 206 207 | } /* *--------------------------------------------------------------------------- * * TclFileMakeDirsCmd * | | | | < | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 | } /* *--------------------------------------------------------------------------- * * TclFileMakeDirsCmd * * This function implements the "mkdir" subcommand of the "file" command. * Filename arguments need to be translated to native format before being * passed to platform-specific code that implements mkdir functionality. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
245 246 247 248 249 250 251 252 | errno = ENOENT; errfile = objv[i]; break; } for (j = 0; j < pobjc; j++) { target = Tcl_FSJoinPath(split, j + 1); Tcl_IncrRefCount(target); /* | > | | < | > > > > > > > | > > > > > > > > > > > > > > > > | | | > > > > > > > | > > | | | | | | | | | 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 | errno = ENOENT; errfile = objv[i]; break; } for (j = 0; j < pobjc; j++) { target = Tcl_FSJoinPath(split, j + 1); Tcl_IncrRefCount(target); /* * Call Tcl_FSStat() so that if target is a symlink that points to * a directory we will create subdirectories in that directory. */ if (Tcl_FSStat(target, &statBuf) == 0) { if (!S_ISDIR(statBuf.st_mode)) { errno = EEXIST; errfile = target; goto done; } } else if (errno != ENOENT) { /* * If Tcl_FSStat() failed and the error is anything other than * non-existence of the target, throw the error. */ errfile = target; goto done; } else if (Tcl_FSCreateDirectory(target) != TCL_OK) { /* * Create might have failed because of being in a race * condition with another process trying to create the same * subdirectory. */ if (errno == EEXIST) { if ((Tcl_FSStat(target, &statBuf) == 0) && S_ISDIR(statBuf.st_mode)) { /* * It is a directory that wasn't there before, so keep * going without error. */ Tcl_ResetResult(interp); } else { errfile = target; goto done; } } else { errfile = target; goto done; } } /* * Forget about this sub-path. */ Tcl_DecrRefCount(target); target = NULL; } Tcl_DecrRefCount(split); split = NULL; } done: if (errfile != NULL) { Tcl_AppendResult(interp, "can't create directory \"", TclGetString(errfile), "\": ", Tcl_PosixError(interp), (char *) NULL); result = TCL_ERROR; } if (split != NULL) { Tcl_DecrRefCount(split); } if (target != NULL) { Tcl_DecrRefCount(target); } return result; } /* *---------------------------------------------------------------------- * * TclFileDeleteCmd * * This function implements the "delete" subcommand of the "file" * command. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ int TclFileDeleteCmd(interp, objc, objv) Tcl_Interp *interp; /* Used for error reporting */ int objc; /* Number of arguments */ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ { int i, force, result; Tcl_Obj *errfile; Tcl_Obj *errorBuffer = NULL; i = FileForceOption(interp, objc - 2, objv + 2, &force); if (i < 0) { return TCL_ERROR; } i += 2; if ((objc - i) < 1) { Tcl_AppendResult(interp, "wrong # args: should be \"", TclGetString(objv[0]), " ", TclGetString(objv[1]), " ?options? file ?file ...?\"", (char *) NULL); return TCL_ERROR; } errfile = NULL; result = TCL_OK; |
︙ | ︙ | |||
343 344 345 346 347 348 349 | /* * Call lstat() to get info so can delete symbolic link itself. */ if (Tcl_FSLstat(objv[i], &statBuf) != 0) { /* | | | | | | > | | | | | > > | > > | > | | | < > | | < > | | | | | > | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | > | > | > | < | | | | | | | | | > | | | | < | | | | > | | | | | | > > | > > | < > > | | | > > > > | > > > | > > | | < > | | | | | | | | | | | > | | | | > > | | | | | | > | < | | | | | | | | | | | | | | | < | | | | | | | | | | | < | | | | | | | < | | | | < | | | | | | | | | | | | > > | | | | > > | > > > > | > > | | | | > | > > | > > | > | | | > > | > > > | | | | | | | | < | > | > > > | | < > > > > > > > > > | 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 | /* * Call lstat() to get info so can delete symbolic link itself. */ if (Tcl_FSLstat(objv[i], &statBuf) != 0) { /* * Trying to delete a file that does not exist is not considered * an error, just a no-op */ if (errno != ENOENT) { result = TCL_ERROR; } } else if (S_ISDIR(statBuf.st_mode)) { /* * We own a reference count on errorBuffer, if it was set as a * result of this call. */ result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer); if (result != TCL_OK) { if ((force == 0) && (errno == EEXIST)) { Tcl_AppendResult(interp, "error deleting \"", TclGetString(objv[i]), "\": directory not empty", (char *) NULL); Tcl_PosixError(interp); goto done; } /* * If possible, use the untranslated name for the file. */ errfile = errorBuffer; /* * FS supposed to check between translated objv and errfile. */ if (Tcl_FSEqualPaths(objv[i], errfile)) { errfile = objv[i]; } } } else { result = Tcl_FSDeleteFile(objv[i]); } if (result != TCL_OK) { result = TCL_ERROR; /* * It is important that we break on error, otherwise we might end * up owning reference counts on numerous errorBuffers. */ break; } } if (result != TCL_OK) { if (errfile == NULL) { /* * We try to accomodate poor error results from our Tcl_FS calls. */ Tcl_AppendResult(interp, "error deleting unknown file: ", Tcl_PosixError(interp), (char *) NULL); } else { Tcl_AppendResult(interp, "error deleting \"", TclGetString(errfile), "\": ", Tcl_PosixError(interp), (char *) NULL); } } done: if (errorBuffer != NULL) { Tcl_DecrRefCount(errorBuffer); } return result; } /* *--------------------------------------------------------------------------- * * CopyRenameOneFile * * Copies or renames specified source file or directory hierarchy to the * specified target. * * Results: * A standard Tcl result. * * Side effects: * Target is overwritten if the force flag is set. Attempting to * copy/rename a file onto a directory or a directory onto a file will * always result in an error. * *---------------------------------------------------------------------- */ static int CopyRenameOneFile(interp, source, target, copyFlag, force) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *source; /* Pathname of file to copy. May need to be * translated. */ Tcl_Obj *target; /* Pathname of file to create/overwrite. May * need to be translated. */ int copyFlag; /* If non-zero, copy files. Otherwise, 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_Obj *actualSource=NULL; /* If source is a link, then this is the real * file/directory. */ Tcl_StatBuf sourceStatBuf, targetStatBuf; if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) { return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } errfile = NULL; errorBuffer = NULL; result = TCL_ERROR; /* * We want to copy/rename links and not the files they point to, so we use * lstat(). If target is a link, we also want to replace the link and not * the file it points to, so we also use lstat() on the target. */ if (Tcl_FSLstat(source, &sourceStatBuf) != 0) { errfile = source; goto done; } if (Tcl_FSLstat(target, &targetStatBuf) != 0) { if (errno != ENOENT) { errfile = target; goto done; } } else { if (force == 0) { errno = EEXIST; errfile = target; goto done; } /* * Prevent copying or renaming a file onto itself. Under Windows, stat * always returns 0 for st_ino. However, the Windows-specific code * knows how to deal with copying or renaming a file on top of itself. * It might be a good idea to write a stat that worked. */ if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { result = TCL_OK; goto done; } } /* * Prevent copying/renaming a file onto a directory and vice-versa. * This is a policy decision based on the fact that existing * implementations of copy and rename on all platforms also prevent * this. */ if (S_ISDIR(sourceStatBuf.st_mode) && !S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; Tcl_AppendResult(interp, "can't overwrite file \"", TclGetString(target), "\" with directory \"", TclGetString(source), "\"", (char *) NULL); goto done; } if (!S_ISDIR(sourceStatBuf.st_mode) && S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; Tcl_AppendResult(interp, "can't overwrite directory \"", TclGetString(target), "\" with file \"", TclGetString(source), "\"", (char *) NULL); goto done; } /* * The destination exists, but appears to be ok to over-write, and * -force is given. We now try to adjust permissions to ensure the * operation succeeds. If we can't adjust permissions, we'll let the * actual copy/rename return an error later. */ { Tcl_Obj* perm = Tcl_NewStringObj("u+w",-1); int index; Tcl_IncrRefCount(perm); if (TclFSFileAttrIndex(target, "-permissions", &index) == TCL_OK) { Tcl_FSFileAttrsSet(NULL, index, target, perm); } Tcl_DecrRefCount(perm); } } if (copyFlag == 0) { result = Tcl_FSRenameFile(source, target); if (result == TCL_OK) { goto done; } if (errno == EINVAL) { Tcl_AppendResult(interp, "error renaming \"", TclGetString(source), "\" to \"", TclGetString(target), "\": trying to rename a volume or ", "move a directory into itself", (char *) NULL); goto done; } else if (errno != EXDEV) { errfile = target; goto done; } /* * 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); /* * Activate the following block to copy files instead of links. However * Tcl's semantics currently say we should copy links, so any such change * should be the subject of careful study on the consequences. * * Perhaps there could be an optional flag to 'file copy' to dictate which * approach to use, with the default being _not_ to have this block * active. */ #if 0 #ifdef S_ISLNK 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 \"", TclGetString(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; } /* * Now we want to check if this is a relative path, and if so, * to make it absolute. */ if (Tcl_FSGetPathType(path) == TCL_PATH_RELATIVE) { Tcl_Obj *abs = Tcl_FSJoinToPath(actualSource, 1, &path); if (abs == NULL) { break; } Tcl_IncrRefCount(abs); Tcl_DecrRefCount(path); path = abs; } 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. */ Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL); Tcl_IncrRefCount(copyCommand); Tcl_ListObjAppendElement(interp, copyCommand, Tcl_NewStringObj("::tcl::CopyDirectory",-1)); if (copyFlag) { Tcl_ListObjAppendElement(interp, copyCommand, Tcl_NewStringObj("copying",-1)); } else { Tcl_ListObjAppendElement(interp, copyCommand, Tcl_NewStringObj("renaming",-1)); } Tcl_ListObjAppendElement(interp, copyCommand, source); Tcl_ListObjAppendElement(interp, copyCommand, target); result = Tcl_EvalObjEx(interp, copyCommand, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); Tcl_DecrRefCount(copyCommand); if (result != TCL_OK) { /* * There was an error in the Tcl-level copy. We will pass * on the Tcl error message and can ensure this by setting * errfile to NULL */ errfile = NULL; } } else { errfile = errorBuffer; if (Tcl_FSEqualPaths(errfile, source)) { 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, so it should * be quite clear */ errfile = target; /* * We now need to reset the result, because the above call, if it * failed, may have put an error message in place. (Ideally we * would prefer not to pass an interpreter in above, but the * channel IO code used by TclCrossFilesystemCopy currently * requires one). */ Tcl_ResetResult(interp); } } if ((copyFlag == 0) && (result == TCL_OK)) { if (S_ISDIR(sourceStatBuf.st_mode)) { result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer); if (result != TCL_OK) { if (Tcl_FSEqualPaths(errfile, source) == 0) { errfile = source; } } } else { result = Tcl_FSDeleteFile(source); if (result != TCL_OK) { errfile = source; } } if (result != TCL_OK) { Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile), "\": ", Tcl_PosixError(interp), (char *) NULL); errfile = NULL; } } done: if (errfile != NULL) { Tcl_AppendResult(interp, ((copyFlag) ? "error copying \"" : "error renaming \""), TclGetString(source), (char *) NULL); if (errfile != source) { Tcl_AppendResult(interp, "\" to \"", TclGetString(target), (char *) NULL); if (errfile != target) { Tcl_AppendResult(interp, "\": \"", TclGetString(errfile), (char *) NULL); } } Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), (char *) NULL); } if (errorBuffer != NULL) { Tcl_DecrRefCount(errorBuffer); } if (actualSource != NULL) { Tcl_DecrRefCount(actualSource); } return result; } /* *--------------------------------------------------------------------------- * * FileForceOption -- * * Helps parse command line options for file commands that take the * "-force" and "--" options. * * Results: * The return value is how many arguments from argv were consumed by this * function, or -1 if there was an error parsing the options. If an error * occurred, an error message is left in the interp's result. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int FileForceOption(interp, objc, objv, forcePtr) Tcl_Interp *interp; /* Interp, for error return. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument strings. First command line * option, if it exists, begins at 0. */ int *forcePtr; /* If the "-force" was specified, *forcePtr is * filled with 1, otherwise with 0. */ { int force, i; force = 0; for (i = 0; i < objc; i++) { if (TclGetString(objv[i])[0] != '-') { break; } if (strcmp(TclGetString(objv[i]), "-force") == 0) { force = 1; } else if (strcmp(TclGetString(objv[i]), "--") == 0) { i++; break; } else { Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), "\": should be -force or --", (char *)NULL); return -1; } } *forcePtr = force; return i; } /* *--------------------------------------------------------------------------- * * FileBasename -- * * Given a path in either tcl format (with / separators), or in the * platform-specific format for the current platform, return all the * characters in the path after the last directory separator. But, if * path is the root directory, returns no characters. * * Results: * Returns the string object that represents the basename. If there is an * error, an error message is left in interp, and NULL is returned. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static Tcl_Obj * FileBasename(interp, pathPtr) Tcl_Interp *interp; /* Interp, for error return. */ Tcl_Obj *pathPtr; /* Path whose basename to extract. */ { int objc; Tcl_Obj *splitPtr; Tcl_Obj *resultPtr = NULL; splitPtr = Tcl_FSSplitPath(pathPtr, &objc); Tcl_IncrRefCount(splitPtr); if (objc != 0) { if ((objc == 1) && (*TclGetString(pathPtr) == '~')) { Tcl_DecrRefCount(splitPtr); if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return NULL; } splitPtr = Tcl_FSSplitPath(pathPtr, &objc); Tcl_IncrRefCount(splitPtr); } /* * Return the last component, unless it is the only component, and it * is the root of an absolute path. */ if (objc > 0) { Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr); if ((objc == 1) && (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) { resultPtr = NULL; } } } if (resultPtr == NULL) { resultPtr = Tcl_NewObj(); } Tcl_IncrRefCount(resultPtr); Tcl_DecrRefCount(splitPtr); return resultPtr; } /* *---------------------------------------------------------------------- * * TclFileAttrsCmd -- * * Sets or gets the platform-specific attributes of a file. The objc-objv * points to the file name with the rest of the command line following. * This routine uses platform-specific tables of option strings and * callbacks. The callback to get the attributes take three parameters: * Tcl_Interp *interp; The interp to report errors with. Since * this is an object-based API, the object * form of the result should be used. * CONST char *fileName; This is extracted using * Tcl_TranslateFileName. * TclObj **attrObjPtrPtr; A new object to hold the attribute is * allocated and put here. * The first two parameters of the callback used to write out the * attributes are the same. The third parameter is: * CONST *attrObjPtr; A pointer to the object that has the new * attribute. * They both return standard TCL errors; if the routine to get an * attribute fails, no object is allocated and *attrObjPtrPtr is * unchanged. * * Results: * Standard TCL error. * * Side effects: * May set file attributes for the file name. * *---------------------------------------------------------------------- */ int TclFileAttrsCmd(interp, objc, objv) Tcl_Interp *interp; /* The interpreter for error reporting. */ int objc; /* Number of command line arguments. */ Tcl_Obj *CONST objv[]; /* The command line objects. */ { int result; CONST char ** attributeStrings; Tcl_Obj* objStrings = NULL; int numObjStrings = -1; Tcl_Obj *filePtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?option? ?value? ?option value ...?"); return TCL_ERROR; } filePtr = objv[2]; 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_AppendResult(interp, "could not read \"", TclGetString(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; } attributeStrings = (CONST char **) ckalloc((1+numObjStrings) * sizeof(char*)); for (index = 0; index < numObjStrings; index++) { Tcl_ListObjIndex(interp, objStrings, index, &objPtr); attributeStrings[index] = TclGetString(objPtr); } attributeStrings[index] = NULL; } if (objc == 0) { /* * Get all attributes. */ int index, res = TCL_OK, nbAtts = 0; Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(0, NULL); for (index = 0; attributeStrings[index] != NULL; index++) { Tcl_Obj *objPtrAttr; if (res != TCL_OK) { /* * Clear the error from the last iteration. */ Tcl_ResetResult(interp); } res = Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtrAttr); if (res == TCL_OK) { Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1); Tcl_ListObjAppendElement(interp, listPtr, objPtr); Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr); nbAtts++; } } if (index > 0 && nbAtts == 0) { /* * Error: no valid attributes found. */ Tcl_DecrRefCount(listPtr); goto end; } Tcl_SetObjResult(interp, listPtr); } else if (objc == 1) { /* * Get one attribute. */ int index; Tcl_Obj *objPtr = NULL; if (numObjStrings == 0) { Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), "\", there are no file attributes in this filesystem.", (char *) NULL); goto end; } if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, "option", 0, &index) != TCL_OK) { goto end; } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; } Tcl_SetObjResult(interp, objPtr); } else { /* * Set option/value pairs. */ int i, index; if (numObjStrings == 0) { Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), "\", there are no file attributes in this filesystem.", (char *) NULL); goto end; } for (i = 0; i < objc ; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, "option", 0, &index) != TCL_OK) { goto end; } if (i + 1 == objc) { Tcl_AppendResult(interp, "value for \"", TclGetString(objv[i]), "\" missing", (char *) NULL); goto end; } if (Tcl_FSFileAttrsSet(interp, index, filePtr, objv[i + 1]) != TCL_OK) { goto end; } } } result = TCL_OK; end: if (numObjStrings != -1) { /* * Free up the array we allocated. */ ckfree((char*)attributeStrings); /* * We don't need this object that was passed to us any more. */ if (objStrings != NULL) { Tcl_DecrRefCount(objStrings); } } return result; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclFileName.c.
1 2 3 | /* * tclFileName.c -- * | | | | | | | | | < | | | < | | > | > > > > | > > | < | | < | | < | > > | > > > | > > > | > > > | > > > > > > > | > > | > | > > > | > | > > | > > > | > | > > > > | > | > | > > > | > | > | > > > > | > | > | > > > > > | > > | | | | | > | | | < | | > | | | | | | | | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 | /* * tclFileName.c -- * * This file contains routines for converting file names betwen native * and network form. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclFileName.c,v 1.60.2.8 2005/08/02 18:15:28 dgp Exp $ */ #include "tclInt.h" #include "tclRegexp.h" #include "tclFileSystem.h" /* For TclGetPathType() */ /* * The following variable is set in the TclPlatformInit call to one of: * TCL_PLATFORM_UNIX or TCL_PLATFORM_WINDOWS. */ TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; /* * Prototypes for local procedures defined in this file: */ static CONST char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp, CONST char *user, Tcl_DString *resultPtr)); static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path, Tcl_DString *resultPtr, int offset, Tcl_PathType *typePtr)); static int SkipToChar _ANSI_ARGS_((char **stringPtr, int match)); static Tcl_Obj* SplitWinPath _ANSI_ARGS_((CONST char *path)); static Tcl_Obj* SplitUnixPath _ANSI_ARGS_((CONST char *path)); static int DoGlob _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *resultPtr, char *separators, Tcl_Obj *pathPtr, int flags, char *pattern, Tcl_GlobTypeData *types)); /* *---------------------------------------------------------------------- * * ExtractWinRoot -- * * Matches the root portion of a Windows path and appends it to the * specified Tcl_DString. * * Results: * Returns the position in the path immediately after the root including * any trailing slashes. Appends a cleaned up version of the root to the * Tcl_DString at the specified offest. * * Side effects: * Modifies the specified Tcl_DString. * *---------------------------------------------------------------------- */ static CONST char * ExtractWinRoot(path, resultPtr, offset, typePtr) CONST char *path; /* Path to parse. */ Tcl_DString *resultPtr; /* Buffer to hold result. */ int offset; /* Offset in buffer where result should be * stored. */ Tcl_PathType *typePtr; /* Where to store pathType result */ { if (path[0] == '/' || path[0] == '\\') { /* * Might be a UNC or Vol-Relative path. */ CONST char *host, *share, *tail; int hlen, slen; if (path[1] != '/' && path[1] != '\\') { Tcl_DStringSetLength(resultPtr, offset); *typePtr = TCL_PATH_VOLUME_RELATIVE; Tcl_DStringAppend(resultPtr, "/", 1); return &path[1]; } host = &path[2]; /* * Skip separators. */ while (host[0] == '/' || host[0] == '\\') { host++; } for (hlen = 0; host[hlen];hlen++) { if (host[hlen] == '/' || host[hlen] == '\\') { break; } } if (host[hlen] == 0 || host[hlen+1] == 0) { /* * The path given is simply of the form '/foo', '//foo', * '/////foo' or the same with backslashes. If there is exactly * one leading '/' the path is volume relative (see filename man * page). If there are more than one, we are simply assuming they * are superfluous and we trim them away. (An alternative * interpretation would be that it is a host name, but we have * been documented that that is not the case). */ *typePtr = TCL_PATH_VOLUME_RELATIVE; Tcl_DStringAppend(resultPtr, "/", 1); return &path[2]; } Tcl_DStringSetLength(resultPtr, offset); share = &host[hlen]; /* * Skip separators. */ while (share[0] == '/' || share[0] == '\\') { share++; } for (slen=0; share[slen]; slen++) { if (share[slen] == '/' || share[slen] == '\\') { break; } } Tcl_DStringAppend(resultPtr, "//", 2); Tcl_DStringAppend(resultPtr, host, hlen); Tcl_DStringAppend(resultPtr, "/", 1); Tcl_DStringAppend(resultPtr, share, slen); tail = &share[slen]; /* * Skip separators. */ while (tail[0] == '/' || tail[0] == '\\') { tail++; } *typePtr = TCL_PATH_ABSOLUTE; return tail; } else if (*path && path[1] == ':') { /* * Might be a drive separator. */ Tcl_DStringSetLength(resultPtr, offset); if (path[2] != '/' && path[2] != '\\') { *typePtr = TCL_PATH_VOLUME_RELATIVE; Tcl_DStringAppend(resultPtr, path, 2); return &path[2]; } else { char *tail = (char*)&path[3]; /* * Skip separators. */ while (*tail && (tail[0] == '/' || tail[0] == '\\')) { tail++; } *typePtr = TCL_PATH_ABSOLUTE; Tcl_DStringAppend(resultPtr, path, 2); Tcl_DStringAppend(resultPtr, "/", 1); return tail; } } else { int abs = 0; /* * Check for Windows devices. */ if ((path[0] == 'c' || path[0] == 'C') && (path[1] == 'o' || path[1] == 'O')) { if ((path[2] == 'm' || path[2] == 'M') && path[3] >= '1' && path[3] <= '4') { /* * May have match for 'com[1-4]:?', which is a serial port. */ if (path[4] == '\0') { abs = 4; } else if (path [4] == ':' && path[5] == '\0') { abs = 5; } } else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') { /* * Have match for 'con'. */ abs = 3; } } else if ((path[0] == 'l' || path[0] == 'L') && (path[1] == 'p' || path[1] == 'P') && (path[2] == 't' || path[2] == 'T')) { if (path[3] >= '1' && path[3] <= '3') { /* * May have match for 'lpt[1-3]:?' */ if (path[4] == '\0') { abs = 4; } else if (path [4] == ':' && path[5] == '\0') { abs = 5; } } } else if ((path[0] == 'p' || path[0] == 'P') && (path[1] == 'r' || path[1] == 'R') && (path[2] == 'n' || path[2] == 'N') && path[3] == '\0') { /* * Have match for 'prn'. */ abs = 3; } else if ((path[0] == 'n' || path[0] == 'N') && (path[1] == 'u' || path[1] == 'U') && (path[2] == 'l' || path[2] == 'L') && path[3] == '\0') { /* * Have match for 'nul'. */ abs = 3; } else if ((path[0] == 'a' || path[0] == 'A') && (path[1] == 'u' || path[1] == 'U') && (path[2] == 'x' || path[2] == 'X') && path[3] == '\0') { /* * Have match for 'aux'. */ abs = 3; } if (abs != 0) { *typePtr = TCL_PATH_ABSOLUTE; Tcl_DStringSetLength(resultPtr, offset); Tcl_DStringAppend(resultPtr, path, abs); return path + abs; } } /* * Anything else is treated as relative. */ *typePtr = TCL_PATH_RELATIVE; return path; } /* *---------------------------------------------------------------------- * * Tcl_GetPathType -- * * Determines whether a given path is relative to the current directory, * relative to the current volume, or absolute. * * The objectified Tcl_FSGetPathType should be used in preference to this * function (as you can see below, this is just a wrapper around that * other function). * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or * TCL_PATH_VOLUME_RELATIVE. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_PathType Tcl_GetPathType(path) CONST char *path; { Tcl_PathType type; Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1); Tcl_IncrRefCount(tempObj); type = Tcl_FSGetPathType(tempObj); Tcl_DecrRefCount(tempObj); return type; } /* *---------------------------------------------------------------------- * * TclpGetNativePathType -- * * Determines whether a given path is relative to the current directory, * relative to the current volume, or absolute, but ONLY FOR THE NATIVE * FILESYSTEM. This function is called from tclIOUtil.c (but needs to be * here due to its dependence on static variables/functions in this * file). The exported function Tcl_FSGetPathType should be used by * extensions. * * Note that '~' paths are always considered TCL_PATH_ABSOLUTE, even * though expanding the '~' could lead to any possible path type. This * function should therefore be considered a low-level, string * manipulation function only -- it doesn't actually do any expansion in * making its determination. * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or * TCL_PATH_VOLUME_RELATIVE. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_PathType TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef) Tcl_Obj *pathPtr; /* Native path of interest */ int *driveNameLengthPtr; /* Returns length of drive, if non-NULL and * path was absolute */ Tcl_Obj **driveNameRef; { Tcl_PathType type = TCL_PATH_ABSOLUTE; int pathLen; char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); if (path[0] == '~') { /* * This case is common to all platforms. Paths that begin with ~ are * absolute. */ if (driveNameLengthPtr != NULL) { char *end = path + 1; while ((*end != '\0') && (*end != '/')) { end++; } *driveNameLengthPtr = end - path; } |
︙ | ︙ | |||
311 312 313 314 315 316 317 | ++path; } } #endif if (path[0] == '/') { if (driveNameLengthPtr != NULL) { /* | | < > | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 | ++path; } } #endif if (path[0] == '/') { if (driveNameLengthPtr != NULL) { /* * We need this addition in case the QNX code was used. */ *driveNameLengthPtr = (1 + path - origPath); } } else { type = TCL_PATH_RELATIVE; } break; } |
︙ | ︙ | |||
348 349 350 351 352 353 354 | } /* *--------------------------------------------------------------------------- * * TclpNativeSplitPath -- * | | | | | | < | | | | 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 | } /* *--------------------------------------------------------------------------- * * TclpNativeSplitPath -- * * This function takes the given Tcl_Obj, which should be a valid path, * and returns a Tcl List object containing each segment of that path as * an element. * * Note this function currently calls the older Split(Plat)Path * functions, which require more memory allocation than is desirable. * * Results: * Returns list object with refCount of zero. If the passed in lenPtr is * non-NULL, we use it to return the number of elements in the returned * list. * * Side effects: * None. * *--------------------------------------------------------------------------- */ |
︙ | ︙ | |||
403 404 405 406 407 408 409 | } /* *---------------------------------------------------------------------- * * Tcl_SplitPath -- * | | | | < | | | | | | | | | | > | > | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_SplitPath -- * * Split a path into a list of path components. The first element of the * list will have the same path type as the original path. * * Results: * Returns a standard Tcl result. The interpreter result contains a list * of path components. *argvPtr will be filled in with the address of an * array whose elements point to the elements of path, in order. * *argcPtr will get filled in with the number of valid elements in the * array. A single block of memory is dynamically allocated to hold both * the argv array and a copy of the path elements. The caller must * eventually free this memory by calling ckfree() on *argvPtr. Note: * *argvPtr and *argcPtr are only modified if the procedure returns * normally. * * Side effects: * Allocates memory. * *---------------------------------------------------------------------- */ void Tcl_SplitPath(path, argcPtr, argvPtr) CONST char *path; /* Pointer to string containing a path. */ int *argcPtr; /* Pointer to location to fill in with the * number of elements in the path. */ CONST char ***argvPtr; /* Pointer to place to store pointer to array * of pointers to path elements. */ { Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Obj *tmpPtr, *eltPtr; int i, size, len; char *p, *str; /* * Perform the splitting, using objectified, vfs-aware code. */ tmpPtr = Tcl_NewStringObj(path, -1); Tcl_IncrRefCount(tmpPtr); resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr); Tcl_IncrRefCount(resultPtr); Tcl_DecrRefCount(tmpPtr); /* * Calculate space required for the result. */ size = 1; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); Tcl_GetStringFromObj(eltPtr, &len); size += len + 1; } /* * Allocate a buffer large enough to hold the contents of all of the list * plus the argv pointers and the terminating NULL pointer. */ *argvPtr = (CONST char **) ckalloc((unsigned) ((((*argcPtr) + 1) * sizeof(char *)) + size)); /* * Position p after the last argv pointer and copy the contents of the * list in, piece by piece. */ p = (char *) &(*argvPtr)[(*argcPtr) + 1]; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); str = Tcl_GetStringFromObj(eltPtr, &len); memcpy((VOID *) p, (VOID *) str, (size_t) len+1); |
︙ | ︙ | |||
501 502 503 504 505 506 507 | } /* *---------------------------------------------------------------------- * * SplitUnixPath -- * | | | | 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 | } /* *---------------------------------------------------------------------- * * SplitUnixPath -- * * This routine is used by Tcl_(FS)SplitPath to handle splitting Unix * paths. * * Results: * Returns a newly allocated Tcl list object. * * Side effects: * None. * |
︙ | ︙ | |||
572 573 574 575 576 577 578 | } if (*p++ == '\0') { break; } } return result; } | < | | | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 | } if (*p++ == '\0') { break; } } return result; } /* *---------------------------------------------------------------------- * * SplitWinPath -- * * This routine is used by Tcl_(FS)SplitPath to handle splitting Windows * paths. * * Results: * Returns a newly allocated Tcl list object. * * Side effects: * None. * |
︙ | ︙ | |||
615 616 617 618 619 620 621 | if (p != path) { Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj( Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); } Tcl_DStringFree(&buf); /* | | | > > | > > | | < | | | | | | | | | | > | | | < | | > | | | | | | > > < | < | 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 | if (p != path) { Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj( Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); } Tcl_DStringFree(&buf); /* * Split on slashes. Embedded elements that start with tilde or a drive * letter will be prefixed with "./" so they are not affected by tilde * substitution. */ do { elementStart = p; while ((*p != '\0') && (*p != '/') && (*p != '\\')) { p++; } length = p - elementStart; if (length > 0) { Tcl_Obj *nextElt; if ((elementStart != path) && ((elementStart[0] == '~') || (isalpha(UCHAR(elementStart[0])) && elementStart[1] == ':'))) { nextElt = Tcl_NewStringObj("./",2); Tcl_AppendToObj(nextElt, elementStart, length); } else { nextElt = Tcl_NewStringObj(elementStart, length); } Tcl_ListObjAppendElement(NULL, result, nextElt); } } while (*p++ != '\0'); return result; } /* *--------------------------------------------------------------------------- * * Tcl_FSJoinToPath -- * * This function takes the given object, which should usually be a valid * path or NULL, and joins onto it the array of paths segments given. * * The objects in the array given will temporarily have their refCount * increased by one, and then decreased by one when this function exits * (which means if they had zero refCount when we were called, they will * be freed). * * Results: * Returns object owned by the caller (which should increment its * refCount) - typically an object with refCount of zero. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_Obj * Tcl_FSJoinToPath(pathPtr, objc, objv) Tcl_Obj *pathPtr; /* Valid path or NULL. */ int objc; /* Number of array elements to join */ Tcl_Obj *CONST objv[]; /* Path elements to join. */ { int i; Tcl_Obj *lobj, *ret; if (pathPtr == NULL) { lobj = Tcl_NewListObj(0, NULL); } else { lobj = Tcl_NewListObj(1, &pathPtr); } for (i = 0; i<objc;i++) { Tcl_ListObjAppendElement(NULL, lobj, objv[i]); } ret = Tcl_FSJoinPath(lobj, -1); /* * It is possible that 'ret' is just a member of the list and is therefore * going to be freed here. Therefore we must adjust the refCount manually. * (It would be better if we changed the documentation of this function * and Tcl_FSJoinPath so that the returned object already has a refCount * for the caller, hence avoiding these subtleties (and code ugliness)). */ Tcl_IncrRefCount(ret); Tcl_DecrRefCount(lobj); ret->refCount--; return ret; } /* *--------------------------------------------------------------------------- * * TclpNativeJoinPath -- * * 'prefix' is absolute, 'joining' is relative to prefix. * * Results: * modifies prefix * * Side effects: * None. * *--------------------------------------------------------------------------- */ void TclpNativeJoinPath(prefix, joining) Tcl_Obj *prefix; char *joining; { int length, needsSep; char *dest, *p, *start; start = Tcl_GetStringFromObj(prefix, &length); /* * Remove the ./ from tilde prefixed elements, and drive-letter prefixed * elements on Windows, unless it is the first component. */ p = joining; if (length != 0) { if ((p[0] == '.') && (p[1] == '/') && ((p[2] == '~') || (tclPlatform==TCL_PLATFORM_WINDOWS && isalpha(UCHAR(p[2])) && (p[3] == ':')))) { p += 2; } } if (*p == '\0') { return; } switch (tclPlatform) { case TCL_PLATFORM_UNIX: /* * Append a separator if needed. */ if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); length++; } needsSep = 0; /* * Append the element, eliminating duplicate and trailing slashes. */ Tcl_SetObjLength(prefix, length + (int) strlen(p)); dest = Tcl_GetString(prefix) + length; for (; *p != '\0'; p++) { if (*p == '/') { |
︙ | ︙ | |||
790 791 792 793 794 795 796 | (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); length++; } needsSep = 0; /* | | < | 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 | (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); length++; } needsSep = 0; /* * Append the element, eliminating duplicate and trailing slashes. */ Tcl_SetObjLength(prefix, length + (int) strlen(p)); dest = Tcl_GetString(prefix) + length; for (; *p != '\0'; p++) { if ((*p == '/') || (*p == '\\')) { while ((p[1] == '/') || (p[1] == '\\')) { |
︙ | ︙ | |||
821 822 823 824 825 826 827 | } /* *---------------------------------------------------------------------- * * Tcl_JoinPath -- * | | | < | | | > | > > | > | > > > | > > > | > > | | | | | | | | < | | > | | | | | | > | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_JoinPath -- * * Combine a list of paths in a platform specific manner. The function * 'Tcl_FSJoinPath' should be used in preference where possible. * * Results: * Appends the joined path to the end of the specified Tcl_DString * returning a pointer to the resulting string. Note that the * Tcl_DString must already be initialized. * * Side effects: * Modifies the Tcl_DString. * *---------------------------------------------------------------------- */ char * Tcl_JoinPath(argc, argv, resultPtr) int argc; CONST char * CONST *argv; Tcl_DString *resultPtr; /* Pointer to previously initialized DString */ { int i, len; Tcl_Obj *listObj = Tcl_NewObj(); Tcl_Obj *resultObj; char *resultStr; /* * Build the list of paths. */ for (i = 0; i < argc; i++) { Tcl_ListObjAppendElement(NULL, listObj, Tcl_NewStringObj(argv[i], -1)); } /* * Ask the objectified code to join the paths. */ Tcl_IncrRefCount(listObj); resultObj = Tcl_FSJoinPath(listObj, argc); Tcl_IncrRefCount(resultObj); Tcl_DecrRefCount(listObj); /* * Store the result. */ resultStr = Tcl_GetStringFromObj(resultObj, &len); Tcl_DStringAppend(resultPtr, resultStr, len); Tcl_DecrRefCount(resultObj); /* * Return a pointer to the result. */ return Tcl_DStringValue(resultPtr); } /* *--------------------------------------------------------------------------- * * Tcl_TranslateFileName -- * * Converts a file name into a form usable by the native system * interfaces. If the name starts with a tilde, it will produce a name * where the tilde and following characters have been replaced by the * home directory location for the named user. * * Results: * The return value is a pointer to a string containing the name after * tilde substitution. If there was no tilde substitution, the return * value is a pointer to a copy of the original string. If there was an * error in processing the name, then an error message is left in the * interp's result (if interp was not NULL) and the return value is NULL. * Space for the return value is allocated in bufferPtr; the caller must * call Tcl_DStringFree() to free the space if the return value was not * NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * Tcl_TranslateFileName(interp, name, bufferPtr) Tcl_Interp *interp; /* Interpreter in which to store error message * (if necessary). */ CONST char *name; /* File name, which may begin with "~" (to * indicate current user's home directory) or * "~<user>" (to indicate any user's home * directory). */ Tcl_DString *bufferPtr; /* Uninitialized or free DString filled with * name after tilde substitution. */ { Tcl_Obj *path = Tcl_NewStringObj(name, -1); Tcl_Obj *transPtr; Tcl_IncrRefCount(path); transPtr = Tcl_FSGetTranslatedPath(interp, path); if (transPtr == NULL) { Tcl_DecrRefCount(path); return NULL; } Tcl_DStringInit(bufferPtr); Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1); Tcl_DecrRefCount(path); Tcl_DecrRefCount(transPtr); /* * Convert forward slashes to backslashes in Windows paths because some * system interfaces don't accept forward slashes. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { register char *p; for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { if (*p == '/') { *p = '\\'; } } } return Tcl_DStringValue(bufferPtr); } /* *---------------------------------------------------------------------- * * TclGetExtension -- * * This function returns a pointer to the beginning of the extension part * of a file name. * * Results: * Returns a pointer into name which indicates where the extension * starts. If there is no extension, returns NULL. * * Side effects: * None. |
︙ | ︙ | |||
1004 1005 1006 1007 1008 1009 1010 | * DoTildeSubst -- * * Given a string following a tilde, this routine returns the * corresponding home directory. * * Results: * The result is a pointer to a static string containing the home | | | | | < | | | | | 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 | * DoTildeSubst -- * * Given a string following a tilde, this routine returns the * corresponding home directory. * * Results: * The result is a pointer to a static string containing the home * directory in native format. If there was an error in processing the * substitution, then an error message is left in the interp's result and * the return value is NULL. On success, the results are appended to * resultPtr, and the contents of resultPtr are returned. * * Side effects: * Information may be left in resultPtr. * *---------------------------------------------------------------------- */ static CONST char * DoTildeSubst(interp, user, resultPtr) Tcl_Interp *interp; /* Interpreter in which to store error message * (if necessary). */ CONST char *user; /* Name of user whose home directory should be * substituted, or "" for current user. */ Tcl_DString *resultPtr; /* Initialized DString filled with name after * tilde substitution. */ { CONST char *dir; if (*user == '\0') { Tcl_DString dirString; dir = TclGetEnv("HOME", &dirString); |
︙ | ︙ | |||
1057 1058 1059 1060 1061 1062 1063 | } /* *---------------------------------------------------------------------- * * Tcl_GlobObjCmd -- * | | | | 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 | } /* *---------------------------------------------------------------------- * * Tcl_GlobObjCmd -- * * This procedure is invoked to process the "glob" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
1103 1104 1105 1106 1107 1108 1109 | typePtr = NULL; for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { string = Tcl_GetStringFromObj(objv[i], &length); if (string[0] == '-') { /* | | | > | | > > | 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 | typePtr = NULL; for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { string = Tcl_GetStringFromObj(objv[i], &length); if (string[0] == '-') { /* * It looks like the command contains an option so signal an * error. */ return TCL_ERROR; } else { /* * This clearly isn't an option; assume it's the first glob * pattern. We must clear the error. */ Tcl_ResetResult(interp); break; } } switch (index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ globFlags |= TCL_GLOBMODE_NO_COMPLAIN; break; case GLOB_DIR: /* -dir */ if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( |
︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 1181 1182 | i++; break; case GLOB_LAST: /* -- */ i++; goto endOfForLoop; } } endOfForLoop: if (objc - i < 1) { | > | | > > > > | > > > | | | | < > > | > > > | | < | | > > > | > > | 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 | i++; break; case GLOB_LAST: /* -- */ i++; goto endOfForLoop; } } endOfForLoop: if (objc - i < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?"); return TCL_ERROR; } if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) { Tcl_AppendResult(interp, "\"-tails\" must be used with either ", "\"-directory\" or \"-path\"", NULL); return TCL_ERROR; } separators = NULL; /* lint. */ switch (tclPlatform) { case TCL_PLATFORM_UNIX: separators = "/"; break; case TCL_PLATFORM_WINDOWS: separators = "/\\:"; break; } if (dir == PATH_GENERAL) { int pathlength; char *last; char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path */ last = first + pathlength; for (; last != first; last--) { if (strchr(separators, *(last-1)) != NULL) { break; } } if (last == first + pathlength) { /* * It's really a directory. */ dir = PATH_DIR; } else { Tcl_DString pref; char *search, *find; Tcl_DStringInit(&pref); if (last == first) { /* * The whole thing is a prefix. This means we must remove any * 'tails' flag too, since it is irrelevant now (the same * effect will happen without it), but in particular its use * in TclGlob requires a non-NULL pathOrDir. */ Tcl_DStringAppend(&pref, first, -1); globFlags &= ~TCL_GLOBMODE_TAILS; pathOrDir = NULL; } else { /* * Have to split off the end. */ Tcl_DStringAppend(&pref, last, first+pathlength-last); pathOrDir = Tcl_NewStringObj(first, last-first-1); /* * We must ensure that we haven't cut off too much, and turned * a valid path like '/' or 'C:/' into an incorrect path like * '' or 'C:'. The way we do this is to add a separator if * there are none presently in the prefix. */ if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) { Tcl_AppendToObj(pathOrDir, last-1, 1); } } /* * Need to quote 'prefix'. */ Tcl_DStringInit(&prefix); search = Tcl_DStringValue(&pref); while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) { Tcl_DStringAppend(&prefix, search, find-search); Tcl_DStringAppend(&prefix, "\\", 1); Tcl_DStringAppend(&prefix, find, 1); search = find+1; |
︙ | ︙ | |||
1267 1268 1269 1270 1271 1272 1273 | if (pathOrDir != NULL) { Tcl_IncrRefCount(pathOrDir); } if (typePtr != NULL) { /* | | | | > > > | 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 | if (pathOrDir != NULL) { Tcl_IncrRefCount(pathOrDir); } if (typePtr != NULL) { /* * The rest of the possible type arguments (except 'd') are platform * specific. We don't complain when they are used on an incompatible * platform. */ Tcl_ListObjLength(interp, typePtr, &length); globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData)); globTypes->type = 0; globTypes->perm = 0; globTypes->macType = NULL; globTypes->macCreator = NULL; while (--length >= 0) { int len; char *str; Tcl_ListObjIndex(interp, typePtr, length, &look); str = Tcl_GetStringFromObj(look, &len); if (strcmp("readonly", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_RONLY; } else if (strcmp("hidden", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_HIDDEN; } else if (len == 1) { |
︙ | ︙ | |||
1321 1322 1323 1324 1325 1326 1327 1328 | break; case 's': globTypes->type |= TCL_GLOB_TYPE_SOCK; break; default: goto badTypesArg; } } else if (len == 4) { | > > | > > > > | 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 | break; case 's': globTypes->type |= TCL_GLOB_TYPE_SOCK; break; default: goto badTypesArg; } } else if (len == 4) { /* * This is assumed to be a MacOS file type. */ if (globTypes->macType != NULL) { goto badMacTypesArg; } globTypes->macType = look; Tcl_IncrRefCount(look); } else { Tcl_Obj* item; if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); if (!strcmp("macintosh", Tcl_GetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); if (!strcmp("type", Tcl_GetString(item))) { Tcl_ListObjIndex(interp, look, 2, &item); |
︙ | ︙ | |||
1354 1355 1356 1357 1358 1359 1360 1361 | } globTypes->macCreator = item; Tcl_IncrRefCount(item); continue; } } } /* | > | < | > | > | | | | < > > | | < | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | > | > > > > | 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 | } globTypes->macCreator = item; Tcl_IncrRefCount(item); continue; } } } /* * Error cases. We reset the 'join' flag to zero, since we * haven't yet made use of it. */ badTypesArg: TclNewObj(resultPtr); Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1); Tcl_AppendObjToObj(resultPtr, look); Tcl_SetObjResult(interp, resultPtr); result = TCL_ERROR; join = 0; goto endOfGlob; badMacTypesArg: Tcl_SetObjResult(interp, Tcl_NewStringObj( "only one MacOS type or creator argument" " to \"-types\" allowed", -1)); result = TCL_ERROR; join = 0; goto endOfGlob; } } } /* * Now we perform the actual glob below. This may involve joining together * the pattern arguments, dealing with particular file types etc. We use a * 'goto' to ensure we free any memory allocated along the way. */ objc -= i; objv += i; result = TCL_OK; if (join) { if (dir != PATH_GENERAL) { Tcl_DStringInit(&prefix); } for (i = 0; i < objc; i++) { string = Tcl_GetStringFromObj(objv[i], &length); Tcl_DStringAppend(&prefix, string, length); if (i != objc -1) { Tcl_DStringAppend(&prefix, separators, 1); } } if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir, globFlags, globTypes) != TCL_OK) { result = TCL_ERROR; goto endOfGlob; } } else if (dir == PATH_GENERAL) { Tcl_DString str; for (i = 0; i < objc; i++) { Tcl_DStringInit(&str); if (dir == PATH_GENERAL) { Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix), Tcl_DStringLength(&prefix)); } string = Tcl_GetStringFromObj(objv[i], &length); Tcl_DStringAppend(&str, string, length); if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir, globFlags, globTypes) != TCL_OK) { result = TCL_ERROR; Tcl_DStringFree(&str); goto endOfGlob; } } Tcl_DStringFree(&str); } else { for (i = 0; i < objc; i++) { string = Tcl_GetString(objv[i]); if (TclGlob(interp, string, pathOrDir, globFlags, globTypes) != TCL_OK) { result = TCL_ERROR; goto endOfGlob; } } } if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), &length) != TCL_OK) { /* * This should never happen. Maybe we should be more dramatic. */ result = TCL_ERROR; goto endOfGlob; } if (length == 0) { Tcl_AppendResult(interp, "no files matched glob pattern", (join || (objc == 1)) ? " \"" : "s \"", (char *) NULL); if (join) { Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), (char *) NULL); } else { char *sep = ""; for (i = 0; i < objc; i++) { string = Tcl_GetString(objv[i]); Tcl_AppendResult(interp, sep, string, (char *) NULL); sep = " "; } } Tcl_AppendResult(interp, "\"", (char *) NULL); result = TCL_ERROR; } } endOfGlob: if (join || (dir == PATH_GENERAL)) { Tcl_DStringFree(&prefix); } if (pathOrDir != NULL) { Tcl_DecrRefCount(pathOrDir); } |
︙ | ︙ | |||
1482 1483 1484 1485 1486 1487 1488 | } /* *---------------------------------------------------------------------- * * TclGlob -- * | | | | | | | | | | < | | | < | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TclGlob -- * * This procedure prepares arguments for the DoGlob call. It sets the * separator string based on the platform, performs * tilde substitution, * and calls DoGlob. * * The interpreter's result, on entry to this function, must be a valid * Tcl list (e.g. it could be empty), since we will lappend any new * results to that list. If it is not a valid list, this function will * fail to do anything very meaningful. * * Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then pathPrefix * cannot be NULL (it is only allowed with -dir or -path). * * Results: * The return value is a standard Tcl result indicating whether an error * occurred in globbing. After a normal return the result in interp (set * by DoGlob) holds all of the file names given by the pattern and * pathPrefix arguments. After an error the result in interp will hold * an error message, unless the 'TCL_GLOBMODE_NO_COMPLAIN' flag was * given, in which case an error results in a TCL_OK return leaving the * interpreter's result unmodified. * * Side effects: * The 'pattern' is written to. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int TclGlob(interp, pattern, pathPrefix, globFlags, types) Tcl_Interp *interp; /* Interpreter for returning error message or * appending list of matching file names. */ char *pattern; /* Glob pattern to match. Must not refer to a * static string. */ Tcl_Obj *pathPrefix; /* Path prefix to glob pattern, if non-null, * which is considered literally. */ int globFlags; /* Stores or'ed combination of flags */ Tcl_GlobTypeData *types; /* Struct containing acceptable types. May be * NULL. */ { char *separators; CONST char *head; char *tail, *start; int result; Tcl_Obj *filenamesObj, *savedResultObj; |
︙ | ︙ | |||
1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 | if (pathPrefix == NULL) { char c; Tcl_DString buffer; Tcl_DStringInit(&buffer); start = pattern; /* * Perform tilde substitution, if needed. */ if (start[0] == '~') { | > < > | | | | | | < | | | 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 | if (pathPrefix == NULL) { char c; Tcl_DString buffer; Tcl_DStringInit(&buffer); start = pattern; /* * Perform tilde substitution, if needed. */ if (start[0] == '~') { /* * Find the first path separator after the tilde. */ for (tail = start; *tail != '\0'; tail++) { if (*tail == '\\') { if (strchr(separators, tail[1]) != NULL) { break; } } else if (strchr(separators, *tail) != NULL) { break; } } /* * Determine the home directory for the specified user. */ c = *tail; *tail = '\0'; if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { /* * We will ignore any error message here, and we don't want to * mess up the interpreter's result. */ head = DoTildeSubst(NULL, start+1, &buffer); } else { head = DoTildeSubst(interp, start+1, &buffer); } *tail = c; if (head == NULL) { if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { return TCL_OK; } else { return TCL_ERROR; } } if (head != Tcl_DStringValue(&buffer)) { Tcl_DStringAppend(&buffer, head, -1); } pathPrefix = Tcl_NewStringObj(Tcl_DStringValue(&buffer), Tcl_DStringLength(&buffer)); Tcl_IncrRefCount(pathPrefix); globFlags |= TCL_GLOBMODE_DIR; if (c != '\0') { tail++; } Tcl_DStringFree(&buffer); } else { tail = pattern; } } else { Tcl_IncrRefCount(pathPrefix); tail = pattern; } /* * Handling empty path prefixes with glob patterns like 'C:' or * 'c:////////' is a pain on Windows if we leave it too late, since these * aren't really patterns at all! We therefore check the head of the * pattern now for such cases, if we don't have an unquoted prefix yet. * * Similarly on Unix with '/' at the head of the pattern -- it just * indicates the root volume, so we treat it as such. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { if (pathPrefix == NULL && tail[0] != '\0' && tail[1] == ':') { char *p = tail + 1; pathPrefix = Tcl_NewStringObj(tail, 1); while (*p != '\0') { |
︙ | ︙ | |||
1645 1646 1647 1648 1649 1650 1651 | } p++; } tail = p; Tcl_IncrRefCount(pathPrefix); } else if (pathPrefix == NULL && (tail[0] == '/' || (tail[0] == '\\' && tail[1] == '\\'))) { | | | | | | | | | | > | 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 | } p++; } tail = p; Tcl_IncrRefCount(pathPrefix); } else if (pathPrefix == NULL && (tail[0] == '/' || (tail[0] == '\\' && tail[1] == '\\'))) { int driveNameLen; Tcl_Obj *driveName; Tcl_Obj *temp = Tcl_NewStringObj(tail, -1); Tcl_IncrRefCount(temp); switch (TclGetPathType(temp, NULL, &driveNameLen, &driveName)) { case TCL_PATH_VOLUME_RELATIVE: { /* * Volume relative path which is equivalent to a path in the * root of the cwd's volume. We will actually return * non-volume-relative paths here. i.e. 'glob /foo*' will * return 'C:/foobar'. This is much the same as globbing for * a path with '\\' will return one with '/' on Windows. */ Tcl_Obj *cwd = Tcl_FSGetCwd(interp); if (cwd == NULL) { Tcl_DecrRefCount(temp); if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { return TCL_OK; } else { |
︙ | ︙ | |||
1681 1682 1683 1684 1685 1686 1687 | tail+=2; } Tcl_IncrRefCount(pathPrefix); break; } case TCL_PATH_ABSOLUTE: /* | | | < > | | > | | > > | | | | | | | | | 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 | tail+=2; } Tcl_IncrRefCount(pathPrefix); break; } case TCL_PATH_ABSOLUTE: /* * Absolute, possibly network path //Machine/Share. Use that * as the path prefix (it already has a refCount). */ pathPrefix = driveName; tail += driveNameLen; break; case TCL_PATH_RELATIVE: /* Do nothing */ break; } Tcl_DecrRefCount(temp); } /* * ':' no longer needed as a separator. It is only relevant to the * beginning of the path. */ separators = "/\\"; } else if (tclPlatform == TCL_PLATFORM_UNIX) { if (pathPrefix == NULL && tail[0] == '/') { pathPrefix = Tcl_NewStringObj(tail, 1); tail++; Tcl_IncrRefCount(pathPrefix); } } /* * Finally if we still haven't managed to generate a path prefix, check if * the path starts with a current volume. */ if (pathPrefix == NULL) { int driveNameLen; Tcl_Obj *driveName; if (TclFSNonnativePathType(tail, (int) strlen(tail), NULL, &driveNameLen, &driveName) == TCL_PATH_ABSOLUTE) { pathPrefix = driveName; tail += driveNameLen; } } /* * To process a [glob] invokation, this function may be called multiple * times. Each time, the previously discovered filenames are in the * interpreter result. We stash that away here so the result is free for * error messsages. */ savedResultObj = Tcl_GetObjResult(interp); Tcl_IncrRefCount(savedResultObj); Tcl_ResetResult(interp); TclNewObj(filenamesObj); /* * Now we do the actual globbing, adding filenames as we go to buffer in * filenamesObj */ if (*tail == '\0' && pathPrefix != NULL) { /* * An empty pattern */ result = Tcl_FSMatchInDirectory(interp, filenamesObj, pathPrefix, |
︙ | ︙ | |||
1766 1767 1768 1769 1770 1771 1772 | result = TCL_OK; } TclDecrRefCount(savedResultObj); return result; } /* | | | | | < | | > | > > | | < | | | < | | | < | | < | | | < | 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 | result = TCL_OK; } TclDecrRefCount(savedResultObj); return result; } /* * If we only want the tails, we must strip off the prefix now. It may * seem more efficient to pass the tails flag down into DoGlob, * Tcl_FSMatchInDirectory, but those functions are continually adjusting * the prefix as the various pieces of the pattern are assimilated, so * that would add a lot of complexity to the code. This way is a little * slower (when the -tails flag is given), but much simpler to code. * * We do it by rewriting the result list in-place. */ if (globFlags & TCL_GLOBMODE_TAILS) { int objc, i; Tcl_Obj **objv; int prefixLen; /* * If this length has never been set, set it here. */ CONST char *pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); if (prefixLen > 0 && (strchr(separators, pre[prefixLen-1]) == NULL)) { /* * If we're on Windows and the prefix is a volume relative one * like 'C:', then there won't be a path separator in between, so * no need to skip it here. */ if ((tclPlatform != TCL_PLATFORM_WINDOWS) || (prefixLen != 2) || (pre[1] != ':')) { prefixLen++; } } Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { int len; char *oldStr = Tcl_GetStringFromObj(objv[i], &len); Tcl_Obj* elems[1]; if (len == prefixLen) { if ((pattern[0] == '\0') || (strchr(separators, pattern[0]) == NULL)) { elems[0] = Tcl_NewStringObj(".", 1); } else { elems[0] = Tcl_NewStringObj("/", 1); } } else { elems[0] = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen); } Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, elems); } } /* * Now we have a list of discovered filenames in filenamesObj and a list * of previously discovered (saved earlier from the interpreter result) in * savedResultObj. Merge them and put them back in the interpreter result. */ if (Tcl_IsShared(savedResultObj)) { TclDecrRefCount(savedResultObj); savedResultObj = Tcl_DuplicateObj(savedResultObj); Tcl_IncrRefCount(savedResultObj); } |
︙ | ︙ | |||
1850 1851 1852 1853 1854 1855 1856 | } /* *---------------------------------------------------------------------- * * SkipToChar -- * | | | < | | | | 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 | } /* *---------------------------------------------------------------------- * * SkipToChar -- * * This function traverses a glob pattern looking for the next unquoted * occurance of the specified character at the same braces nesting level. * * Results: * Updates stringPtr to point to the matching character, or to the end of * the string if nothing matched. The return value is 1 if a match was * found at the top level, otherwise it is 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1902 1903 1904 1905 1906 1907 1908 | } /* *---------------------------------------------------------------------- * * DoGlob -- * | | | | < | | | | | | | | | | | | | | < | | | | | | | > | | | | > | | < > | | | | | | | > > | > > > | > > > | > > > | | | | 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 | } /* *---------------------------------------------------------------------- * * DoGlob -- * * This recursive procedure forms the heart of the globbing code. It * performs a depth-first traversal of the tree given by the path name to * be globbed and the pattern. The directory and remainder are assumed to * be native format paths. The prefix contained in 'pathPtr' is either a * directory or path from which to start the search (or NULL). If pathPtr * is NULL, then the pattern must not start with an absolute path * specification (that case should be handled by moving the absolute path * prefix into pathPtr before calling DoGlob). * * Results: * The return value is a standard Tcl result indicating whether an error * occurred in globbing. After a normal return the result in interp will * be set to hold all of the file names given by the dir and remaining * arguments. After an error the result in interp will hold an error * message. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) Tcl_Interp *interp; /* Interpreter to use for error reporting * (e.g. unmatched brace). */ Tcl_Obj *matchesObj; /* Unshared list object in which to place all * resulting filenames. Caller allocates and * deallocates; DoGlob must not touch the * refCount of this object. */ char *separators; /* String containing separator characters that * should be used to identify globbing * boundaries. */ Tcl_Obj *pathPtr; /* Completely expanded prefix. */ int flags; /* If non-zero then pathPtr is a directory */ char *pattern; /* The pattern to match against. Must not be * a pointer to a static string. */ Tcl_GlobTypeData *types; /* List object containing list of acceptable * types. May be NULL. */ { int baseLength, quoted, count; int result = TCL_OK; char *name, *p, *openBrace, *closeBrace, *firstSpecialChar; Tcl_Obj *joinedPtr; /* * Consume any leading directory separators, leaving pattern pointing just * past the last initial separator. */ count = 0; name = pattern; for (; *pattern != '\0'; pattern++) { if (*pattern == '\\') { /* * If the first character is escaped, either we have a directory * separator, or we have any other character. In the latter case * the rest is a pattern, and we must break from the loop. This * is particularly important on Windows where '\' is both the * escaping character and a directory separator. */ if (strchr(separators, pattern[1]) != NULL) { pattern++; } else { break; } } else if (strchr(separators, *pattern) == NULL) { break; } count++; } /* * This block of code is not exercised by the Tcl test suite as of Tcl * 8.5a0. Simplifications to the calling paths suggest it may not be * necessary any more, since path separators are handled elsewhere. It is * left in place in case new bugs are reported */ #if 0 /* PROBABLY_OBSOLETE */ /* * Deal with path separators. */ if (pathPtr == NULL) { /* * Length used to be the length of the prefix, and lastChar the * lastChar of the prefix. But, none of this is used any more. */ int length = 0; char lastChar = 0; switch (tclPlatform) { case TCL_PLATFORM_WINDOWS: /* * If this is a drive relative path, add the colon and the * trailing slash if needed. Otherwise add the slash if this is * the first absolute element, or a later relative element. Add * an extra slash if this is a UNC path. */ if (*name == ':') { Tcl_DStringAppend(&append, ":", 1); if (count > 1) { Tcl_DStringAppend(&append, "/", 1); } } else if ((*pattern != '\0') && (((length > 0) && (strchr(separators, lastChar) == NULL)) || ((length == 0) && (count > 0)))) { Tcl_DStringAppend(&append, "/", 1); if ((length == 0) && (count > 1)) { Tcl_DStringAppend(&append, "/", 1); } } break; case TCL_PLATFORM_UNIX: /* * Add a separator if this is the first absolute element, or a * later relative element. */ if ((*pattern != '\0') && (((length > 0) && (strchr(separators, lastChar) == NULL)) || ((length == 0) && (count > 0)))) { Tcl_DStringAppend(&append, "/", 1); } break; } } #endif /* PROBABLY_OBSOLETE */ /* * Look for the first matching pair of braces or the first directory * separator that is not inside a pair of braces. */ openBrace = closeBrace = NULL; quoted = 0; for (p = pattern; *p != '\0'; p++) { if (quoted) { quoted = 0; } else if (*p == '\\') { quoted = 1; if (strchr(separators, p[1]) != NULL) { /* * Quoted directory separator. */ break; } } else if (strchr(separators, *p) != NULL) { /* * Unquoted directory separator. */ break; } else if (*p == '{') { openBrace = p; p++; if (SkipToChar(&p, '}')) { /* * Balanced braces. */ closeBrace = p; break; } Tcl_SetResult(interp, "unmatched open-brace in file name", TCL_STATIC); return TCL_ERROR; } else if (*p == '}') { Tcl_SetResult(interp, "unmatched close-brace in file name", TCL_STATIC); return TCL_ERROR; } } /* * Substitute the alternate patterns from the braces and recurse. */ if (openBrace != NULL) { char *element; Tcl_DString newName; Tcl_DStringInit(&newName); /* * For each element within in the outermost pair of braces, append the * element and the remainder to the fixed portion before the first * brace and recursively call DoGlob. */ Tcl_DStringAppend(&newName, pattern, openBrace-pattern); baseLength = Tcl_DStringLength(&newName); *closeBrace = '\0'; for (p = openBrace; p != closeBrace; ) { p++; |
︙ | ︙ | |||
2111 2112 2113 2114 2115 2116 2117 | } *closeBrace = '}'; Tcl_DStringFree(&newName); return result; } /* | | | | | | | | | | | | | | | | | | < | | 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 | } *closeBrace = '}'; Tcl_DStringFree(&newName); return result; } /* * At this point, there are no more brace substitutions to perform on this * path component. The variable p is pointing at a quoted or unquoted * directory separator or the end of the string. So we need to check for * special globbing characters in the current pattern. We avoid modifying * pattern if p is pointing at the end of the string. * * If we find any globbing characters, then we must call * Tcl_FSMatchInDirectory. If we're at the end of the string, then that's * all we need to do. If we're not at the end of the string, then we must * recurse, so we do that below. * * Alternatively, if there are no globbing characters then again there are * two cases. If we're at the end of the string, we just need to check for * the given path's existence and type. If we're not at the end of the * string, we recurse. */ if (*p != '\0') { /* * Note that we are modifying the string in place. This won't work if * the string is a static. */ char savedChar = *p; *p = '\0'; firstSpecialChar = strpbrk(pattern, "*[]?\\"); *p = savedChar; } else { firstSpecialChar = strpbrk(pattern, "*[]?\\"); } if (firstSpecialChar != NULL) { /* * Look for matching files in the given directory. The implementation * of this function is filesystem specific. For each file that * matches, it will add the match onto the resultPtr given. */ static Tcl_GlobTypeData dirOnly = { TCL_GLOB_TYPE_DIR, 0, NULL, NULL }; char save = *p; Tcl_Obj* subdirsPtr; if (*p == '\0') { return Tcl_FSMatchInDirectory(interp, matchesObj, pathPtr, pattern, types); } /* * We do the recursion ourselves. This makes implementing * Tcl_FSMatchInDirectory for each filesystem much easier. */ *p = '\0'; TclNewObj(subdirsPtr); result = Tcl_FSMatchInDirectory(interp, subdirsPtr, pathPtr, pattern, &dirOnly); |
︙ | ︙ | |||
2194 2195 2196 2197 2198 2199 2200 | * We reach here with no pattern char in current section */ if (*p == '\0') { /* * This is the code path reached by a command like 'glob foo'. * | | | | | | | | | 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 | * We reach here with no pattern char in current section */ if (*p == '\0') { /* * This is the code path reached by a command like 'glob foo'. * * There are no more wildcards in the pattern and no more unprocessed * characters in the pattern, so now we can construct the path, and * pass it to Tcl_FSMatchInDirectory with an empty pattern to verify * the existence of the file and check it is of the correct type (if a * 'types' flag it given -- if no such flag was given, we could just * use 'Tcl_FSLStat', but for simplicity we keep to a common * approach). */ int length; Tcl_DString append; Tcl_DStringInit(&append); Tcl_DStringAppend(&append, pattern, p-pattern); |
︙ | ︙ | |||
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 | if (((*name == '\\') && (name[1] == '/' || name[1] == '\\')) || (*name == '/')) { Tcl_DStringAppend(&append, "/", 1); } else { Tcl_DStringAppend(&append, ".", 1); } } #if defined(__CYGWIN__) && defined(__WIN32__) { extern int cygwin_conv_to_win32_path(CONST char *, char *); char winbuf[MAX_PATH+1]; cygwin_conv_to_win32_path(Tcl_DStringValue(&append), winbuf); Tcl_DStringFree(&append); Tcl_DStringAppend(&append, winbuf, -1); } #endif /* __CYGWIN__ && __WIN32__ */ break; case TCL_PLATFORM_UNIX: if (length == 0 && (Tcl_DStringLength(&append) == 0)) { if ((*name == '\\' && name[1] == '/') || (*name == '/')) { Tcl_DStringAppend(&append, "/", 1); } else { Tcl_DStringAppend(&append, ".", 1); } } break; } | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | > > > > > > > > | 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 | if (((*name == '\\') && (name[1] == '/' || name[1] == '\\')) || (*name == '/')) { Tcl_DStringAppend(&append, "/", 1); } else { Tcl_DStringAppend(&append, ".", 1); } } #if defined(__CYGWIN__) && defined(__WIN32__) { extern int cygwin_conv_to_win32_path(CONST char *, char *); char winbuf[MAX_PATH+1]; cygwin_conv_to_win32_path(Tcl_DStringValue(&append), winbuf); Tcl_DStringFree(&append); Tcl_DStringAppend(&append, winbuf, -1); } #endif /* __CYGWIN__ && __WIN32__ */ break; case TCL_PLATFORM_UNIX: if (length == 0 && (Tcl_DStringLength(&append) == 0)) { if ((*name == '\\' && name[1] == '/') || (*name == '/')) { Tcl_DStringAppend(&append, "/", 1); } else { Tcl_DStringAppend(&append, ".", 1); } } break; } /* * Common for all platforms. */ if (pathPtr == NULL) { joinedPtr = Tcl_NewStringObj(Tcl_DStringValue(&append), Tcl_DStringLength(&append)); } else if (flags) { joinedPtr = TclNewFSPathObj(pathPtr, Tcl_DStringValue(&append), Tcl_DStringLength(&append)); } else { joinedPtr = Tcl_DuplicateObj(pathPtr); if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) { /* * The current prefix must end in a separator. */ int len; CONST char *joined = Tcl_GetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { Tcl_AppendToObj(joinedPtr, "/", 1); } } Tcl_AppendToObj(joinedPtr, Tcl_DStringValue(&append), Tcl_DStringLength(&append)); } Tcl_IncrRefCount(joinedPtr); Tcl_DStringFree(&append); Tcl_FSMatchInDirectory(interp, matchesObj, joinedPtr, NULL, types); Tcl_DecrRefCount(joinedPtr); return TCL_OK; } /* * If it's not the end of the string, we must recurse */ if (pathPtr == NULL) { joinedPtr = Tcl_NewStringObj(pattern, p-pattern); } else if (flags) { joinedPtr = TclNewFSPathObj(pathPtr, pattern, p-pattern); } else { joinedPtr = Tcl_DuplicateObj(pathPtr); if (strchr(separators, pattern[0]) == NULL) { /* * The current prefix must end in a separator, unless this is a * volume-relative path. In particular globbing in Windows * shares, when not using -dir or -path, e.g. 'glob [file join * //machine/share/subdir *]' requires adding a separator here. * This behaviour is not currently tested for in the test suite. */ int len; CONST char *joined = Tcl_GetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { Tcl_AppendToObj(joinedPtr, "/", 1); } } } Tcl_AppendToObj(joinedPtr, pattern, p-pattern); } Tcl_IncrRefCount(joinedPtr); result = DoGlob(interp, matchesObj, separators, joinedPtr, 1, p, types); Tcl_DecrRefCount(joinedPtr); return result; } /* *--------------------------------------------------------------------------- * * Tcl_AllocStatBuf -- * * This procedure allocates a Tcl_StatBuf on the heap. It exists so that * extensions may be used unchanged on systems where largefile support is * optional. * * Results: * A pointer to a Tcl_StatBuf which may be deallocated by being passed to * ckfree(). * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_StatBuf * Tcl_AllocStatBuf() { return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf)); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclGet.c.
|
| | | | | | | | < | | | | | | | < < < | < < < < < | < < < < < < < < < < | < < < < < < < < < < < | < < | | > | < < | < < < | < | < < < < < < | < < < < < < < < < | | | | | | | | < | | | | | < < < < | < < < < | < < < < | < < < < < < < < < < < | < < | | > | < < < < < < | < < < < < < < | < > < | | | | | | | | | | | | < < < < | | < < < < | < < < < < < | < > < | | | | | | | | | | | > | < < < < < < | < < < < < < < < < < < | | < < | | | < < < < < < < < | < < < < < < > | | < | < < | | | < | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | /* * tclGet.c -- * * This file contains functions to convert strings into other forms, like * integers or floating-point numbers or booleans, doing syntax checking * along the way. * * Copyright (c) 1990-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclGet.c,v 1.9.2.5 2005/08/02 18:15:29 dgp Exp $ */ #include "tclInt.h" /* *---------------------------------------------------------------------- * * Tcl_GetInt -- * * Given a string, produce the corresponding integer value. * * Results: * The return value is normally TCL_OK; in this case *intPtr will be set * to the integer value equivalent to src. If src is improperly formed * then TCL_ERROR is returned and an error message will be left in the * interp's result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetInt(interp, src, intPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ CONST char *src; /* String containing a (possibly signed) * integer in a form acceptable to strtoul. */ int *intPtr; /* Place to store converted result. */ { Tcl_Obj obj; int code; obj.refCount = 1; obj.bytes = (char *) src; obj.length = strlen(src); obj.typePtr = NULL; code = Tcl_GetIntFromObj(interp, &obj, intPtr); if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } return code; } /* *---------------------------------------------------------------------- * * TclGetLong -- * * Given a string, produce the corresponding long integer value. This * routine is a version of Tcl_GetInt but returns a "long" instead of an * "int" (a difference that matters on 64-bit architectures). * * Results: * The return value is normally TCL_OK; in this case *longPtr will be set * to the long integer value equivalent to src. If src is improperly * formed then TCL_ERROR is returned and an error message will be left in * the interp's result if interp is non-NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclGetLong(interp, src, longPtr) Tcl_Interp *interp; /* Interpreter used for error reporting if not * NULL. */ CONST char *src; /* String containing a (possibly signed) long * integer in a form acceptable to strtoul. */ long *longPtr; /* Place to store converted long result. */ { Tcl_Obj obj; int code; obj.refCount = 1; obj.bytes = (char *) src; obj.length = strlen(src); obj.typePtr = NULL; code = Tcl_GetLongFromObj(interp, &obj, longPtr); if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } return code; } /* *---------------------------------------------------------------------- * * Tcl_GetDouble -- * * Given a string, produce the corresponding double-precision * floating-point value. * * Results: * The return value is normally TCL_OK; in this case *doublePtr will be * set to the double-precision value equivalent to src. If src is * improperly formed then TCL_ERROR is returned and an error message will * be left in the interp's result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetDouble(interp, src, doublePtr) Tcl_Interp *interp; /* Interpreter used for error reporting. */ CONST char *src; /* String containing a floating-point number * in a form acceptable to strtod. */ double *doublePtr; /* Place to store converted result. */ { Tcl_Obj obj; int code; obj.refCount = 1; obj.bytes = (char *) src; obj.length = strlen(src); obj.typePtr = NULL; code = Tcl_GetDoubleFromObj(interp, &obj, doublePtr); if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } return code; } /* *---------------------------------------------------------------------- * * Tcl_GetBoolean -- * * Given a string, return a 0/1 boolean value corresponding to the * string. * * Results: * The return value is normally TCL_OK; in this case *boolPtr will be set * to the 0/1 value equivalent to src. If src is improperly formed then * TCL_ERROR is returned and an error message will be left in the * interp's result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetBoolean(interp, src, boolPtr) Tcl_Interp *interp; /* Interpreter used for error reporting. */ CONST char *src; /* String containing a boolean number * specified either as 1/0 or true/false or * yes/no. */ int *boolPtr; /* Place to store converted result, which will * be 0 or 1. */ { Tcl_Obj obj; int code; obj.refCount = 1; obj.bytes = (char *) src; obj.length = strlen(src); obj.typePtr = NULL; code = Tcl_ConvertToType(interp, &obj, &tclBooleanType); if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (code == TCL_OK) { *boolPtr = obj.internalRep.longValue; } return code; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclGetDate.y.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclGetDate.y -- * * Contains yacc grammar for parsing date and time strings. * The output of this file should be the file tclDate.c which * is used directly in the Tcl sources. * * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclGetDate.y -- * * Contains yacc grammar for parsing date and time strings. * The output of this file should be the file tclDate.c which * is used directly in the Tcl sources. * * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclGetDate.y,v 1.25.2.1 2004/12/29 22:47:00 kennykb Exp $ */ %{ /* * tclDate.c -- * * This file is generated from a yacc grammar defined in |
︙ | ︙ | |||
73 74 75 76 77 78 79 80 81 82 83 84 85 86 | time_t dateDayOrdinal; time_t dateDayNumber; int dateHaveDay; char *dateInput; time_t *dateRelPointer; } DateInfo; #define YYPARSE_PARAM info #define YYLEX_PARAM info #define yyDSTmode (((DateInfo*)info)->dateDSTmode) #define yyDayOrdinal (((DateInfo*)info)->dateDayOrdinal) | > > | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | time_t dateDayOrdinal; time_t dateDayNumber; int dateHaveDay; char *dateInput; time_t *dateRelPointer; int dateDigitCount; } DateInfo; #define YYPARSE_PARAM info #define YYLEX_PARAM info #define yyDSTmode (((DateInfo*)info)->dateDSTmode) #define yyDayOrdinal (((DateInfo*)info)->dateDayOrdinal) |
︙ | ︙ | |||
101 102 103 104 105 106 107 108 109 110 111 112 113 114 | #define yySeconds (((DateInfo*)info)->dateSeconds) #define yyMeridian (((DateInfo*)info)->dateMeridian) #define yyRelMonth (((DateInfo*)info)->dateRelMonth) #define yyRelDay (((DateInfo*)info)->dateRelDay) #define yyRelSeconds (((DateInfo*)info)->dateRelSeconds) #define yyRelPointer (((DateInfo*)info)->dateRelPointer) #define yyInput (((DateInfo*)info)->dateInput) #define EPOCH 1970 #define START_OF_TIME 1902 #define END_OF_TIME 2037 /* * The offset of tm_year of struct tm returned by localtime, gmtime, etc. | > | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | #define yySeconds (((DateInfo*)info)->dateSeconds) #define yyMeridian (((DateInfo*)info)->dateMeridian) #define yyRelMonth (((DateInfo*)info)->dateRelMonth) #define yyRelDay (((DateInfo*)info)->dateRelDay) #define yyRelSeconds (((DateInfo*)info)->dateRelSeconds) #define yyRelPointer (((DateInfo*)info)->dateRelPointer) #define yyInput (((DateInfo*)info)->dateInput) #define yyDigitCount (((DateInfo*)info)->dateDigitCount) #define EPOCH 1970 #define START_OF_TIME 1902 #define END_OF_TIME 2037 /* * The offset of tm_year of struct tm returned by localtime, gmtime, etc. |
︙ | ︙ | |||
403 404 405 406 407 408 409 | number : tUNUMBER { if (yyHaveTime && yyHaveDate && !yyHaveRel) { yyYear = $1; } else { yyHaveTime++; | | | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 | number : tUNUMBER { if (yyHaveTime && yyHaveDate && !yyHaveRel) { yyYear = $1; } else { yyHaveTime++; if (yyDigitCount <= 2) { yyHour = $1; yyMinutes = 0; } else { yyHour = $1 / 100; yyMinutes = $1 % 100; } yySeconds = 0; |
︙ | ︙ | |||
797 798 799 800 801 802 803 804 805 806 807 808 809 810 | Count = 0; for (yylval.Number = 0; isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */ yylval.Number = 10 * yylval.Number + c - '0'; Count++; } yyInput--; /* A number with 6 or more digits is considered an ISO 8601 base */ if (Count >= 6) { return tISOBASE; } else { return tUNUMBER; } } | > | 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 | Count = 0; for (yylval.Number = 0; isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */ yylval.Number = 10 * yylval.Number + c - '0'; Count++; } yyInput--; yyDigitCount = Count; /* A number with 6 or more digits is considered an ISO 8601 base */ if (Count >= 6) { return tISOBASE; } else { return tUNUMBER; } } |
︙ | ︙ |
Changes to generic/tclHash.c.
1 2 3 4 5 6 7 8 9 | /* * tclHash.c -- * * Implementation of in-memory hash tables for Tcl and Tcl-based * applications. * * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * | | | | | | | | | < | | 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 | /* * tclHash.c -- * * Implementation of in-memory hash tables for Tcl and Tcl-based * applications. * * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclHash.c,v 1.22.2.1 2005/08/02 18:15:29 dgp Exp $ */ #include "tclInt.h" /* * Prevent macros from clashing with function definitions. */ #if TCL_PRESERVE_BINARY_COMPATABILITY # undef Tcl_FindHashEntry # undef Tcl_CreateHashEntry #endif /* * When there are this many entries per bucket, on average, rebuild the hash * table to make it larger. */ #define REBUILD_MULTIPLIER 3 /* * The following macro takes a preliminary integer hash value and produces an * index into a hash tables bucket list. The idea is to make it so that * preliminary values that are arbitrarily similar will end up in different * buckets. The hash function was taken from a random-number generator. */ #define RANDOM_INDEX(tablePtr, i) \ (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) /* * Prototypes for the array hash key methods. |
︙ | ︙ | |||
74 75 76 77 78 79 80 | Tcl_HashTable *tablePtr, VOID *keyPtr)); static int CompareStringKeys _ANSI_ARGS_(( VOID *keyPtr, Tcl_HashEntry *hPtr)); static unsigned int HashStringKey _ANSI_ARGS_(( Tcl_HashTable *tablePtr, VOID *keyPtr)); /* | | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | Tcl_HashTable *tablePtr, VOID *keyPtr)); static int CompareStringKeys _ANSI_ARGS_(( VOID *keyPtr, Tcl_HashEntry *hPtr)); static unsigned int HashStringKey _ANSI_ARGS_(( Tcl_HashTable *tablePtr, VOID *keyPtr)); /* * Function prototypes for static functions in this file: */ #if TCL_PRESERVE_BINARY_COMPATABILITY static Tcl_HashEntry * BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key)); static Tcl_HashEntry * BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key, int *newPtr)); |
︙ | ︙ | |||
112 113 114 115 116 117 118 | TCL_HASH_KEY_TYPE_VERSION, /* version */ 0, /* flags */ HashStringKey, /* hashKeyProc */ CompareStringKeys, /* compareKeysProc */ AllocStringEntry, /* allocEntryProc */ NULL /* freeEntryProc */ }; | < | | | | | | | | > | | | | | | | | 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 | TCL_HASH_KEY_TYPE_VERSION, /* version */ 0, /* flags */ HashStringKey, /* hashKeyProc */ CompareStringKeys, /* compareKeysProc */ AllocStringEntry, /* allocEntryProc */ NULL /* freeEntryProc */ }; /* *---------------------------------------------------------------------- * * Tcl_InitHashTable -- * * Given storage for a hash table, set up the fields to prepare the hash * table for use. * * Results: * None. * * Side effects: * TablePtr is now ready to be passed to Tcl_FindHashEntry and * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ #undef Tcl_InitHashTable void Tcl_InitHashTable(tablePtr, keyType) register Tcl_HashTable *tablePtr; /* Pointer to table record, which is * supplied by the caller. */ int keyType; /* Type of keys to use in table: * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, * or an integer >= 2. */ { /* * Use a special value to inform the extended version that it must not * access any of the new fields in the Tcl_HashTable. If an extension is * rebuilt then any calls to this function will be redirected to the * extended version by a macro. */ Tcl_InitCustomHashTable(tablePtr, keyType, (Tcl_HashKeyType *) -1); } /* *---------------------------------------------------------------------- * * Tcl_InitCustomHashTable -- * * Given storage for a hash table, set up the fields to prepare the hash * table for use. This is an extended version of Tcl_InitHashTable which * supports user defined keys. * * Results: * None. * * Side effects: * TablePtr is now ready to be passed to Tcl_FindHashEntry and * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitCustomHashTable(tablePtr, keyType, typePtr) register Tcl_HashTable *tablePtr; /* Pointer to table record, which is * supplied by the caller. */ int keyType; /* Type of keys to use in table: * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, * TCL_CUSTOM_TYPE_KEYS, * TCL_CUSTOM_PTR_KEYS, or an integer * >= 2. */ Tcl_HashKeyType *typePtr; /* Pointer to structure which defines * the behaviour of this table. */ { #if (TCL_SMALL_HASH_TABLE != 4) Tcl_Panic("Tcl_InitCustomHashTable: TCL_SMALL_HASH_TABLE is %d, not 4\n", TCL_SMALL_HASH_TABLE); #endif |
︙ | ︙ | |||
206 207 208 209 210 211 212 | if (typePtr == NULL) { /* * The caller has been rebuilt so the hash table is an extended * version. */ } else if (typePtr != (Tcl_HashKeyType *) -1) { /* | | | > | < > | | > | | | | 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 | if (typePtr == NULL) { /* * The caller has been rebuilt so the hash table is an extended * version. */ } else if (typePtr != (Tcl_HashKeyType *) -1) { /* * The caller is requesting a customized hash table so it must be an * extended version. */ tablePtr->typePtr = typePtr; } else { /* * The caller has not been rebuilt so the hash table is not extended. */ } #else if (typePtr == NULL) { /* * Use the key type to decide which key type is needed. */ if (keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (keyType == TCL_ONE_WORD_KEYS) { typePtr = &tclOneWordHashKeyType; } else if (keyType == TCL_CUSTOM_TYPE_KEYS) { Tcl_Panic ("No type structure specified for TCL_CUSTOM_TYPE_KEYS"); } else if (keyType == TCL_CUSTOM_PTR_KEYS) { Tcl_Panic ("No type structure specified for TCL_CUSTOM_PTR_KEYS"); } else { typePtr = &tclArrayHashKeyType; } } else if (typePtr == (Tcl_HashKeyType *) -1) { /* * If the caller has not been rebuilt then we cannot continue as the * hash table is not an extended version. */ Tcl_Panic("Hash table is not compatible"); } tablePtr->typePtr = typePtr; #endif } /* *---------------------------------------------------------------------- * * Tcl_FindHashEntry -- * * Given a hash table find the entry with a matching key. * * Results: * The return value is a token for the matching entry in the hash table, * or NULL if there was no matching entry. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
308 309 310 311 312 313 314 | /* * Search all of the entries in the appropriate bucket. */ if (typePtr->compareKeysProc) { Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc; for (hPtr = tablePtr->buckets[index]; hPtr != NULL; | | | | | | | | | | | | | 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 | /* * Search all of the entries in the appropriate bucket. */ if (typePtr->compareKeysProc) { Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc; for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { #if TCL_HASH_KEY_STORE_HASH if (hash != (unsigned int) hPtr->hash) { continue; } #endif if (compareKeysProc ((VOID *) key, hPtr)) { return hPtr; } } } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { #if TCL_HASH_KEY_STORE_HASH if (hash != (unsigned int) hPtr->hash) { continue; } #endif if (key == hPtr->key.oneWordValue) { return hPtr; } } } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_CreateHashEntry -- * * Given a hash table with string keys, and a string key, find the entry * with a matching key. If there is no matching entry, then create a new * entry that does match. * * Results: * The return value is a pointer to the matching entry. If this is a * newly-created entry, then *newPtr will be set to a non-zero value; * otherwise *newPtr will be set to 0. If this is a new entry the value * stored in the entry will initially be 0. * * Side effects: * A new entry may be added to the hash table. * *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_CreateHashEntry(tablePtr, key, newPtr) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ CONST char *key; /* Key to use to find or create matching * entry. */ int *newPtr; /* Store info here telling whether a new entry * was created. */ { register Tcl_HashEntry *hPtr; Tcl_HashKeyType *typePtr; unsigned int hash; int index; #if TCL_PRESERVE_BINARY_COMPATABILITY |
︙ | ︙ | |||
407 408 409 410 411 412 413 | /* * Search all of the entries in the appropriate bucket. */ if (typePtr->compareKeysProc) { Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc; for (hPtr = tablePtr->buckets[index]; hPtr != NULL; | | | | | 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 | /* * Search all of the entries in the appropriate bucket. */ if (typePtr->compareKeysProc) { Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc; for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { #if TCL_HASH_KEY_STORE_HASH if (hash != (unsigned int) hPtr->hash) { continue; } #endif if (compareKeysProc ((VOID *) key, hPtr)) { *newPtr = 0; return hPtr; } } } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { #if TCL_HASH_KEY_STORE_HASH if (hash != (unsigned int) hPtr->hash) { continue; } #endif if (key == hPtr->key.oneWordValue) { *newPtr = 0; return hPtr; } } } /* * Entry not found. Add a new one to the bucket. */ *newPtr = 1; if (typePtr->allocEntryProc) { hPtr = typePtr->allocEntryProc (tablePtr, (VOID *) key); } else { hPtr = (Tcl_HashEntry *) ckalloc((unsigned) sizeof(Tcl_HashEntry)); |
︙ | ︙ | |||
463 464 465 466 467 468 469 | hPtr->nextPtr = *hPtr->bucketPtr; *hPtr->bucketPtr = hPtr; #endif hPtr->clientData = 0; tablePtr->numEntries++; /* | | | | | | < | 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 | hPtr->nextPtr = *hPtr->bucketPtr; *hPtr->bucketPtr = hPtr; #endif hPtr->clientData = 0; tablePtr->numEntries++; /* * If the table has exceeded a decent size, rebuild it with many more * buckets. */ if (tablePtr->numEntries >= tablePtr->rebuildSize) { RebuildTable(tablePtr); } return hPtr; } /* *---------------------------------------------------------------------- * * Tcl_DeleteHashEntry -- * * Remove a single entry from a hash table. * * Results: * None. * * Side effects: * The entry given by entryPtr is deleted from its table and should never * again be used by the caller. It is up to the caller to free the * clientData field of the entry, if that is relevant. * *---------------------------------------------------------------------- */ void Tcl_DeleteHashEntry(entryPtr) Tcl_HashEntry *entryPtr; |
︙ | ︙ | |||
561 562 563 564 565 566 567 | } /* *---------------------------------------------------------------------- * * Tcl_DeleteHashTable -- * | | | | 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 | } /* *---------------------------------------------------------------------- * * Tcl_DeleteHashTable -- * * Free up everything associated with a hash table except for the record * for the table itself. * * Results: * None. * * Side effects: * The hash table is no longer useable. * |
︙ | ︙ | |||
643 644 645 646 647 648 649 | } /* *---------------------------------------------------------------------- * * Tcl_FirstHashEntry -- * | | | < | | | | < | | | | | | | | > | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_FirstHashEntry -- * * Locate the first entry in a hash table and set up a record that can be * used to step through all the remaining entries of the table. * * Results: * The return value is a pointer to the first entry in tablePtr, or NULL * if tablePtr has no entries in it. The memory at *searchPtr is * initialized so that subsequent calls to Tcl_NextHashEntry will return * all of the entries in the table, one at a time. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_FirstHashEntry(tablePtr, searchPtr) Tcl_HashTable *tablePtr; /* Table to search. */ Tcl_HashSearch *searchPtr; /* Place to store information about progress * through the table. */ { searchPtr->tablePtr = tablePtr; searchPtr->nextIndex = 0; searchPtr->nextEntryPtr = NULL; return Tcl_NextHashEntry(searchPtr); } /* *---------------------------------------------------------------------- * * Tcl_NextHashEntry -- * * Once a hash table enumeration has been initiated by calling * Tcl_FirstHashEntry, this function may be called to return successive * elements of the table. * * Results: * The return value is the next entry in the hash table being enumerated, * or NULL if the end of the table is reached. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_NextHashEntry(searchPtr) register Tcl_HashSearch *searchPtr; /* Place to store information about progress * through the table. Must have been * initialized by calling * Tcl_FirstHashEntry. */ { Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr = searchPtr->tablePtr; while (searchPtr->nextEntryPtr == NULL) { if (searchPtr->nextIndex >= tablePtr->numBuckets) { return NULL; |
︙ | ︙ | |||
719 720 721 722 723 724 725 | } /* *---------------------------------------------------------------------- * * Tcl_HashStats -- * | | | | | < | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_HashStats -- * * Return statistics describing the layout of the hash table in its hash * buckets. * * Results: * The return value is a malloc-ed string containing information about * tablePtr. It is the caller's responsibility to free this string. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_HashStats(tablePtr) Tcl_HashTable *tablePtr; /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 int count[NUM_COUNTERS], overflow, i, j; double average, tmp; register Tcl_HashEntry *hPtr; char *result, *p; Tcl_HashKeyType *typePtr; |
︙ | ︙ | |||
791 792 793 794 795 796 797 798 799 800 801 802 803 804 | average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0; } } /* * Print out the histogram and a few other pieces of information. */ if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { result = (char *) TclpSysAlloc((unsigned) (NUM_COUNTERS*60) + 300, 0); } else { result = (char *) ckalloc((unsigned) (NUM_COUNTERS*60) + 300); } sprintf(result, "%d entries in table, %d buckets\n", tablePtr->numEntries, tablePtr->numBuckets); | > | 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 | average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0; } } /* * Print out the histogram and a few other pieces of information. */ if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { result = (char *) TclpSysAlloc((unsigned) (NUM_COUNTERS*60) + 300, 0); } else { result = (char *) ckalloc((unsigned) (NUM_COUNTERS*60) + 300); } sprintf(result, "%d entries in table, %d buckets\n", tablePtr->numEntries, tablePtr->numBuckets); |
︙ | ︙ | |||
862 863 864 865 866 867 868 | *---------------------------------------------------------------------- * * CompareArrayKeys -- * * Compares two array keys. * * Results: | | | | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 | *---------------------------------------------------------------------- * * CompareArrayKeys -- * * Compares two array keys. * * Results: * The return value is 0 if they are different and 1 if they are the * same. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
897 898 899 900 901 902 903 | } /* *---------------------------------------------------------------------- * * HashArrayKey -- * | | | | 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 | } /* *---------------------------------------------------------------------- * * HashArrayKey -- * * Compute a one-word summary of an array, which can be used to generate * a hash index. * * Results: * The return value is a one-word summary of the information in * string. * * Side effects: * None. |
︙ | ︙ | |||
969 970 971 972 973 974 975 | *---------------------------------------------------------------------- * * CompareStringKeys -- * * Compares two string keys. * * Results: | | | | 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 | *---------------------------------------------------------------------- * * CompareStringKeys -- * * Compares two string keys. * * Results: * The return value is 0 if they are different and 1 if they are the * same. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 | } /* *---------------------------------------------------------------------- * * HashStringKey -- * | | | | < | | | | | | | | | | | | > | | | < | 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 | } /* *---------------------------------------------------------------------- * * HashStringKey -- * * Compute a one-word summary of a text string, which can be used to * generate a hash index. * * Results: * The return value is a one-word summary of the information in string. * * Side effects: * None. * *---------------------------------------------------------------------- */ static unsigned int HashStringKey(tablePtr, keyPtr) Tcl_HashTable *tablePtr; /* Hash table. */ VOID *keyPtr; /* Key from which to compute hash value. */ { register CONST char *string = (CONST char *) keyPtr; register unsigned int result; register int c; /* * I tried a zillion different hash functions and asked many other people * for advice. Many people had their own favorite functions, all * different, but no-one had much idea why they were good ones. I chose * the one below (multiply by 9 and add new character) because of the * following reasons: * * 1. Multiplying by 10 is perfect for keys that are decimal strings, and * multiplying by 9 is just about as good. * 2. Times-9 is (shift-left-3) plus (old). This means that each * character's bits hang around in the low-order bits of the hash value * for ever, plus they spread fairly rapidly up to the high-order bits * to fill out the hash value. This seems works well both for decimal * and non-decimal strings, but isn't strong against maliciously-chosen * keys. */ result = 0; for (c=*string++ ; c ; c=*string++) { result += (result<<3) + c; } return result; } #if TCL_PRESERVE_BINARY_COMPATABILITY /* *---------------------------------------------------------------------- * * BogusFind -- * * This function is invoked when an Tcl_FindHashEntry is called on a * table that has been deleted. * * Results: * If Tcl_Panic returns (which it shouldn't) this function returns NULL. * * Side effects: * Generates a panic. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1086 1087 1088 1089 1090 1091 1092 | } /* *---------------------------------------------------------------------- * * BogusCreate -- * | | | | < | | | | | < | < | 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 | } /* *---------------------------------------------------------------------- * * BogusCreate -- * * This function is invoked when an Tcl_CreateHashEntry is called on a * table that has been deleted. * * Results: * If panic returns (which it shouldn't) this function returns NULL. * * Side effects: * Generates a panic. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static Tcl_HashEntry * BogusCreate(tablePtr, key, newPtr) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ CONST char *key; /* Key to use to find or create matching * entry. */ int *newPtr; /* Store info here telling whether a new entry * was created. */ { Tcl_Panic("called Tcl_CreateHashEntry on deleted table"); return NULL; } #endif /* *---------------------------------------------------------------------- * * RebuildTable -- * * This function is invoked when the ratio of entries to hash buckets * becomes too large. It creates a new table with a larger bucket array * and moves all of the entries into the new table. * * Results: * None. * * Side effects: * Memory gets reallocated and entries get re-hashed to new buckets. * *---------------------------------------------------------------------- */ static void RebuildTable(tablePtr) register Tcl_HashTable *tablePtr; /* Table to enlarge. */ |
︙ | ︙ | |||
1162 1163 1164 1165 1166 1167 1168 | typePtr = tablePtr->typePtr; #endif oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; /* | | | | 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 | typePtr = tablePtr->typePtr; #endif oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; /* * Allocate and initialize the new bucket array, and set up hashing * constants for new array size. */ tablePtr->numBuckets *= 4; if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned) (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0); } else { |
︙ | ︙ | |||
1232 1233 1234 1235 1236 1237 1238 | if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { TclpSysFree((char *) oldBuckets); } else { ckfree((char *) oldBuckets); } } } | > > > > > > > > | 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 | if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { TclpSysFree((char *) oldBuckets); } else { ckfree((char *) oldBuckets); } } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclIO.c.
|
| | | < | | | | | > | | | < < | < | | < < | < < < | | < > | | < < < < < < | > | > | > < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | /* * 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.81.2.10 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.h" #include "tclIO.h" #include <assert.h> /* * All static variables used in this file are collected into a single instance * of the following structure. For multi-threaded implementations, there is * one instance of this structure for each thread. * * Notice that different structures with the same name appear in other files. * The structure defined below is used in this file only. */ typedef struct ThreadSpecificData { NextChannelHandler *nestedHandlerPtr; /* This variable holds the list of * nested ChannelHandlerEventProc * invocations. */ ChannelState *firstCSPtr; /* List of all channels currently * open, indexed by ChannelState, as * only one ChannelState exists per * set of stacked channels. */ #ifdef oldcode int channelExitHandlerCreated; /* Has a channel exit handler been * created yet? */ int channelEventSourceCreated; /* Has the channel event source been * created and registered with the * notifier? */ #endif Tcl_Channel stdinChannel; /* Static variable for the stdin * channel. */ int stdinInitialized; Tcl_Channel stdoutChannel; /* Static variable for the stdout * channel. */ int stdoutInitialized; Tcl_Channel stderrChannel; /* Static variable for the stderr * channel. */ int stderrInitialized; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * Static functions in this file: */ |
︙ | ︙ | |||
144 145 146 147 148 149 150 151 152 153 154 155 156 157 | char *dst, CONST char *src, int *dstLenPtr, int *srcLenPtr)); static void UpdateInterest _ANSI_ARGS_((Channel *chanPtr)); static int WriteBytes _ANSI_ARGS_((Channel *chanPtr, CONST char *src, int srcLen)); static int WriteChars _ANSI_ARGS_((Channel *chanPtr, CONST char *src, int srcLen)); /* *--------------------------------------------------------------------------- * * TclInitIOSubsystem -- * * Initialize all resources used by this subsystem on a per-process | > > > > > > | | | > | | | | | 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 | char *dst, CONST char *src, int *dstLenPtr, int *srcLenPtr)); static void UpdateInterest _ANSI_ARGS_((Channel *chanPtr)); static int WriteBytes _ANSI_ARGS_((Channel *chanPtr, CONST char *src, int srcLen)); static int WriteChars _ANSI_ARGS_((Channel *chanPtr, CONST char *src, int srcLen)); static Tcl_Obj* FixLevelCode _ANSI_ARGS_ ((Tcl_Obj* msg)); static void SpliceChannel _ANSI_ARGS_ ((Tcl_Channel chan)); static void CutChannel _ANSI_ARGS_ ((Tcl_Channel chan)); /* *--------------------------------------------------------------------------- * * TclInitIOSubsystem -- * * Initialize all resources used by this subsystem on a per-process * basis. * * Results: * None. * * Side effects: * Depends on the memory subsystems. * *--------------------------------------------------------------------------- */ void TclInitIOSubsystem() { /* * By fetching thread local storage we take care of allocating it for each * thread. */ (void) TCL_TSD_INIT(&dataKey); } /* *------------------------------------------------------------------------- * * TclFinalizeIOSubsystem -- * * Releases all resources used by this subsystem on a per-process basis. * Closes all extant channels that have not already been closed because * they were not owned by any interp. * * Results: * None. * * Side effects: * Depends on encoding and memory subsystems. * |
︙ | ︙ | |||
205 206 207 208 209 210 211 | for (statePtr = tsdPtr->firstCSPtr; statePtr != (ChannelState *) NULL; statePtr = nextCSPtr) { chanPtr = statePtr->topChanPtr; nextCSPtr = statePtr->nextCSPtr; /* | | | < | | < | | < | | | 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 | for (statePtr = tsdPtr->firstCSPtr; statePtr != (ChannelState *) NULL; statePtr = nextCSPtr) { chanPtr = statePtr->topChanPtr; nextCSPtr = statePtr->nextCSPtr; /* * Set the channel back into blocking mode to ensure that we wait for * all data to flush out. */ (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, "-blocking", "on"); if ((chanPtr == (Channel *) tsdPtr->stdinChannel) || (chanPtr == (Channel *) tsdPtr->stdoutChannel) || (chanPtr == (Channel *) tsdPtr->stderrChannel)) { /* * Decrement the refcount which was earlier artificially bumped up * to keep the channel from being closed. */ statePtr->refCount--; } if (statePtr->refCount <= 0) { /* * Close it only if the refcount indicates that the channel is not * referenced from any interpreter. If it is, that interpreter * will close the channel when it gets destroyed. */ (void) Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); } else { /* * The refcount is greater than zero, so flush the channel. */ Tcl_Flush((Tcl_Channel) chanPtr); /* * Call the device driver to actually close the underlying device * for this channel. */ if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { (chanPtr->typePtr->closeProc)(chanPtr->instanceData, (Tcl_Interp *) NULL); } else { (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, |
︙ | ︙ | |||
266 267 268 269 270 271 272 273 274 275 276 277 278 279 | * on it. */ chanPtr->instanceData = (ClientData) NULL; statePtr->flags |= CHANNEL_DEAD; } } } /* *---------------------------------------------------------------------- * * Tcl_SetStdChannel -- * | > | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | 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 | * on it. */ chanPtr->instanceData = (ClientData) NULL; statePtr->flags |= CHANNEL_DEAD; } } TclpFinalizePipes(); } /* *---------------------------------------------------------------------- * * Tcl_SetStdChannel -- * * This function is used to change the channels that are used for * stdin/stdout/stderr in new interpreters. * * Results: * None * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_SetStdChannel(channel, type) Tcl_Channel channel; int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); switch (type) { case TCL_STDIN: tsdPtr->stdinInitialized = 1; tsdPtr->stdinChannel = channel; break; case TCL_STDOUT: tsdPtr->stdoutInitialized = 1; tsdPtr->stdoutChannel = channel; break; case TCL_STDERR: tsdPtr->stderrInitialized = 1; tsdPtr->stderrChannel = channel; break; } } /* *---------------------------------------------------------------------- * * Tcl_GetStdChannel -- * * Returns the specified standard channel. * * Results: * Returns the specified standard channel, or NULL. * * Side effects: * May cause the creation of a standard channel and the underlying file. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_GetStdChannel(type) int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ { Tcl_Channel channel = NULL; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * If the channels were not created yet, create them now and store them in * the static variables. */ switch (type) { case TCL_STDIN: if (!tsdPtr->stdinInitialized) { tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN); tsdPtr->stdinInitialized = 1; /* * Artificially bump the refcount to ensure that the channel is * only closed on exit. * * NOTE: Must only do this if stdinChannel is not NULL. It can be * NULL in situations where Tcl is unable to connect to the * standard input. */ if (tsdPtr->stdinChannel != (Tcl_Channel) NULL) { (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, tsdPtr->stdinChannel); } } channel = tsdPtr->stdinChannel; break; case TCL_STDOUT: if (!tsdPtr->stdoutInitialized) { tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT); tsdPtr->stdoutInitialized = 1; if (tsdPtr->stdoutChannel != (Tcl_Channel) NULL) { (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, tsdPtr->stdoutChannel); } } channel = tsdPtr->stdoutChannel; break; case TCL_STDERR: if (!tsdPtr->stderrInitialized) { tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR); tsdPtr->stderrInitialized = 1; if (tsdPtr->stderrChannel != (Tcl_Channel) NULL) { (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, tsdPtr->stderrChannel); } } channel = tsdPtr->stderrChannel; break; } return channel; } /* *---------------------------------------------------------------------- * * Tcl_CreateCloseHandler * * Creates a close callback which will be called when the channel is * closed. * * Results: * None. * * Side effects: * Causes the callback to be called in the future when the channel will * be closed. * *---------------------------------------------------------------------- */ void Tcl_CreateCloseHandler(chan, proc, clientData) Tcl_Channel chan; /* The channel for which to create the close * callback. */ Tcl_CloseProc *proc; /* The callback routine to call when the * channel will be closed. */ ClientData clientData; /* Arbitrary data to pass to the close * callback. */ { ChannelState *statePtr; CloseCallback *cbPtr; statePtr = ((Channel *) chan)->state; cbPtr = (CloseCallback *) ckalloc((unsigned) sizeof(CloseCallback)); cbPtr->proc = proc; cbPtr->clientData = clientData; cbPtr->nextPtr = statePtr->closeCbPtr; statePtr->closeCbPtr = cbPtr; } /* *---------------------------------------------------------------------- * * Tcl_DeleteCloseHandler -- * * Removes a callback that would have been called on closing the channel. * If there is no matching callback then this function has no effect. * * Results: * None. * * Side effects: * The callback will not be called in the future when the channel is * eventually closed. * *---------------------------------------------------------------------- */ void Tcl_DeleteCloseHandler(chan, proc, clientData) Tcl_Channel chan; /* The channel for which to cancel the close * callback. */ Tcl_CloseProc *proc; /* The procedure for the callback to * remove. */ ClientData clientData; /* The callback data for the callback to * remove. */ { ChannelState *statePtr; CloseCallback *cbPtr, *cbPrevPtr; statePtr = ((Channel *) chan)->state; for (cbPtr = statePtr->closeCbPtr, cbPrevPtr = (CloseCallback *) NULL; cbPtr != (CloseCallback *) NULL; |
︙ | ︙ | |||
476 477 478 479 480 481 482 | } /* *---------------------------------------------------------------------- * * GetChannelTable -- * | | | | < | | | 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 | } /* *---------------------------------------------------------------------- * * GetChannelTable -- * * Gets and potentially initializes the channel table for an interpreter. * If it is initializing the table it also inserts channels for stdin, * stdout and stderr if the interpreter is trusted. * * Results: * A pointer to the hash table created, for use by the caller. * * Side effects: * Initializes the channel table for an interpreter. May create channels * for stdin, stdout and stderr. * *---------------------------------------------------------------------- */ static Tcl_HashTable * GetChannelTable(interp) Tcl_Interp *interp; |
︙ | ︙ | |||
508 509 510 511 512 513 514 | Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); (void) Tcl_SetAssocData(interp, "tclIO", (Tcl_InterpDeleteProc *) DeleteChannelTable, (ClientData) hTblPtr); /* | | | < | 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 | Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); (void) Tcl_SetAssocData(interp, "tclIO", (Tcl_InterpDeleteProc *) DeleteChannelTable, (ClientData) hTblPtr); /* * If the interpreter is trusted (not "safe"), insert channels for * stdin, stdout and stderr (possibly creating them in the process). */ if (Tcl_IsSafe(interp) == 0) { stdinChan = Tcl_GetStdChannel(TCL_STDIN); if (stdinChan != NULL) { Tcl_RegisterChannel(interp, stdinChan); } |
︙ | ︙ | |||
537 538 539 540 541 542 543 | /* *---------------------------------------------------------------------- * * DeleteChannelTable -- * * Deletes the channel table for an interpreter, closing any open | | | < | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 | /* *---------------------------------------------------------------------- * * DeleteChannelTable -- * * Deletes the channel table for an interpreter, closing any open * channels whose refcount reaches zero. This procedure is invoked when * an interpreter is deleted, via the AssocData cleanup mechanism. * * Results: * None. * * Side effects: * Deletes the hash table of channels. May close channels. May flush * output on closed channels. Removes any channeEvent handlers that were |
︙ | ︙ | |||
563 564 565 566 567 568 569 | { Tcl_HashTable *hTblPtr; /* The hash table. */ Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ Channel *chanPtr; /* Channel being deleted. */ ChannelState *statePtr; /* State of Channel being deleted. */ EventScriptRecord *sPtr, *prevPtr, *nextPtr; | | | 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 | { Tcl_HashTable *hTblPtr; /* The hash table. */ Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ Channel *chanPtr; /* Channel being deleted. */ ChannelState *statePtr; /* State of Channel being deleted. */ EventScriptRecord *sPtr, *prevPtr, *nextPtr; /* Variables to loop over all channel events * registered, to delete the ones that refer * to the interpreter being deleted. */ /* * Delete all the registered channels - this will close channels whose * refcount reaches zero. */ |
︙ | ︙ | |||
608 609 610 611 612 613 614 | } else { prevPtr = sPtr; } } /* * Cannot call Tcl_UnregisterChannel because that procedure calls | | | | | | | | | | 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 | } else { prevPtr = sPtr; } } /* * Cannot call Tcl_UnregisterChannel because that procedure calls * Tcl_GetAssocData to get the channel table, which might already be * inaccessible from the interpreter structure. Instead, we emulate * the behavior of Tcl_UnregisterChannel directly here. */ Tcl_DeleteHashEntry(hPtr); statePtr->refCount--; if (statePtr->refCount <= 0) { if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) { (void) Tcl_Close(interp, (Tcl_Channel) chanPtr); } } } Tcl_DeleteHashTable(hTblPtr); ckfree((char *) hTblPtr); } /* *---------------------------------------------------------------------- * * CheckForStdChannelsBeingClosed -- * * Perform special handling for standard channels being closed. When * given a standard channel, if the refcount is now 1, it means that the * last reference to the standard channel is being explicitly closed. Now * bump the refcount artificially down to 0, to ensure the normal * handling of channels being closed will occur. Also reset the static * pointer to the channel to NULL, to avoid dangling references. * * Results: * None. * * Side effects: * Manipulates the refcount on standard channels. May smash the global * static pointer to a standard channel. |
︙ | ︙ | |||
695 696 697 698 699 700 701 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | 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 | * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_IsStandardChannel(chan) Tcl_Channel chan; /* Channel to check. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if ((chan == tsdPtr->stdinChannel) || (chan == tsdPtr->stdoutChannel) || (chan == tsdPtr->stderrChannel)) { return 1; } else { return 0; } } /* *---------------------------------------------------------------------- * * Tcl_RegisterChannel -- * * Adds an already-open channel to the channel table of an interpreter. * If the interpreter passed as argument is NULL, it only increments the * channel refCount. * * Results: * None. * * Side effects: * May increment the reference count of a channel. * |
︙ | ︙ | |||
757 758 759 760 761 762 763 | Tcl_Panic("Tcl_RegisterChannel: channel without name"); } if (interp != (Tcl_Interp *) NULL) { hTblPtr = GetChannelTable(interp); hPtr = Tcl_CreateHashEntry(hTblPtr, statePtr->channelName, &new); if (new == 0) { if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) { | | | | | | | | 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 | Tcl_Panic("Tcl_RegisterChannel: channel without name"); } if (interp != (Tcl_Interp *) NULL) { hTblPtr = GetChannelTable(interp); hPtr = Tcl_CreateHashEntry(hTblPtr, statePtr->channelName, &new); if (new == 0) { if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) { return; } Tcl_Panic("Tcl_RegisterChannel: duplicate channel names"); } Tcl_SetHashValue(hPtr, (ClientData) chanPtr); } statePtr->refCount++; } /* *---------------------------------------------------------------------- * * Tcl_UnregisterChannel -- * * Deletes the hash entry for a channel associated with an interpreter. * If the interpreter given as argument is NULL, it only decrements the * reference count. (This all happens in the Tcl_DetachChannel helper * function). * * Finally, if the reference count of the channel drops to zero, it is * deleted. * * Results: * A standard Tcl result. * * Side effects: * Calls Tcl_DetachChannel which deletes the hash entry for a channel * associated with an interpreter. * * May delete the channel, which can have a variety of consequences, * especially if we are forced to close the channel. * *---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
833 834 835 836 837 838 839 | /* * If the refCount reached zero, close the actual channel. */ if (statePtr->refCount <= 0) { /* | | | > | > > | 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 | /* * If the refCount reached zero, close the actual channel. */ if (statePtr->refCount <= 0) { /* * Ensure that if there is another buffer, it gets flushed whether or * not we are doing a background flush. */ if ((statePtr->curOutPtr != NULL) && (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) { statePtr->flags |= BUFFER_READY; } Tcl_Preserve((ClientData)statePtr); if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) { /* * We don't want to re-enter Tcl_Close(). */ if (!(statePtr->flags & CHANNEL_CLOSED)) { if (Tcl_Close(interp, chan) != TCL_OK) { statePtr->flags |= CHANNEL_CLOSED; Tcl_Release((ClientData)statePtr); return TCL_ERROR; } } |
︙ | ︙ | |||
866 867 868 869 870 871 872 | /* *---------------------------------------------------------------------- * * Tcl_DetachChannel -- * * Deletes the hash entry for a channel associated with an interpreter. * If the interpreter given as argument is NULL, it only decrements the | | | | | < | | | | | | | | | | | < | | | < | 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 | /* *---------------------------------------------------------------------- * * Tcl_DetachChannel -- * * Deletes the hash entry for a channel associated with an interpreter. * If the interpreter given as argument is NULL, it only decrements the * reference count. Even if the ref count drops to zero, the channel is * NOT closed or cleaned up. This allows a channel to be detached from * an interpreter and left in the same state it was in when it was * originally returned by 'Tcl_OpenFileChannel', for example. * * This function cannot be used on the standard channels, and will return * TCL_ERROR if that is attempted. * * This function should only be necessary for special purposes in which * you need to generate a pristine channel from one that has already been * used. All ordinary purposes will almost always want to use * Tcl_UnregisterChannel instead. * * Provided the channel is not attached to any other interpreter, it can * then be closed with Tcl_Close, rather than with Tcl_UnregisterChannel. * * Results: * A standard Tcl result. If the channel is not currently registered * with the given interpreter, TCL_ERROR is returned, otherwise TCL_OK. * However no error messages are left in the interp's result. * * Side effects: * Deletes the hash entry for a channel associated with an interpreter. * *---------------------------------------------------------------------- */ int Tcl_DetachChannel(interp, chan) Tcl_Interp *interp; /* Interpreter in which channel is defined. */ |
︙ | ︙ | |||
915 916 917 918 919 920 921 | /* *---------------------------------------------------------------------- * * DetachChannel -- * * Deletes the hash entry for a channel associated with an interpreter. * If the interpreter given as argument is NULL, it only decrements the | | | | | < | | | < | 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 | /* *---------------------------------------------------------------------- * * DetachChannel -- * * Deletes the hash entry for a channel associated with an interpreter. * If the interpreter given as argument is NULL, it only decrements the * reference count. Even if the ref count drops to zero, the channel is * NOT closed or cleaned up. This allows a channel to be detached from * an interpreter and left in the same state it was in when it was * originally returned by 'Tcl_OpenFileChannel', for example. * * Results: * A standard Tcl result. If the channel is not currently registered * with the given interpreter, TCL_ERROR is returned, otherwise TCL_OK. * However no error messages are left in the interp's result. * * Side effects: * Deletes the hash entry for a channel associated with an interpreter. * *---------------------------------------------------------------------- */ static int DetachChannel(interp, chan) Tcl_Interp *interp; /* Interpreter in which channel is defined. */ |
︙ | ︙ | |||
967 968 969 970 971 972 973 | } if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) { return TCL_ERROR; } Tcl_DeleteHashEntry(hPtr); /* | | | | | | 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 | } if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) { return TCL_ERROR; } Tcl_DeleteHashEntry(hPtr); /* * Remove channel handlers that refer to this interpreter, so that * they will not be present if the actual close is delayed and more * events happen on the channel. This may occur if the channel is * shared between several interpreters, or if the channel has async * flushing active. */ CleanupChannelHandlers(interp, chanPtr); } statePtr->refCount--; |
︙ | ︙ | |||
992 993 994 995 996 997 998 | * Tcl_GetChannel -- * * Finds an existing Tcl_Channel structure by name in a given * interpreter. This function is public because it is used by * channel-type-specific functions. * * Results: | | | | | | | | | | | | 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 | * Tcl_GetChannel -- * * Finds an existing Tcl_Channel structure by name in a given * interpreter. This function is public because it is used by * channel-type-specific functions. * * Results: * A Tcl_Channel or NULL on failure. If failed, interp's result object * contains an error message. *modePtr is filled with the modes in which * the channel was opened. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_Channel Tcl_GetChannel(interp, chanName, modePtr) Tcl_Interp *interp; /* Interpreter in which to find or create the * channel. */ CONST char *chanName; /* The name of the channel. */ int *modePtr; /* Where to store the mode in which the * channel was opened? Will contain an ORed * combination of TCL_READABLE and * TCL_WRITABLE, if non-NULL. */ { Channel *chanPtr; /* The actual channel. */ Tcl_HashTable *hTblPtr; /* Hash table of channels. */ Tcl_HashEntry *hPtr; /* Search variable. */ CONST char *name; /* Translated name. */ /* * Substitute "stdin", etc. Note that even though we immediately find the * channel using Tcl_GetStdChannel, we still need to look it up in the * specified interpreter to ensure that it is present in the channel * table. Otherwise, safe interpreters would always have access to the * standard channels. */ name = chanName; if ((chanName[0] == 's') && (chanName[1] == 't')) { chanPtr = NULL; if (strcmp(chanName, "stdin") == 0) { chanPtr = (Channel *) Tcl_GetStdChannel(TCL_STDIN); |
︙ | ︙ | |||
1049 1050 1051 1052 1053 1054 1055 | if (hPtr == (Tcl_HashEntry *) NULL) { Tcl_AppendResult(interp, "can not find channel named \"", chanName, "\"", (char *) NULL); return NULL; } /* | | | | < | < | < | | | | | | | | | | 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 | if (hPtr == (Tcl_HashEntry *) NULL) { Tcl_AppendResult(interp, "can not find channel named \"", chanName, "\"", (char *) NULL); return NULL; } /* * Always return bottom-most channel in the stack. This one lives the * longest - other channels may go away unnoticed. The other APIs * compensate where necessary to retrieve the topmost channel again. */ chanPtr = (Channel *) Tcl_GetHashValue(hPtr); chanPtr = chanPtr->state->bottomChanPtr; if (modePtr != NULL) { *modePtr = (chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE)); } return (Tcl_Channel) chanPtr; } /* *---------------------------------------------------------------------- * * Tcl_CreateChannel -- * * Creates a new entry in the hash table for a Tcl_Channel record. * * Results: * Returns the new Tcl_Channel. * * Side effects: * Creates a new Tcl_Channel instance and inserts it into the hash table. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_CreateChannel(typePtr, chanName, instanceData, mask) Tcl_ChannelType *typePtr; /* The channel type record. */ CONST char *chanName; /* Name of channel to record. */ ClientData instanceData; /* Instance specific data. */ int mask; /* TCL_READABLE & TCL_WRITABLE to indicate if * the channel is readable, writable. */ { Channel *chanPtr; /* The channel structure newly created. */ ChannelState *statePtr; /* The stack-level independent state info for * the channel. */ CONST char *name; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * With the change of the Tcl_ChannelType structure to use a version in * 8.3.2+, we have to make sure that our assumption that the structure * remains a binary compatible size is true. * * If this assertion fails on some system, then it can be removed only if * the user recompiles code with older channel drivers in the new system * as well. */ assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc*)); /* * JH: We could subsequently memset these to 0 to avoid the numerous * assignments to 0/NULL below. */ chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); statePtr = (ChannelState *) ckalloc((unsigned) sizeof(ChannelState)); chanPtr->state = statePtr; chanPtr->instanceData = instanceData; |
︙ | ︙ | |||
1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 | Tcl_Panic("Tcl_CreateChannel: NULL channel name"); } statePtr->flags = mask; /* * Set the channel to system default encoding. */ statePtr->encoding = NULL; name = Tcl_GetEncodingName(NULL); if (strcmp(name, "binary") != 0) { | > > > > > > | | | | | | | 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 | Tcl_Panic("Tcl_CreateChannel: NULL channel name"); } statePtr->flags = mask; /* * Set the channel to system default encoding. * * Note the strange bit of protection taking place here. If the system * encoding name is reported back as "binary", something weird is * happening. Tcl provides no "binary" encoding, so someone else has * provided one. We ignore it so as not to interfere with the "magic" * interpretation that Tcl_Channels give to the "-encoding binary" option. */ statePtr->encoding = NULL; name = Tcl_GetEncodingName(NULL); if (strcmp(name, "binary") != 0) { statePtr->encoding = Tcl_GetEncoding(NULL, name); } statePtr->inputEncodingState = NULL; statePtr->inputEncodingFlags = TCL_ENCODING_START; statePtr->outputEncodingState = NULL; statePtr->outputEncodingFlags = TCL_ENCODING_START; /* * Set the channel up initially in AUTO input translation mode to accept * "\n", "\r" and "\r\n". Output translation mode is set to a platform * specific default value. The eofChar is set to 0 for both input and * output, so that Tcl does not look for an in-file EOF indicator * (e.g. ^Z) and does not append an EOF indicator to files. */ statePtr->inputTranslation = TCL_TRANSLATE_AUTO; statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; statePtr->inEofChar = 0; statePtr->outEofChar = 0; |
︙ | ︙ | |||
1185 1186 1187 1188 1189 1190 1191 | statePtr->outputStage = NULL; if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { statePtr->outputStage = (char *) ckalloc((unsigned) (statePtr->bufSize + 2)); } /* | | > > > > | | < | < < | < | | > | > > > | > | | | < | | | | < | | | | | | | | | < | | | > | | | | | | | | | | | | | | < | | | | | | | | | | | | > > > > > > > > > > > > > > > > | | | | > | | | | > > > > > > > | | | > | | | | | | | | 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 | statePtr->outputStage = NULL; if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { statePtr->outputStage = (char *) ckalloc((unsigned) (statePtr->bufSize + 2)); } /* * As we are creating the channel, it is obviously the top for now. */ statePtr->topChanPtr = chanPtr; statePtr->bottomChanPtr = chanPtr; chanPtr->downChanPtr = (Channel *) NULL; chanPtr->upChanPtr = (Channel *) NULL; chanPtr->inQueueHead = (ChannelBuffer *) NULL; chanPtr->inQueueTail = (ChannelBuffer *) NULL; /* TIP #219, Tcl Channel Reflection API */ statePtr->chanMsg = NULL; statePtr->unreportedMsg = NULL; /* * Link the channel into the list of all channels; create an on-exit * handler if there is not one already, to close off all the channels in * the list on exit. * * JH: Could call Tcl_SpliceChannel, but need to avoid NULL check. * * TIP #218. * AK: Just initialize the field to NULL before invoking Tcl_SpliceChannel * We need Tcl_SpliceChannel, for the threadAction calls. There is no * real reason to duplicate all of this. * NOTE: All drivers using thread actions now have to perform their TSD * manipulation only in their thread action proc. Doing it when * creating their instance structures will collide with the thread * action activity and lead to damaged lists. */ statePtr->nextCSPtr = (ChannelState *) NULL; SpliceChannel ((Tcl_Channel) chanPtr); /* * Install this channel in the first empty standard channel slot, if the * channel was previously closed explicitly. */ if ((tsdPtr->stdinChannel == NULL) && (tsdPtr->stdinInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDIN); Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); } else if ((tsdPtr->stdoutChannel == NULL) && (tsdPtr->stdoutInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDOUT); Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); } else if ((tsdPtr->stderrChannel == NULL) && (tsdPtr->stderrInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDERR); Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); } return (Tcl_Channel) chanPtr; } /* *---------------------------------------------------------------------- * * Tcl_StackChannel -- * * Replaces an entry in the hash table for a Tcl_Channel record. The * replacement is a new channel with same name, it supercedes the * replaced channel. Input and output of the superceded channel is now * going through the newly created channel and allows the arbitrary * filtering/manipulation of the dataflow. * * Andreas Kupries <[email protected]>, 12/13/1998 "Trf-Patch for * filtering channels" * * Results: * Returns the new Tcl_Channel, which actually contains the saved * information about prevChan. * * Side effects: * A new channel structure is allocated and linked below the existing * channel. The channel operations and client data of the existing channel * are copied down to the newly created channel, and the current channel * has its operations replaced by the new typePtr. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan) Tcl_Interp *interp; /* The interpreter we are working in */ Tcl_ChannelType *typePtr; /* The channel type record for the new * channel. */ ClientData instanceData; /* Instance specific data for the new * channel. */ int mask; /* TCL_READABLE & TCL_WRITABLE to indicate if * the channel is readable, writable. */ Tcl_Channel prevChan; /* The channel structure to replace */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Channel *chanPtr, *prevChanPtr; ChannelState *statePtr; Tcl_DriverThreadActionProc *threadActionProc; /* * Find the given channel (prevChan) in the list of all channels. If we don't find * it, then it was never registered correctly. * * This operation should occur at the top of a channel stack. */ statePtr = (ChannelState *) tsdPtr->firstCSPtr; prevChanPtr = ((Channel *) prevChan)->state->topChanPtr; while (statePtr->topChanPtr != prevChanPtr) { statePtr = statePtr->nextCSPtr; } if (statePtr == NULL) { Tcl_AppendResult(interp, "couldn't find state for channel \"", Tcl_GetChannelName(prevChan), "\"", (char *) NULL); return (Tcl_Channel) NULL; } /* * Here we check if the given "mask" matches the "flags" of the already * existing channel. * * | - | R | W | RW | * --+---+---+---+----+ <=> 0 != (chan->mask & prevChan->mask) * - | | | | | * R | | + | | + | The superceding channel is allowed to restrict * W | | | + | + | the capabilities of the superceded one! * RW| | + | + | + | * --+---+---+---+----+ */ if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) { Tcl_AppendResult(interp, "reading and writing both disallowed for channel \"", Tcl_GetChannelName(prevChan), "\"", (char *) NULL); return (Tcl_Channel) NULL; } /* * Flush the buffers. This ensures that any data still in them at this * time is not handled by the new transformation. Restrict this to * writable channels. Take care to hide a possible bg-copy in progress * from Tcl_Flush and the CheckForChannelErrors inside. */ if ((mask & TCL_WRITABLE) != 0) { CopyState *csPtr; csPtr = statePtr->csPtr; statePtr->csPtr = (CopyState *) NULL; if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) { statePtr->csPtr = csPtr; Tcl_AppendResult(interp, "could not flush channel \"", Tcl_GetChannelName(prevChan), "\"", (char *) NULL); return (Tcl_Channel) NULL; } statePtr->csPtr = csPtr; } /* * Discard any input in the buffers. They are not yet read by the user of * the channel, so they have to go through the new transformation before * reading. As the buffers contain the untransformed form their contents * are not only useless but actually distorts our view of the system. * * To preserve the information without having to read them again and to * avoid problems with the location in the channel (seeking might be * impossible) we move the buffers from the common state structure into * the channel itself. We use the buffers in the channel below the new * transformation to hold the data. In the future this allows us to write * transformations which pre-read data and push the unused part back when * they are going away. */ if (((mask & TCL_READABLE) != 0) && (statePtr->inQueueHead != (ChannelBuffer *) NULL)) { /* * Remark: It is possible that the channel buffers contain data from * some earlier push-backs. */ statePtr->inQueueTail->nextPtr = prevChanPtr->inQueueHead; prevChanPtr->inQueueHead = statePtr->inQueueHead; if (prevChanPtr->inQueueTail == (ChannelBuffer *) NULL) { prevChanPtr->inQueueTail = statePtr->inQueueTail; } statePtr->inQueueHead = (ChannelBuffer *) NULL; statePtr->inQueueTail = (ChannelBuffer *) NULL; } chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); /* * Save some of the current state into the new structure, reinitialize the * parts which will stay with the transformation. * * Remarks: */ chanPtr->state = statePtr; chanPtr->instanceData = instanceData; chanPtr->typePtr = typePtr; chanPtr->downChanPtr = prevChanPtr; chanPtr->upChanPtr = (Channel *) NULL; chanPtr->inQueueHead = (ChannelBuffer *) NULL; chanPtr->inQueueTail = (ChannelBuffer *) NULL; /* * Place new block at the head of a possibly existing list of previously * stacked channels. */ prevChanPtr->upChanPtr = chanPtr; statePtr->topChanPtr = chanPtr; /* TIP #218, Channel Thread Actions. * * We call the thread actions for the new channel directly. We _cannot_ * use SpliceChannel, because the (thread-)global list of all channels * always contains the _ChannelState_ for a stack of channels, not the * individual channels. And SpliceChannel would not only call the thread * actions, but also add the shared ChannelState to this list a second * time, mangling it. */ threadActionProc = Tcl_ChannelThreadActionProc (chanPtr->typePtr); if (threadActionProc != NULL) { (*threadActionProc) (chanPtr->instanceData, TCL_CHANNEL_THREAD_INSERT); } return (Tcl_Channel) chanPtr; } /* *---------------------------------------------------------------------- * * Tcl_UnstackChannel -- * * Unstacks an entry in the hash table for a Tcl_Channel record. This is * the reverse to 'Tcl_StackChannel'. * * Results: * A standard Tcl result. * * Side effects: * If TCL_ERROR is returned, the posix error code will be set with * Tcl_SetErrno. May leave a message in interp result as well. * *---------------------------------------------------------------------- */ int Tcl_UnstackChannel(interp, chan) Tcl_Interp *interp; /* The interpreter we are working in */ Tcl_Channel chan; /* The channel to unstack */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; int result = 0; Tcl_DriverThreadActionProc *threadActionProc; /* * This operation should occur at the top of a channel stack. */ chanPtr = statePtr->topChanPtr; if (chanPtr->downChanPtr != (Channel *) NULL) { /* * Instead of manipulating the per-thread / per-interp list/hashtable * of registered channels we wind down the state of the transformation, * and then restore the state of underlying channel into the old * structure. */ Channel *downChanPtr = chanPtr->downChanPtr; /* * Flush the buffers. This ensures that any data still in them at this * time _is_ handled by the transformation we are unstacking right * now. Restrict this to writable channels. Take care to hide a * possible bg-copy in progress from Tcl_Flush and the * CheckForChannelErrors inside. */ if (statePtr->flags & TCL_WRITABLE) { CopyState *csPtr; csPtr = statePtr->csPtr; statePtr->csPtr = (CopyState *) NULL; if (Tcl_Flush((Tcl_Channel) chanPtr) != TCL_OK) { statePtr->csPtr = csPtr; /* TIP #219, Tcl Channel Reflection API. * Move error messages put by the driver into the chan/ip * bypass area into the regular interpreter result. Fall back * to the regular message if nothing was found in the * bypasses. */ if (!TclChanCaughtErrorBypass (interp, chan)) { Tcl_AppendResult(interp, "could not flush channel \"", Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"", (char *) NULL); } return TCL_ERROR; } statePtr->csPtr = csPtr; } /* * Anything in the input queue and the push-back buffers of the * transformation going away is transformed data, but not yet read. As * unstacking means that the caller does not want to see transformed * data any more we have to discard these bytes. To avoid writing an * analogue to 'DiscardInputQueued' we move the information in the * push back buffers to the input queue and then call * 'DiscardInputQueued' on that. */ if (((statePtr->flags & TCL_READABLE) != 0) && ((statePtr->inQueueHead != (ChannelBuffer *) NULL) || (chanPtr->inQueueHead != (ChannelBuffer *) NULL))) { if ((statePtr->inQueueHead != (ChannelBuffer *) NULL) && |
︙ | ︙ | |||
1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 | } chanPtr->inQueueHead = (ChannelBuffer *) NULL; chanPtr->inQueueTail = (ChannelBuffer *) NULL; DiscardInputQueued(statePtr, 0); } statePtr->topChanPtr = downChanPtr; downChanPtr->upChanPtr = (Channel *) NULL; /* * Leave this link intact for closeproc * chanPtr->downChanPtr = (Channel *) NULL; | > > > > > > > > > > > > > > > > > | 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 | } chanPtr->inQueueHead = (ChannelBuffer *) NULL; chanPtr->inQueueTail = (ChannelBuffer *) NULL; DiscardInputQueued(statePtr, 0); } /* TIP #218, Channel Thread Actions. * * We call the thread actions for the new channel directly. We * _cannot_ use CutChannel, because the (thread-)global list of all * channels always contains the _ChannelState_ for a stack of * channels, not the individual channels. And SpliceChannel would not * only call the thread actions, but also remove the shared * ChannelState from this list despite there being more channels for * the state which are still active. */ threadActionProc = Tcl_ChannelThreadActionProc (chanPtr->typePtr); if (threadActionProc != NULL) { (*threadActionProc) (chanPtr->instanceData, TCL_CHANNEL_THREAD_REMOVE); } statePtr->topChanPtr = downChanPtr; downChanPtr->upChanPtr = (Channel *) NULL; /* * Leave this link intact for closeproc * chanPtr->downChanPtr = (Channel *) NULL; |
︙ | ︙ | |||
1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 | */ Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); UpdateInterest(downChanPtr); if (result != 0) { Tcl_SetErrno(result); return TCL_ERROR; } } else { /* | > > > > > | | > > > > > > > > > > | | | | 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 | */ Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); UpdateInterest(downChanPtr); if (result != 0) { Tcl_SetErrno(result); /* TIP #219, Tcl Channel Reflection API. * Move error messages put by the driver into the chan/ip bypass * area into the regular interpreter result. */ TclChanCaughtErrorBypass (interp, chan); return TCL_ERROR; } } else { /* * This channel does not cover another one. Simply do a close, if * necessary. */ if (statePtr->refCount <= 0) { if (Tcl_Close(interp, chan) != TCL_OK) { /* TIP #219, Tcl Channel Reflection API. * "TclChanCaughtErrorBypass" is not required here, it was * done already by "Tcl_Close". */ return TCL_ERROR; } } /* TIP #218, Channel Thread Actions. * Not required in this branch, this is done by Tcl_Close. If * Tcl_Close is not called then the ChannelState is still active in * the thread and no action has to be taken either. */ } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetStackedChannel -- * * Determines whether the specified channel is stacked upon another. * * Results: * NULL if the channel is not stacked upon another one, or a reference to * the channel it is stacked upon. This reference can be used in queries, * but modification is not allowed. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1586 1587 1588 1589 1590 1591 1592 | *---------------------------------------------------------------------- * * Tcl_GetTopChannel -- * * Returns the top channel of a channel stack. * * Results: | | | | | 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 | *---------------------------------------------------------------------- * * Tcl_GetTopChannel -- * * Returns the top channel of a channel stack. * * Results: * NULL if the channel is not stacked upon another one, or a reference to * the channel it is stacked upon. This reference can be used in queries, * but modification is not allowed. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1635 1636 1637 1638 1639 1640 1641 | } /* *---------------------------------------------------------------------- * * Tcl_GetChannelThread -- * | | < | > | 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 | } /* *---------------------------------------------------------------------- * * Tcl_GetChannelThread -- * * Given a channel structure, returns the thread managing it. TIP #10 * * Results: * Returns the id of the thread managing the channel. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_ThreadId Tcl_GetChannelThread(chan) Tcl_Channel chan; /* The channel to return managing thread * for. */ { Channel *chanPtr = (Channel *) chan; /* The actual channel. */ return chanPtr->state->managingThread; } /* |
︙ | ︙ | |||
1676 1677 1678 1679 1680 1681 1682 | *---------------------------------------------------------------------- */ Tcl_ChannelType * Tcl_GetChannelType(chan) Tcl_Channel chan; /* The channel to return type for. */ { | | > | | | | | | | < | 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 | *---------------------------------------------------------------------- */ Tcl_ChannelType * Tcl_GetChannelType(chan) Tcl_Channel chan; /* The channel to return type for. */ { Channel *chanPtr = (Channel *) chan; /* The actual channel. */ return chanPtr->typePtr; } /* *---------------------------------------------------------------------- * * Tcl_GetChannelMode -- * * Computes a mask indicating whether the channel is open for reading and * writing. * * Results: * An OR-ed combination of TCL_READABLE and TCL_WRITABLE. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetChannelMode(chan) Tcl_Channel chan; /* The channel for which the mode is being * computed. */ { ChannelState *statePtr = ((Channel *) chan)->state; /* State of actual channel. */ return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE)); } /* *---------------------------------------------------------------------- * * Tcl_GetChannelName -- * * Returns the string identifying the channel name. * * Results: * The string containing the channel name. This memory is owned by the * generic layer and should not be modified by the caller. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1778 1779 1780 1781 1782 1783 1784 | } /* *--------------------------------------------------------------------------- * * AllocChannelBuffer -- * | | | | | < | | | | | 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 | } /* *--------------------------------------------------------------------------- * * AllocChannelBuffer -- * * A channel buffer has BUFFER_PADDING bytes extra at beginning to hold * any bytes of a native-encoding character that got split by the end of * the previous buffer and need to be moved to the beginning of the next * buffer to make a contiguous string so it can be converted to UTF-8. * * A channel buffer has BUFFER_PADDING bytes extra at the end to hold any * bytes of a native-encoding character (generated from a UTF-8 * character) that overflow past the end of the buffer and need to be * moved to the next buffer. * * Results: * A newly allocated channel buffer. * * Side effects: * None. * |
︙ | ︙ | |||
1819 1820 1821 1822 1823 1824 1825 | } /* *---------------------------------------------------------------------- * * RecycleBuffer -- * | | | | | < | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * RecycleBuffer -- * * Helper function to recycle input and output buffers. Ensures that two * input buffers are saved (one in the input queue and another in the * saveInBufPtr field) and that curOutPtr is set to a buffer. Only if * these conditions are met is the buffer freed to the OS. * * Results: * None. * * Side effects: * May free a buffer to the OS. * *---------------------------------------------------------------------- */ static void RecycleBuffer(statePtr, bufPtr, mustDiscard) ChannelState *statePtr; /* ChannelState in which to recycle buffers. */ ChannelBuffer *bufPtr; /* The buffer to recycle. */ int mustDiscard; /* If nonzero, free the buffer to the OS, * always. */ { /* * Do we have to free the buffer to the OS? */ if (mustDiscard) { ckfree((char *) bufPtr); return; } /* * Only save buffers which are at least as big as the requested buffersize * for the channel. This is to honor dynamic changes of the buffersize * made by the user. */ if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) { ckfree((char *) bufPtr); return; } /* * Only save buffers for the input queue if the channel is readable. */ if (statePtr->flags & TCL_READABLE) { if (statePtr->inQueueHead == (ChannelBuffer *) NULL) { statePtr->inQueueHead = bufPtr; statePtr->inQueueTail = bufPtr; goto keepBuffer; } if (statePtr->saveInBufPtr == (ChannelBuffer *) NULL) { statePtr->saveInBufPtr = bufPtr; goto keepBuffer; } } /* * Only save buffers for the output queue if the channel is writable. */ if (statePtr->flags & TCL_WRITABLE) { if (statePtr->curOutPtr == (ChannelBuffer *) NULL) { statePtr->curOutPtr = bufPtr; goto keepBuffer; } } /* * If we reached this code we return the buffer to the OS. */ ckfree((char *) bufPtr); return; keepBuffer: bufPtr->nextRemoved = BUFFER_PADDING; bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextPtr = (ChannelBuffer *) NULL; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
1937 1938 1939 1940 1941 1942 1943 | } /* *---------------------------------------------------------------------- * * CheckForDeadChannel -- * | | | | | | | | | | | | | | | | | | | | < | 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 | } /* *---------------------------------------------------------------------- * * CheckForDeadChannel -- * * This function checks is a given channel is Dead (a channel that has * been closed but not yet deallocated.) * * Results: * True (1) if channel is Dead, False (0) if channel is Ok * * Side effects: * None * *---------------------------------------------------------------------- */ static int CheckForDeadChannel(interp, statePtr) Tcl_Interp *interp; /* For error reporting (can be NULL) */ ChannelState *statePtr; /* The channel state to check. */ { if (statePtr->flags & CHANNEL_DEAD) { Tcl_SetErrno(EINVAL); if (interp) { Tcl_AppendResult(interp, "unable to access channel: invalid channel", (char *) NULL); } return 1; } return 0; } /* *---------------------------------------------------------------------- * * FlushChannel -- * * This function flushes as much of the queued output as is possible * now. If calledFromAsyncFlush is nonzero, it is being called in an * event handler to flush channel output asynchronously. * * Results: * 0 if successful, else the error code that was returned by the channel * type operation. May leave a message in the interp result. * * Side effects: * May produce output on a channel. May block indefinitely if the channel * is synchronous. May schedule an async flush on the channel. May * recycle memory for buffers in the output queue. * *---------------------------------------------------------------------- */ static int FlushChannel(interp, chanPtr, calledFromAsyncFlush) Tcl_Interp *interp; /* For error reporting during close. */ Channel *chanPtr; /* The channel to flush on. */ int calledFromAsyncFlush; /* If nonzero then we are being called * from an asynchronous flush * callback. */ { ChannelState *statePtr = chanPtr->state; /* State of the channel stack. */ ChannelBuffer *bufPtr; /* Iterates over buffered output * queue. */ int toWrite; /* Amount of output data in current * buffer available to be written. */ int written; /* Amount of output data actually * written in current round. */ int errorCode = 0; /* Stores POSIX error codes from * channel driver operations. */ int wroteSome = 0; /* Set to one if any data was written * to the driver. */ /* * Prevent writing on a dead channel -- a channel that has been closed but * not yet deallocated. This can occur if the exit handler for the channel * deallocation runs before all channels are deregistered in all * interpreters. */ if (CheckForDeadChannel(interp, statePtr)) { return -1; } /* * Loop over the queued buffers and attempt to flush as much as possible * of the queued output to the channel. */ while (1) { /* * If the queue is empty and there is a ready current buffer, OR if * the current buffer is full, then move the current buffer to the * queue. */ if (((statePtr->curOutPtr != (ChannelBuffer *) NULL) && |
︙ | ︙ | |||
2049 2050 2051 2052 2053 2054 2055 | } statePtr->outQueueTail = statePtr->curOutPtr; statePtr->curOutPtr = (ChannelBuffer *) NULL; } bufPtr = statePtr->outQueueHead; /* | | | | 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 | } statePtr->outQueueTail = statePtr->curOutPtr; statePtr->curOutPtr = (ChannelBuffer *) NULL; } bufPtr = statePtr->outQueueHead; /* * If we are not being called from an async flush and an async flush * is active, we just return without producing any output. */ if ((!calledFromAsyncFlush) && (statePtr->flags & BG_FLUSH_SCHEDULED)) { return 0; } |
︙ | ︙ | |||
2093 2094 2095 2096 2097 2098 2099 | if (errorCode == EINTR) { errorCode = 0; continue; } /* | | | | | | | > > > > > > > > > > > | | > > > > > > > > > > > > > > > | | | | | | | | > | | > > > | > | | | 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 | if (errorCode == EINTR) { errorCode = 0; continue; } /* * If the channel is non-blocking and we would have blocked, start * a background flushing handler and break out of the loop. */ if ((errorCode == EWOULDBLOCK) || (errorCode == EAGAIN)) { /* * This used to check for CHANNEL_NONBLOCKING, and panic if * the channel was blocking. However, it appears that setting * stdin to -blocking 0 has some effect on the stdout when * it's a tty channel (dup'ed underneath) */ if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) { statePtr->flags |= BG_FLUSH_SCHEDULED; UpdateInterest(chanPtr); } errorCode = 0; break; } /* * Decide whether to report the error upwards or defer it. */ if (calledFromAsyncFlush) { /* TIP #219, Tcl Channel Reflection API. * When defering the error copy a message from the bypass into * the unreported area. Or discard it if the new error is to be * ignored in favor of an earlier defered error. */ Tcl_Obj* msg = statePtr->chanMsg; if (statePtr->unreportedError == 0) { statePtr->unreportedError = errorCode; statePtr->unreportedMsg = msg; if (msg != NULL) { Tcl_IncrRefCount (msg); } } else { /* An old unreported error is kept, and this error * thrown away. */ statePtr->chanMsg = NULL; if (msg != NULL) { Tcl_DecrRefCount (msg); } } } else { /* TIP #219, Tcl Channel Reflection API. * Move error messages put by the driver into the chan bypass * area into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypasses. */ Tcl_SetErrno(errorCode); if (interp != NULL) { if (!TclChanCaughtErrorBypass (interp, (Tcl_Channel) chanPtr)) { /* * Casting away CONST here is safe because the * TCL_VOLATILE flag guarantees CONST treatment * of the Posix error string. */ Tcl_SetResult(interp, (char *) Tcl_PosixError(interp), TCL_VOLATILE); } } /* An unreportable bypassed message is kept, for the * caller of Tcl_Seek, Tcl_Write, etc. */ } /* * When we get an error we throw away all the output currently * queued. */ DiscardOutputQueued(statePtr); continue; } else { wroteSome = 1; } |
︙ | ︙ | |||
2164 2165 2166 2167 2168 2169 2170 | } RecycleBuffer(statePtr, bufPtr, 0); } } /* Closes "while (1)". */ /* * If we wrote some data while flushing in the background, we are done. | | | | | | | | 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 | } RecycleBuffer(statePtr, bufPtr, 0); } } /* Closes "while (1)". */ /* * If we wrote some data while flushing in the background, we are done. * We can't finish the background flush until we run out of data and the * channel becomes writable again. This ensures that all of the pending * data has been flushed at the system level. */ if (statePtr->flags & BG_FLUSH_SCHEDULED) { if (wroteSome) { return errorCode; } else if (statePtr->outQueueHead == (ChannelBuffer *) NULL) { statePtr->flags &= (~(BG_FLUSH_SCHEDULED)); (chanPtr->typePtr->watchProc)(chanPtr->instanceData, statePtr->interestMask); } } /* * If the channel is flagged as closed, delete it when the refCount drops * to zero, the output queue is empty and there is no output in the * current output buffer. */ if ((statePtr->flags & CHANNEL_CLOSED) && (statePtr->refCount <= 0) && (statePtr->outQueueHead == (ChannelBuffer *) NULL) && ((statePtr->curOutPtr == (ChannelBuffer *) NULL) || (statePtr->curOutPtr->nextAdded == statePtr->curOutPtr->nextRemoved))) { |
︙ | ︙ | |||
2206 2207 2208 2209 2210 2211 2212 | * * Utility procedure to close a channel and free associated resources. * * If the channel was stacked, then the it will copy the necessary * elements of the NEXT channel into the TOP channel, in essence * unstacking the channel. The NEXT channel will then be freed. * | | | | | | | 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 | * * Utility procedure to close a channel and free associated resources. * * If the channel was stacked, then the it will copy the necessary * elements of the NEXT channel into the TOP channel, in essence * unstacking the channel. The NEXT channel will then be freed. * * If the channel was not stacked, then we will free all the bits for the * TOP channel, including the data structure itself. * * Results: * Error code from an unreported error or the driver close operation. * * Side effects: * May close the actual channel, may free memory, may change the value of * errno. * *---------------------------------------------------------------------- */ static int CloseChannel(interp, chanPtr, errorCode) Tcl_Interp *interp; /* For error reporting. */ |
︙ | ︙ | |||
2251 2252 2253 2254 2255 2256 2257 | if (statePtr->curOutPtr != (ChannelBuffer *) NULL) { ckfree((char *) statePtr->curOutPtr); statePtr->curOutPtr = (ChannelBuffer *) NULL; } /* | | < | | > > > > > > > > > > > > > | > | | < | | > > > > > > > > > > > | 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 | if (statePtr->curOutPtr != (ChannelBuffer *) NULL) { ckfree((char *) statePtr->curOutPtr); statePtr->curOutPtr = (ChannelBuffer *) NULL; } /* * The caller guarantees that there are no more buffers queued for output. */ if (statePtr->outQueueHead != (ChannelBuffer *) NULL) { Tcl_Panic("TclFlush, closed channel: queued output left"); } /* * If the EOF character is set in the channel, append that to the output * device. */ if ((statePtr->outEofChar != 0) && (statePtr->flags & TCL_WRITABLE)) { int dummy; char c = (char) statePtr->outEofChar; (chanPtr->typePtr->outputProc) (chanPtr->instanceData, &c, 1, &dummy); } /* TIP #219, Tcl Channel Reflection API. * Move a leftover error message in the channel bypass into the * interpreter bypass. Just clear it if there is no interpreter. */ if (statePtr->chanMsg != NULL) { if (interp != NULL) { Tcl_SetChannelErrorInterp (interp,statePtr->chanMsg); } Tcl_DecrRefCount (statePtr->chanMsg); statePtr->chanMsg = NULL; } /* * Remove this channel from of the list of all channels. */ CutChannel((Tcl_Channel) chanPtr); /* * Close and free the channel driver state. * This may leave a TIP #219 error message in the interp. */ if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData, interp); } else { result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp, 0); } /* * Some resources can be cleared only if the bottom channel in a stack is * closed. All the other channels in the stack are not allowed to remove. */ if (chanPtr == statePtr->bottomChanPtr) { if (statePtr->channelName != (char *) NULL) { ckfree((char *) statePtr->channelName); statePtr->channelName = NULL; } Tcl_FreeEncoding(statePtr->encoding); if (statePtr->outputStage != NULL) { ckfree((char *) statePtr->outputStage); statePtr->outputStage = (char *) NULL; } } /* * If we are being called synchronously, report either any latent error on * the channel or the current error. */ if (statePtr->unreportedError != 0) { errorCode = statePtr->unreportedError; /* TIP #219, Tcl Channel Reflection API. * Move an error message found in the unreported area into the regular * bypass (interp). This kills any message in the channel bypass area. */ if (statePtr->chanMsg != NULL) { Tcl_DecrRefCount (statePtr->chanMsg); statePtr->chanMsg = NULL; } Tcl_SetChannelErrorInterp (interp,statePtr->unreportedMsg); } if (errorCode == 0) { errorCode = result; if (errorCode != 0) { Tcl_SetErrno(errorCode); } } |
︙ | ︙ | |||
2347 2348 2349 2350 2351 2352 2353 | chanPtr->typePtr = NULL; Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); return Tcl_Close(interp, (Tcl_Channel) downChanPtr); } /* | | | < | | > | | < | | | | | < | | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > > > > > > > > > | | | | | | | | < | | | | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > > | > > > > > > > > | | | | | | | > | 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 | chanPtr->typePtr = NULL; Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); return Tcl_Close(interp, (Tcl_Channel) downChanPtr); } /* * There is only the TOP Channel, so we free the remaining pointers we * have and then ourselves. Since this is the last of the channels in the * stack, make sure to free the ChannelState structure associated with it. * We use Tcl_EventuallyFree to allow for any last references. */ chanPtr->typePtr = NULL; Tcl_EventuallyFree((ClientData) statePtr, TCL_DYNAMIC); Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); return errorCode; } /* *---------------------------------------------------------------------- * * Tcl_CutChannel -- * CutChannel -- * * Removes a channel from the (thread-)global list of all channels (in * that thread). This is actually the statePtr for the stack of channel. * * Results: * Nothing. * * Side effects: * Resets the field 'nextCSPtr' of the specified channel state to NULL. * * NOTE: * The channel to cut out of the list must not be referenced in any * interpreter. This is something this procedure cannot check (despite * the refcount) because the caller usually wants fiddle with the channel * (like transfering it to a different thread) and thus keeps the * refcount artifically high to prevent its destruction. * *---------------------------------------------------------------------- */ static void CutChannel(chan) Tcl_Channel chan; /* The channel being removed. Must * not be referenced in any * interpreter. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ChannelState *prevCSPtr; /* Preceding channel state in list of * all states - used to splice a * channel out of the list on close. */ ChannelState *statePtr = ((Channel *) chan)->state; /* state of the channel stack. */ Tcl_DriverThreadActionProc *threadActionProc; /* * Remove this channel from of the list of all channels (in the current * thread). */ if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) { tsdPtr->firstCSPtr = statePtr->nextCSPtr; } else { for (prevCSPtr = tsdPtr->firstCSPtr; prevCSPtr && (prevCSPtr->nextCSPtr != statePtr); prevCSPtr = prevCSPtr->nextCSPtr) { /* Empty loop body. */ } if (prevCSPtr == (ChannelState *) NULL) { Tcl_Panic("FlushChannel: damaged channel list"); } prevCSPtr->nextCSPtr = statePtr->nextCSPtr; } statePtr->nextCSPtr = (ChannelState *) NULL; /* TIP #218, Channel Thread Actions */ threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan)); if (threadActionProc != NULL) { (*threadActionProc) (Tcl_GetChannelInstanceData(chan), TCL_CHANNEL_THREAD_REMOVE); } } void Tcl_CutChannel(chan) Tcl_Channel chan; /* The channel being added. Must not * be referenced in any * interpreter. */ { Channel* chanPtr = ((Channel*) chan)->state->bottomChanPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ChannelState *prevCSPtr; /* Preceding channel state in list of * all states - used to splice a * channel out of the list on close. */ ChannelState *statePtr = chanPtr->state; /* state of the channel stack. */ Tcl_DriverThreadActionProc *threadActionProc; /* * Remove this channel from of the list of all channels (in the current * thread). */ if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) { tsdPtr->firstCSPtr = statePtr->nextCSPtr; } else { for (prevCSPtr = tsdPtr->firstCSPtr; prevCSPtr && (prevCSPtr->nextCSPtr != statePtr); prevCSPtr = prevCSPtr->nextCSPtr) { /* Empty loop body. */ } if (prevCSPtr == (ChannelState *) NULL) { Tcl_Panic("FlushChannel: damaged channel list"); } prevCSPtr->nextCSPtr = statePtr->nextCSPtr; } statePtr->nextCSPtr = (ChannelState *) NULL; /* TIP #218, Channel Thread Actions * For all transformations and the base channel. */ while (chanPtr) { threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr); if (threadActionProc != NULL) { (*threadActionProc) (chanPtr->instanceData, TCL_CHANNEL_THREAD_REMOVE); } chanPtr= chanPtr->upChanPtr; } } /* *---------------------------------------------------------------------- * * Tcl_SpliceChannel -- * SpliceChannel -- * * Adds a channel to the (thread-)global list of all channels (in that * thread). Expects that the field 'nextChanPtr' in the channel is set to * NULL. * * Results: * Nothing. * * Side effects: * Nothing. * * NOTE: * The channel to splice into the list must not be referenced in any * interpreter. This is something this procedure cannot check (despite * the refcount) because the caller usually wants figgle with the channel * (like transfering it to a different thread) and thus keeps the * refcount artifically high to prevent its destruction. * *---------------------------------------------------------------------- */ static void SpliceChannel(chan) Tcl_Channel chan; /* The channel being added. Must not * be referenced in any * interpreter. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ChannelState *statePtr = ((Channel *) chan)->state; Tcl_DriverThreadActionProc *threadActionProc; if (statePtr->nextCSPtr != (ChannelState *) NULL) { Tcl_Panic("SpliceChannel: trying to add channel used in different list"); } statePtr->nextCSPtr = tsdPtr->firstCSPtr; tsdPtr->firstCSPtr = statePtr; /* * TIP #10. Mark the current thread as the new one managing this channel. * Note: 'Tcl_GetCurrentThread' returns sensible values even for * a non-threaded core. */ statePtr->managingThread = Tcl_GetCurrentThread(); /* TIP #218, Channel Thread Actions */ threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan)); if (threadActionProc != NULL) { (*threadActionProc) (Tcl_GetChannelInstanceData(chan), TCL_CHANNEL_THREAD_INSERT); } } void Tcl_SpliceChannel(chan) Tcl_Channel chan; /* The channel being added. Must not * be referenced in any * interpreter. */ { Channel *chanPtr = ((Channel*) chan)->state->bottomChanPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ChannelState *statePtr = chanPtr->state; Tcl_DriverThreadActionProc *threadActionProc; if (statePtr->nextCSPtr != (ChannelState *) NULL) { Tcl_Panic("SpliceChannel: trying to add channel used in different list"); } statePtr->nextCSPtr = tsdPtr->firstCSPtr; tsdPtr->firstCSPtr = statePtr; /* * TIP #10. Mark the current thread as the new one managing this channel. * Note: 'Tcl_GetCurrentThread' returns sensible values even for * a non-threaded core. */ statePtr->managingThread = Tcl_GetCurrentThread(); /* TIP #218, Channel Thread Actions * For all transformations and the base channel. */ while (chanPtr) { threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr); if (threadActionProc != NULL) { (*threadActionProc) (chanPtr->instanceData, TCL_CHANNEL_THREAD_INSERT); } chanPtr= chanPtr->upChanPtr; } } /* *---------------------------------------------------------------------- * * Tcl_Close -- * * Closes a channel. * * Results: * A standard Tcl result. * * Side effects: * Closes the channel if this is the last reference. * * NOTE: * Tcl_Close removes the channel as far as the user is concerned. * However, it may continue to exist for a while longer if it has a * background flush scheduled. The device itself is eventually closed and * the channel record removed, in CloseChannel, above. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_Close(interp, chan) Tcl_Interp *interp; /* Interpreter for errors. */ Tcl_Channel chan; /* The channel being closed. Must not * be referenced in any * interpreter. */ { CloseCallback *cbPtr; /* Iterate over close callbacks for * this channel. */ Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of real IO channel. */ int result; /* Of calling FlushChannel. */ int flushcode; if (chan == (Tcl_Channel) NULL) { return TCL_OK; } /* * Perform special handling for standard channels being closed. If the |
︙ | ︙ | |||
2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 | } statePtr->flags |= CHANNEL_INCLOSE; /* * When the channel has an escape sequence driven encoding such as * iso2022, the terminated escape sequence must write to the buffer. */ if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL) && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { statePtr->outputEncodingFlags |= TCL_ENCODING_END; WriteChars(chanPtr, "", 0); } Tcl_ClearChannelHandlers(chan); /* * Invoke the registered close callbacks and delete their records. */ | > > > > > > > > > > > > > > | 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 | } statePtr->flags |= CHANNEL_INCLOSE; /* * When the channel has an escape sequence driven encoding such as * iso2022, the terminated escape sequence must write to the buffer. */ if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL) && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { statePtr->outputEncodingFlags |= TCL_ENCODING_END; WriteChars(chanPtr, "", 0); /* TIP #219, Tcl Channel Reflection API. * Move an error message found in the channel bypass into the * interpreter bypass. Just clear it if there is no interpreter. */ if (statePtr->chanMsg != NULL) { if (interp != NULL) { Tcl_SetChannelErrorInterp (interp,statePtr->chanMsg); } Tcl_DecrRefCount (statePtr->chanMsg); statePtr->chanMsg = NULL; } } Tcl_ClearChannelHandlers(chan); /* * Invoke the registered close callbacks and delete their records. */ |
︙ | ︙ | |||
2584 2585 2586 2587 2588 2589 2590 | if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) && (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) { statePtr->flags |= BUFFER_READY; } /* | | | | | | > | > > > > > > > > > > > > > > > > > | 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 | if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) && (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) { statePtr->flags |= BUFFER_READY; } /* * If this channel supports it, close the read side, since we don't need * it anymore and this will help avoid deadlocks on some channel types. */ if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) { result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp, TCL_CLOSE_READ); } else { result = 0; } /* * The call to FlushChannel will flush any queued output and invoke the * close function of the channel driver, or it will set up the channel to * be flushed and closed asynchronously. */ statePtr->flags |= CHANNEL_CLOSED; flushcode = FlushChannel(interp, chanPtr, 0); /* TIP #219. * Capture error messages put by the driver into the bypass area and put * them into the regular interpreter result. * * Notes: Due to the assertion of CHANNEL_CLOSED in the flags * "FlushChannel" has called "CloseChannel" and thus freed all the channel * structures. We must not try to access "chan" anymore, hence the NULL * argument in the call below. The only place which may still contain a * message is the interpreter itself, and "CloseChannel" made sure to lift * any channel message it generated into it. */ if (TclChanCaughtErrorBypass (interp, NULL)) { result = EINVAL; } if ((flushcode != 0) || (result != 0)) { return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
2646 2647 2648 2649 2650 2651 2652 | */ chanPtr = (Channel *) channel; statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; /* | > > > > > > | | | < | 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 | */ chanPtr = (Channel *) channel; statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; /* * Cancel any outstanding timer. */ Tcl_DeleteTimerHandler(statePtr->timer); /* * Remove any references to channel handlers for this channel that may be * about to be invoked. */ for (nhPtr = tsdPtr->nestedHandlerPtr; nhPtr != (NextChannelHandler *) NULL; nhPtr = nhPtr->nestedHandlerPtr) { if (nhPtr->nextHandlerPtr && (nhPtr->nextHandlerPtr->chanPtr == chanPtr)) { nhPtr->nextHandlerPtr = NULL; } } /* * Remove all the channel handler records attached to the channel itself. */ for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; chPtr = chNext) { chNext = chPtr->nextPtr; ckfree((char *) chPtr); |
︙ | ︙ | |||
2683 2684 2685 2686 2687 2688 2689 2690 | StopCopy(statePtr->csPtr); /* * Must set the interest mask now to 0, otherwise infinite loops * will occur if Tcl_DoOneEvent is called before the channel is * finally deleted in FlushChannel. This can happen if the channel * has a background flush active. */ | > > > > > | > | | | | | | 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 | StopCopy(statePtr->csPtr); /* * Must set the interest mask now to 0, otherwise infinite loops * will occur if Tcl_DoOneEvent is called before the channel is * finally deleted in FlushChannel. This can happen if the channel * has a background flush active. * Also, delete all registered file handlers for this channel * (and for the current thread). This prevents executing of pending * file-events still sitting in the event queue of the current thread. * We deliberately do not call UpdateInterest() because this could * re-schedule new events if the channel still needs to be flushed. */ statePtr->interestMask = 0; (chanPtr->typePtr->watchProc)(chanPtr->instanceData, 0); /* * Remove any EventScript records for this channel. */ for (ePtr = statePtr->scriptRecordPtr; ePtr != (EventScriptRecord *) NULL; ePtr = eNextPtr) { eNextPtr = ePtr->nextPtr; TclDecrRefCount(ePtr->scriptPtr); ckfree((char *) ePtr); } statePtr->scriptRecordPtr = (EventScriptRecord *) NULL; } /* *---------------------------------------------------------------------- * * Tcl_Write -- * * Puts a sequence of bytes into an output buffer, may queue the buffer * for output if it gets full, and also remembers whether the current * buffer is ready e.g. if it contains a newline and we are in line * buffering mode. Compensates stacking, i.e. will redirect the data from * the specified channel to the topmost channel in a stack. * * No encoding conversions are applied to the bytes being read. * * Results: * The number of bytes written or -1 in case of error. If -1, * Tcl_GetErrno will return the error code. * |
︙ | ︙ | |||
2757 2758 2759 2760 2761 2762 2763 | } /* *---------------------------------------------------------------------- * * Tcl_WriteRaw -- * | | | | | | | 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 | } /* *---------------------------------------------------------------------- * * Tcl_WriteRaw -- * * Puts a sequence of bytes into an output buffer, may queue the buffer * for output if it gets full, and also remembers whether the current * buffer is ready e.g. if it contains a newline and we are in line * buffering mode. Writes directly to the driver of the channel, does not * compensate for stacking. * * No encoding conversions are applied to the bytes being read. * * Results: * The number of bytes written or -1 in case of error. If -1, * Tcl_GetErrno will return the error code. * |
︙ | ︙ | |||
2816 2817 2818 2819 2820 2821 2822 | /* *--------------------------------------------------------------------------- * * Tcl_WriteChars -- * * Takes a sequence of UTF-8 characters and converts them for output | | | | | | | > | | | | | | | > | | | | | | | | | | | | > | 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 | /* *--------------------------------------------------------------------------- * * Tcl_WriteChars -- * * Takes a sequence of UTF-8 characters and converts them for output * using the channel's current encoding, may queue the buffer for output * if it gets full, and also remembers whether the current buffer is * ready e.g. if it contains a newline and we are in line buffering * mode. Compensates stacking, i.e. will redirect the data from the * specified channel to the topmost channel in a stack. * * Results: * The number of bytes written or -1 in case of error. If -1, * Tcl_GetErrno will return the error code. * * Side effects: * May buffer up output and may cause output to be produced on the * channel. * *---------------------------------------------------------------------- */ int Tcl_WriteChars(chan, src, len) Tcl_Channel chan; /* The channel to buffer output for. */ CONST char *src; /* UTF-8 characters to queue in output * buffer. */ int len; /* Length of string in bytes, or < 0 for * strlen(). */ { ChannelState *statePtr; /* state info for channel */ statePtr = ((Channel *) chan)->state; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { return -1; } return DoWriteChars((Channel *) chan, src, len); } /* *--------------------------------------------------------------------------- * * DoWriteChars -- * * Takes a sequence of UTF-8 characters and converts them for output * using the channel's current encoding, may queue the buffer for output * if it gets full, and also remembers whether the current buffer is * ready e.g. if it contains a newline and we are in line buffering mode. * Compensates stacking, i.e. will redirect the data from the specified * channel to the topmost channel in a stack. * * Results: * The number of bytes written or -1 in case of error. If -1, * Tcl_GetErrno will return the error code. * * Side effects: * May buffer up output and may cause output to be produced on the * channel. * *---------------------------------------------------------------------- */ static int DoWriteChars(chanPtr, src, len) Channel *chanPtr; /* The channel to buffer output for. */ CONST char *src; /* UTF-8 characters to queue in output * buffer. */ int len; /* Length of string in bytes, or < 0 for * strlen(). */ { /* * Always use the topmost channel of the stack */ ChannelState *statePtr; /* state info for channel */ statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; if (len < 0) { len = strlen(src); } if (statePtr->encoding == NULL) { /* * Inefficient way to convert UTF-8 to byte-array, but the code * parallels the way it is done for objects. */ Tcl_Obj *objPtr; int result; objPtr = Tcl_NewStringObj(src, len); src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); result = WriteBytes(chanPtr, src, len); TclDecrRefCount(objPtr); return result; } return WriteChars(chanPtr, src, len); } /* *--------------------------------------------------------------------------- * * Tcl_WriteObj -- * * Takes the Tcl object and queues its contents for output. If the * encoding of the channel is NULL, takes the byte-array representation * of the object and queues those bytes for output. Otherwise, takes the * characters in the UTF-8 (string) representation of the object and * converts them for output using the channel's current encoding. May * flush internal buffers to output if one becomes full or is ready for * some other reason, e.g. if it contains a newline and the channel is in * line buffering mode. * * Results: * The number of bytes written or -1 in case of error. If -1, * Tcl_GetErrno() will return the error code. * * Side effects: * May buffer up output and may cause output to be produced on the * channel. * *---------------------------------------------------------------------- */ int Tcl_WriteObj(chan, objPtr) Tcl_Channel chan; /* The channel to buffer output for. */ Tcl_Obj *objPtr; /* The object to write. */ { /* * Always use the topmost channel of the stack */ Channel *chanPtr; ChannelState *statePtr; /* state info for channel */ char *src; int srcLen; statePtr = ((Channel *) chan)->state; chanPtr = statePtr->topChanPtr; |
︙ | ︙ | |||
2969 2970 2971 2972 2973 2974 2975 | } /* *---------------------------------------------------------------------- * * WriteBytes -- * | | | | | | 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 | } /* *---------------------------------------------------------------------- * * WriteBytes -- * * Write a sequence of bytes into an output buffer, may queue the buffer * for output if it gets full, and also remembers whether the current * buffer is ready e.g. if it contains a newline and we are in line * buffering mode. * * Results: * The number of bytes written or -1 in case of error. If -1, * Tcl_GetErrno will return the error code. * * Side effects: * May buffer up output and may cause output to be produced on the |
︙ | ︙ | |||
3001 3002 3003 3004 3005 3006 3007 | int dstMax, sawLF, savedLF, total, dstLen, toWrite; total = 0; sawLF = 0; savedLF = 0; /* | | | | | | 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 | int dstMax, sawLF, savedLF, total, dstLen, toWrite; total = 0; sawLF = 0; savedLF = 0; /* * Loop over all bytes in src, storing them in output buffer with proper * EOL translation. */ while (srcLen + savedLF > 0) { bufPtr = statePtr->curOutPtr; if (bufPtr == NULL) { bufPtr = AllocChannelBuffer(statePtr->bufSize); statePtr->curOutPtr = bufPtr; } dst = bufPtr->buf + bufPtr->nextAdded; dstMax = bufPtr->bufLength - bufPtr->nextAdded; dstLen = dstMax; toWrite = dstLen; if (toWrite > srcLen) { toWrite = srcLen; } if (savedLF) { /* * A '\n' was left over from last call to TranslateOutputEOL() and * we need to store it in this buffer. If the channel is * line-based, we will need to flush it. */ *dst++ = '\n'; dstLen--; sawLF++; } |
︙ | ︙ | |||
3058 3059 3060 3061 3062 3063 3064 | } /* *---------------------------------------------------------------------- * * WriteChars -- * | | | | | < | 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 | } /* *---------------------------------------------------------------------- * * WriteChars -- * * Convert UTF-8 bytes to the channel's external encoding and write the * produced bytes into an output buffer, may queue the buffer for output * if it gets full, and also remembers whether the current buffer is * ready e.g. if it contains a newline and we are in line buffering mode. * * Results: * The number of bytes written or -1 in case of error. If -1, * Tcl_GetErrno will return the error code. * * Side effects: * May buffer up output and may cause output to be produced on the |
︙ | ︙ | |||
3121 3122 3123 3124 3125 3126 3127 | toWrite = stageLen; if (toWrite > srcLen) { toWrite = srcLen; } if (savedLF) { /* | | | | | | 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 | toWrite = stageLen; if (toWrite > srcLen) { toWrite = srcLen; } if (savedLF) { /* * A '\n' was left over from last call to TranslateOutputEOL() and * we need to store it in the staging buffer. If the channel is * line-based, we will need to flush the output buffer (after * translating the staging buffer). */ *stage++ = '\n'; stageLen--; sawLF++; } if (TranslateOutputEOL(statePtr, stage, src, &stageLen, &toWrite)) { |
︙ | ︙ | |||
3162 3163 3164 3165 3166 3167 3168 | statePtr->curOutPtr = bufPtr; } dst = bufPtr->buf + bufPtr->nextAdded; dstLen = bufPtr->bufLength - bufPtr->nextAdded; if (saved != 0) { /* | | | < | 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 | statePtr->curOutPtr = bufPtr; } dst = bufPtr->buf + bufPtr->nextAdded; dstLen = bufPtr->bufLength - bufPtr->nextAdded; if (saved != 0) { /* * Here's some translated bytes left over from the last buffer * that we need to stick at the beginning of this buffer. */ memcpy((VOID *) dst, (VOID *) safe, (size_t) saved); bufPtr->nextAdded += saved; dst += saved; dstLen -= saved; saved = 0; |
︙ | ︙ | |||
3217 3218 3219 3220 3221 3222 3223 | savedLF = 0; break; } bufPtr->nextAdded += dstWrote; if (bufPtr->nextAdded > bufPtr->bufLength) { /* * When translating from UTF-8 to external encoding, we | | | | | < | 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 | savedLF = 0; break; } bufPtr->nextAdded += dstWrote; if (bufPtr->nextAdded > bufPtr->bufLength) { /* * When translating from UTF-8 to external encoding, we * allowed the translation to produce a character that crossed * the end of the output buffer, so that we would get a * completely full buffer before flushing it. The extra bytes * will be moved to the beginning of the next buffer. */ saved = bufPtr->nextAdded - bufPtr->bufLength; memcpy((VOID *) safe, (VOID *) (dst + dstLen), (size_t) saved); bufPtr->nextAdded = bufPtr->bufLength; } if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) { |
︙ | ︙ | |||
3251 3252 3253 3254 3255 3256 3257 | if ((stageLen + saved == 0) && (result == 0)) { endEncoding = 0; } } } | > | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | < | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | 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 | 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 -- * * Helper function for WriteBytes() and WriteChars(). Converts the '\n' * characters in the source buffer into the appropriate EOL form * specified by the output translation mode. * * EOL translation stops either when the source buffer is empty or the * output buffer is full. * * When converting to CRLF mode and there is only 1 byte left in the * output buffer, this routine stores the '\r' in the last byte and then * stores the '\n' in the byte just past the end of the buffer. The * caller is responsible for passing in a buffer that is large enough to * hold the extra byte. * * Results: * The return value is 1 if a '\n' was translated from the source buffer, * or 0 otherwise -- this can be used by the caller to decide to flush a * line-based channel even though the channel buffer is not full. * * *dstLenPtr is filled with how many bytes of the output buffer were * used. As mentioned above, this can be one more that the output * buffer's specified length if a CRLF was stored. * * *srcLenPtr is filled with how many bytes of the source buffer were * consumed. * * Side effects: * It may be obvious, but bears mentioning that when converting in CRLF * mode (which requires two bytes of storage in the output buffer), the * number of bytes consumed from the source buffer will be less than the * number of bytes stored in the output buffer. * *--------------------------------------------------------------------------- */ static int TranslateOutputEOL(statePtr, dst, src, dstLenPtr, srcLenPtr) ChannelState *statePtr; /* Channel being read, for translation and * buffering modes. */ char *dst; /* Output buffer filled with UTF-8 chars by * applying appropriate EOL translation to * source characters. */ CONST char *src; /* Source UTF-8 characters. */ int *dstLenPtr; /* On entry, the maximum length of output * buffer in bytes. On exit, the number of * bytes actually used in output buffer. */ int *srcLenPtr; /* On entry, the length of source buffer. On * exit, the number of bytes read from the * source buffer. */ { char *dstEnd; int srcLen, newlineFound; newlineFound = 0; srcLen = *srcLenPtr; switch (statePtr->outputTranslation) { case TCL_TRANSLATE_LF: for (dstEnd = dst + srcLen; dst < dstEnd; ) { if (*src == '\n') { newlineFound = 1; } *dst++ = *src++; } *dstLenPtr = srcLen; break; case TCL_TRANSLATE_CR: for (dstEnd = dst + srcLen; dst < dstEnd;) { if (*src == '\n') { *dst++ = '\r'; newlineFound = 1; src++; } else { *dst++ = *src++; } } *dstLenPtr = srcLen; break; case TCL_TRANSLATE_CRLF: { /* * Since this causes the number of bytes to grow, we start off trying * to put 'srcLen' bytes into the output buffer, but allow it to store * more bytes, as long as there's still source bytes and room in the * output buffer. */ char *dstStart, *dstMax; CONST char *srcStart; dstStart = dst; dstMax = dst + *dstLenPtr; srcStart = src; if (srcLen < *dstLenPtr) { dstEnd = dst + srcLen; } else { dstEnd = dst + *dstLenPtr; } while (dst < dstEnd) { if (*src == '\n') { if (dstEnd < dstMax) { dstEnd++; } *dst++ = '\r'; newlineFound = 1; } *dst++ = *src++; } *srcLenPtr = src - srcStart; *dstLenPtr = dst - dstStart; break; } default: break; } return newlineFound; } /* *--------------------------------------------------------------------------- * * CheckFlush -- * * Helper function for WriteBytes() and WriteChars(). If the channel * buffer is ready to be flushed, flush it. * * Results: * The return value is -1 if there was a problem flushing the channel * buffer, or 0 otherwise. * * Side effects: * The buffer will be recycled if it is flushed. * *--------------------------------------------------------------------------- */ static int CheckFlush(chanPtr, bufPtr, newlineFlag) Channel *chanPtr; /* Channel being read, for buffering mode. */ ChannelBuffer *bufPtr; /* Channel buffer to possibly flush. */ int newlineFlag; /* Non-zero if a the channel buffer contains a * newline. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ /* * The current buffer is ready for output: * 1. if it is full. * 2. if it contains a newline and this channel is line-buffered. * 3. if it contains any output and this channel is unbuffered. |
︙ | ︙ | |||
3455 3456 3457 3458 3459 3460 3461 | * * Results: * Length of line read (in characters) or -1 if error, EOF, or blocked. * If -1, use Tcl_GetErrno() to retrieve the POSIX error code for the * error or condition that occurred. * * Side effects: | | | | 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 | * * Results: * Length of line read (in characters) or -1 if error, EOF, or blocked. * If -1, use Tcl_GetErrno() to retrieve the POSIX error code for the * error or condition that occurred. * * Side effects: * May flush output on the channel. May cause input to be consumed from * the channel. * *--------------------------------------------------------------------------- */ int Tcl_Gets(chan, lineRead) Tcl_Channel chan; /* Channel from which to read. */ |
︙ | ︙ | |||
3489 3490 3491 3492 3493 3494 3495 | /* *--------------------------------------------------------------------------- * * Tcl_GetsObj -- * * Accumulate input from the input channel until end-of-line or | | | < | | | | < | 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 | /* *--------------------------------------------------------------------------- * * Tcl_GetsObj -- * * Accumulate input from the input channel until end-of-line or * end-of-file has been seen. Bytes read from the input channel are * converted to UTF-8 using the encoding specified by the channel. * * Results: * Number of characters accumulated in the object or -1 if error, * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX * error code for the error or condition that occurred. * * Side effects: * Consumes input from the channel. * * On reading EOF, leave channel pointing at EOF char. On reading EOL, * leave channel pointing after EOL, but don't return EOL in dst buffer. * *--------------------------------------------------------------------------- */ int Tcl_GetsObj(chan, objPtr) Tcl_Channel chan; /* Channel from which to read. */ |
︙ | ︙ | |||
3538 3539 3540 3541 3542 3543 3544 | goto done; } bufPtr = statePtr->inQueueHead; encoding = statePtr->encoding; /* | | | | | | | 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 | goto done; } bufPtr = statePtr->inQueueHead; encoding = statePtr->encoding; /* * Preserved so we can restore the channel's state in case we don't find a * newline in the available input. */ Tcl_GetStringFromObj(objPtr, &oldLength); oldFlags = statePtr->inputEncodingFlags; oldState = statePtr->inputEncodingState; oldRemoved = BUFFER_PADDING; if (bufPtr != NULL) { oldRemoved = bufPtr->nextRemoved; } /* * If there is no encoding, use "iso8859-1" -- Tcl_GetsObj() doesn't * produce ByteArray objects. */ if (encoding == NULL) { encoding = Tcl_GetEncoding(NULL, "iso8859-1"); } /* * Object used by FilterInputBytes to keep track of how much data has been * consumed from the channel buffers. */ gs.objPtr = objPtr; gs.dstPtr = &dst; gs.encoding = encoding; gs.bufPtr = bufPtr; gs.state = oldState; |
︙ | ︙ | |||
3590 3591 3592 3593 3594 3595 3596 | if (FilterInputBytes(chanPtr, &gs) != 0) { goto restore; } dstEnd = dst + gs.bytesWrote; } /* | | | | | | | | | | | < | | | | | | | | < | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | if (FilterInputBytes(chanPtr, &gs) != 0) { goto restore; } dstEnd = dst + gs.bytesWrote; } /* * Remember if EOF char is seen, then look for EOL anyhow, because the * EOL might be before the EOF char. */ if (inEofChar != '\0') { for (eol = dst; eol < dstEnd; eol++) { if (*eol == inEofChar) { dstEnd = eol; eof = eol; break; } } } /* * On EOL, leave current file position pointing after the EOL, but * don't store the EOL in the output string. */ switch (statePtr->inputTranslation) { case TCL_TRANSLATE_LF: for (eol = dst; eol < dstEnd; eol++) { if (*eol == '\n') { skip = 1; goto gotEOL; } } break; case TCL_TRANSLATE_CR: for (eol = dst; eol < dstEnd; eol++) { if (*eol == '\r') { skip = 1; goto gotEOL; } } break; case TCL_TRANSLATE_CRLF: for (eol = dst; eol < dstEnd; eol++) { if (*eol == '\r') { eol++; /* * If a CR is at the end of the buffer, then check for a * LF at the begining of the next buffer. */ if (eol >= dstEnd) { int offset; offset = eol - objPtr->bytes; dst = dstEnd; if (FilterInputBytes(chanPtr, &gs) != 0) { goto restore; } dstEnd = dst + gs.bytesWrote; eol = objPtr->bytes + offset; if (eol >= dstEnd) { skip = 0; goto gotEOL; } } if (*eol == '\n') { eol--; skip = 2; goto gotEOL; } } } break; case TCL_TRANSLATE_AUTO: eol = dst; skip = 1; if (statePtr->flags & INPUT_SAW_CR) { statePtr->flags &= ~INPUT_SAW_CR; if ((eol < dstEnd) && (*eol == '\n')) { /* * Skip the raw bytes that make up the '\n'. */ char tmp[1 + TCL_UTF_MAX]; int rawRead; bufPtr = gs.bufPtr; Tcl_ExternalToUtf(NULL, gs.encoding, bufPtr->buf + bufPtr->nextRemoved, gs.rawRead, statePtr->inputEncodingFlags, &gs.state, tmp, 1 + TCL_UTF_MAX, &rawRead, NULL, NULL); bufPtr->nextRemoved += rawRead; gs.rawRead -= rawRead; gs.bytesWrote--; gs.charsWrote--; memmove(dst, dst + 1, (size_t) (dstEnd - dst)); dstEnd--; } } for (eol = dst; eol < dstEnd; eol++) { if (*eol == '\r') { eol++; if (eol == dstEnd) { /* * If buffer ended on \r, peek ahead to see if a \n is * available. */ int offset; offset = eol - objPtr->bytes; dst = dstEnd; PeekAhead(chanPtr, &dstEnd, &gs); eol = objPtr->bytes + offset; if (eol >= dstEnd) { eol--; statePtr->flags |= INPUT_SAW_CR; goto gotEOL; } } if (*eol == '\n') { skip++; } eol--; goto gotEOL; } else if (*eol == '\n') { goto gotEOL; } } } if (eof != NULL) { /* * EOF character was seen. On EOF, leave current file position * pointing at the EOF character, but don't store the EOF |
︙ | ︙ | |||
3747 3748 3749 3750 3751 3752 3753 | */ Tcl_SetObjLength(objPtr, oldLength); CommonGetsCleanup(chanPtr, encoding); copiedTotal = -1; goto done; } | | | | | | | | | 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 | */ Tcl_SetObjLength(objPtr, oldLength); CommonGetsCleanup(chanPtr, encoding); copiedTotal = -1; goto done; } goto gotEOL; } dst = dstEnd; } /* * Found EOL or EOF, but the output buffer may now contain too many UTF-8 * characters. We need to know how many raw bytes correspond to the * number of UTF-8 characters we want, plus how many raw bytes correspond * to the character(s) making up EOL (if any), so we can remove the * correct number of bytes from the channel buffer. */ gotEOL: bufPtr = gs.bufPtr; statePtr->inputEncodingState = gs.state; Tcl_ExternalToUtf(NULL, gs.encoding, bufPtr->buf + bufPtr->nextRemoved, gs.rawRead, statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, eol - dst + skip + TCL_UTF_MAX, &gs.rawRead, NULL, &gs.charsWrote); |
︙ | ︙ | |||
3782 3783 3784 3785 3786 3787 3788 | CommonGetsCleanup(chanPtr, encoding); statePtr->flags &= ~CHANNEL_BLOCKED; copiedTotal = gs.totalChars + gs.charsWrote - skip; goto done; /* * Couldn't get a complete line. This only happens if we get a error | | | | | | | | | < | | > | | | | | | | | | | | | | | 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 | CommonGetsCleanup(chanPtr, encoding); statePtr->flags &= ~CHANNEL_BLOCKED; copiedTotal = gs.totalChars + gs.charsWrote - skip; goto done; /* * Couldn't get a complete line. This only happens if we get a error * reading from the channel or we are non-blocking and there wasn't an EOL * or EOF in the data available. */ restore: bufPtr = statePtr->inQueueHead; bufPtr->nextRemoved = oldRemoved; for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { bufPtr->nextRemoved = BUFFER_PADDING; } CommonGetsCleanup(chanPtr, encoding); statePtr->inputEncodingState = oldState; statePtr->inputEncodingFlags = oldFlags; Tcl_SetObjLength(objPtr, oldLength); /* * We didn't get a complete line so we need to indicate to UpdateInterest * that the gets blocked. It will wait for more data instead of firing a * timer, avoiding a busy wait. This is where we are assuming that the * next operation is a gets. No more file events will be delivered on * this channel until new data arrives or some operation is performed on * the channel (e.g. gets, read, fconfigure) that changes the blocking * state. Note that this means a file event will not be delivered even * though a read would be able to consume the buffered data. */ statePtr->flags |= CHANNEL_NEED_MORE_DATA; copiedTotal = -1; /* * Update the notifier state so we don't block while there is still data * in the buffers. */ done: UpdateInterest(chanPtr); return copiedTotal; } /* *--------------------------------------------------------------------------- * * FilterInputBytes -- * * Helper function for Tcl_GetsObj. Produces UTF-8 characters from raw * bytes read from the channel. * * Consumes available bytes from channel buffers. When channel buffers * are exhausted, reads more bytes from channel device into a new channel * buffer. It is the caller's responsibility to free the channel buffers * that have been exhausted. * * Results: * The return value is -1 if there was an error reading from the channel, * 0 otherwise. * * Side effects: * Status object keeps track of how much data from channel buffers has * been consumed and where UTF-8 bytes should be stored. * *--------------------------------------------------------------------------- */ static int FilterInputBytes(chanPtr, gsPtr) Channel *chanPtr; /* Channel to read. */ GetsState *gsPtr; /* Current state of gets operation. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ ChannelBuffer *bufPtr; char *raw, *rawStart, *rawEnd; char *dst; int offset, toRead, dstNeeded, spaceLeft, result, rawLen, length; Tcl_Obj *objPtr; #define ENCODING_LINESIZE 20 /* Lower bound on how many bytes to convert at * a time. Since we don't know a priori how * many bytes of storage this many source * bytes will use, we actually need at least * ENCODING_LINESIZE * TCL_MAX_UTF bytes of * room. */ objPtr = gsPtr->objPtr; /* |
︙ | ︙ | |||
3883 3884 3885 3886 3887 3888 3889 | bufPtr = bufPtr->nextPtr; } } gsPtr->totalChars += gsPtr->charsWrote; if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) { /* | | | | | | 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 | bufPtr = bufPtr->nextPtr; } } gsPtr->totalChars += gsPtr->charsWrote; if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) { /* * All channel buffers were exhausted and the caller still hasn't seen * EOL. Need to read more bytes from the channel device. Side effect * is to allocate another channel buffer. */ read: if (statePtr->flags & CHANNEL_BLOCKED) { if (statePtr->flags & CHANNEL_NONBLOCKING) { gsPtr->charsWrote = 0; gsPtr->rawRead = 0; return -1; } statePtr->flags &= ~CHANNEL_BLOCKED; |
︙ | ︙ | |||
3952 3953 3954 3955 3956 3957 3958 | */ statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; if (result == TCL_CONVERT_MULTIBYTE) { /* * The last few bytes in this channel buffer were the start of a | | | | 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 | */ statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; if (result == TCL_CONVERT_MULTIBYTE) { /* * The last few bytes in this channel buffer were the start of a * multibyte sequence. If this buffer was full, then move them to the * next buffer so the bytes will be contiguous. */ ChannelBuffer *nextPtr; int extra; nextPtr = bufPtr->nextPtr; if (bufPtr->nextAdded < bufPtr->bufLength) { |
︙ | ︙ | |||
3976 3977 3978 3979 3980 3981 3982 | * There was a partial character followed by EOF on the * device. Fall through, returning that nothing was found. */ bufPtr->nextRemoved = bufPtr->nextAdded; } else { /* | | | | 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 | * There was a partial character followed by EOF on the * device. Fall through, returning that nothing was found. */ bufPtr->nextRemoved = bufPtr->nextAdded; } else { /* * There are no more cached raw bytes left. See if we can get * some more. */ goto read; } } else { if (nextPtr == NULL) { nextPtr = AllocChannelBuffer(statePtr->bufSize); |
︙ | ︙ | |||
4005 4006 4007 4008 4009 4010 4011 | } /* *--------------------------------------------------------------------------- * * PeekAhead -- * | | | | | | | | | | | 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 | } /* *--------------------------------------------------------------------------- * * PeekAhead -- * * Helper function used by Tcl_GetsObj(). Called when we've seen a \r at * the end of the UTF-8 string and want to look ahead one character to * see if it is a \n. * * Results: * *gsPtr->dstPtr is filled with a pointer to the start of the range of * UTF-8 characters that were found by peeking and *dstEndPtr is filled * with a pointer to the bytes just after the end of the range. * * Side effects: * If no more raw bytes were available in one of the channel buffers, * tries to perform a non-blocking read to get more bytes from the * channel device. * *--------------------------------------------------------------------------- */ static void PeekAhead(chanPtr, dstEndPtr, gsPtr) Channel *chanPtr; /* The channel to read. */ char **dstEndPtr; /* Filled with pointer to end of new range of * UTF-8 characters. */ GetsState *gsPtr; /* Current state of gets operation. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ ChannelBuffer *bufPtr; Tcl_DriverBlockModeProc *blockModeProc; int bytesLeft; bufPtr = gsPtr->bufPtr; /* * If there's any more raw input that's still buffered, we'll peek into * that. Otherwise, only get more data from the channel driver if it looks * like there might actually be more data. The assumption is that if the * channel buffer is filled right up to the end, then there might be more * data to read. */ blockModeProc = NULL; if (bufPtr->nextPtr == NULL) { bytesLeft = bufPtr->nextAdded - (bufPtr->nextRemoved + gsPtr->rawRead); if (bytesLeft == 0) { if (bufPtr->nextAdded < bufPtr->bufLength) { |
︙ | ︙ | |||
4076 4077 4078 4079 4080 4081 4082 | *dstEndPtr = *gsPtr->dstPtr + gsPtr->bytesWrote; } if (blockModeProc != NULL) { StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING); } return; | | | | | 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 | *dstEndPtr = *gsPtr->dstPtr + gsPtr->bytesWrote; } if (blockModeProc != NULL) { StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING); } return; cleanup: bufPtr->nextRemoved += gsPtr->rawRead; gsPtr->rawRead = 0; gsPtr->totalChars += gsPtr->charsWrote; gsPtr->bytesWrote = 0; gsPtr->charsWrote = 0; } /* *--------------------------------------------------------------------------- * * CommonGetsCleanup -- * * Helper function for Tcl_GetsObj() to restore the channel after a * "gets" operation. * * Results: * None. * * Side effects: * Encoding may be freed. * |
︙ | ︙ | |||
4155 4156 4157 4158 4159 4160 4161 | } /* *---------------------------------------------------------------------- * * Tcl_Read -- * | | | | | | | | | | | | | | | | | | | | | > | | | | < | | > > | | | > > | | > > | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_Read -- * * Reads a given number of bytes from a channel. EOL and EOF translation * is done on the bytes being read, so the number of bytes consumed from * the channel may not be equal to the number of bytes stored in the * destination buffer. * * No encoding conversions are applied to the bytes being read. * * Results: * The number of bytes read, or -1 on error. Use Tcl_GetErrno() to * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. * *---------------------------------------------------------------------- */ int Tcl_Read(chan, dst, bytesToRead) Tcl_Channel chan; /* The channel from which to read. */ char *dst; /* Where to store input read. */ int bytesToRead; /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ /* * This operation should occur at the top of a channel stack. */ chanPtr = statePtr->topChanPtr; if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { return -1; } return DoRead(chanPtr, dst, bytesToRead); } /* *---------------------------------------------------------------------- * * Tcl_ReadRaw -- * * Reads a given number of bytes from a channel. EOL and EOF translation * is done on the bytes being read, so the number of bytes consumed from * the channel may not be equal to the number of bytes stored in the * destination buffer. * * No encoding conversions are applied to the bytes being read. * * Results: * The number of bytes read, or -1 on error. Use Tcl_GetErrno() to * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. * *---------------------------------------------------------------------- */ int Tcl_ReadRaw(chan, bufPtr, bytesToRead) Tcl_Channel chan; /* The channel from which to read. */ char *bufPtr; /* Where to store input read. */ int bytesToRead; /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ int nread, result; int copied, copiedNow; /* * The check below does too much because it will reject a call to this * function with a channel which is part of an 'fcopy'. But we have to * allow this here or else the chaining in the transformation drivers will * fail with 'file busy' error instead of retrieving and transforming the * data to copy. * * We let the check procedure now believe that there is no fcopy in * progress. A better solution than this might be an additional flag * argument to switch off specific checks. */ if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) { return -1; } /* * Check for information in the push-back buffers. If there is some, use * it. Go to the driver only if there is none (anymore) and the caller * requests more bytes. */ for (copied = 0; copied < bytesToRead; copied += copiedNow) { copiedNow = CopyBuffer(chanPtr, bufPtr + copied, bytesToRead - copied); if (copiedNow == 0) { if (statePtr->flags & CHANNEL_EOF) { goto done; } if (statePtr->flags & CHANNEL_BLOCKED) { if (statePtr->flags & CHANNEL_NONBLOCKING) { goto done; } statePtr->flags &= (~(CHANNEL_BLOCKED)); } #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING /* * [SF Tcl Bug 943274]. Better emulation of non-blocking channels * for channels without BlockModeProc, by keeping track of true * fileevents generated by the OS == Data waiting and reading if * and only if we are sure to have data. */ if ((statePtr->flags & CHANNEL_NONBLOCKING) && (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) && !(statePtr->flags & CHANNEL_HAS_MORE_DATA)) { /* * We bypass the driver; it would block as no data is * available. */ nread = -1; result = EWOULDBLOCK; } else { #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ /* * Now go to the driver to get as much as is possible to fill * the remaining request. Do all the error handling by * ourselves. The code was stolen from 'GetInput' and * slightly adapted (different return value here). * * The case of 'bytesToRead == 0' at this point cannot happen. */ nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData, bufPtr + copied, bytesToRead - copied, &result); #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ if (nread > 0) { /* * If we get a short read, signal up that we may be * BLOCKED. We should avoid calling the driver because * on some platforms we will block in the low level * reading code even though the channel is set into * nonblocking mode. */ if (nread < (bytesToRead - copied)) { statePtr->flags |= CHANNEL_BLOCKED; } #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING if (nread <= (bytesToRead - copied)) { /* * [SF Tcl Bug 943274] We have read the available data, * clear flag. */ statePtr->flags &= ~CHANNEL_HAS_MORE_DATA; } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ } else if (nread == 0) { statePtr->flags |= CHANNEL_EOF; statePtr->inputEncodingFlags |= TCL_ENCODING_END; } else if (nread < 0) { if ((result == EWOULDBLOCK) || (result == EAGAIN)) { if (copied > 0) { /* * Information that was copied earlier has precedence * over EAGAIN/WOULDBLOCK handling. */ return copied; } statePtr->flags |= CHANNEL_BLOCKED; result = EAGAIN; } Tcl_SetErrno(result); return -1; } return copied + nread; } } done: return copied; } /* *--------------------------------------------------------------------------- * * Tcl_ReadChars -- * * Reads from the channel until the requested number of characters have * been seen, EOF is seen, or the channel would block. EOL and EOF * translation is done. If reading binary data, the raw bytes are * wrapped in a Tcl byte array object. Otherwise, the raw bytes are * converted to UTF-8 using the channel's current encoding and stored in * a Tcl string object. * * Results: * The number of characters read, or -1 on error. Use Tcl_GetErrno() to * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. * *--------------------------------------------------------------------------- */ int Tcl_ReadChars(chan, objPtr, toRead, appendFlag) Tcl_Channel chan; /* The channel to read. */ Tcl_Obj *objPtr; /* Input data is stored in this object. */ int toRead; /* Maximum number of characters to store, or * -1 to read all available data (up to EOF or * when channel blocks). */ int appendFlag; /* If non-zero, data read from the channel * will be appended to the object. Otherwise, * the data will replace the existing contents * of the object. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ |
︙ | ︙ | |||
4409 4410 4411 4412 4413 4414 4415 | return DoReadChars(chanPtr, objPtr, toRead, appendFlag); } /* *--------------------------------------------------------------------------- * * DoReadChars -- * | | | | | | | | | | | | | 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 | return DoReadChars(chanPtr, objPtr, toRead, appendFlag); } /* *--------------------------------------------------------------------------- * * DoReadChars -- * * Reads from the channel until the requested number of characters have * been seen, EOF is seen, or the channel would block. EOL and EOF * translation is done. If reading binary data, the raw bytes are * wrapped in a Tcl byte array object. Otherwise, the raw bytes are * converted to UTF-8 using the channel's current encoding and stored in * a Tcl string object. * * Results: * The number of characters read, or -1 on error. Use Tcl_GetErrno() to * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. * *--------------------------------------------------------------------------- */ static int DoReadChars(chanPtr, objPtr, toRead, appendFlag) Channel *chanPtr; /* The channel to read. */ Tcl_Obj *objPtr; /* Input data is stored in this object. */ int toRead; /* Maximum number of characters to store, or * -1 to read all available data (up to EOF or * when channel blocks). */ int appendFlag; /* If non-zero, data read from the channel * will be appended to the object. Otherwise, * the data will replace the existing contents * of the object. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ ChannelBuffer *bufPtr; |
︙ | ︙ | |||
4457 4458 4459 4460 4461 4462 4463 | factor = UTF_EXPANSION_FACTOR; if (appendFlag == 0) { if (encoding == NULL) { Tcl_SetByteArrayLength(objPtr, 0); } else { Tcl_SetObjLength(objPtr, 0); | > | | | | | 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 | factor = UTF_EXPANSION_FACTOR; if (appendFlag == 0) { if (encoding == NULL) { Tcl_SetByteArrayLength(objPtr, 0); } else { Tcl_SetObjLength(objPtr, 0); /* * We're going to access objPtr->bytes directly, so we must ensure * that this is actually a string object (otherwise it might have * been pure Unicode). */ Tcl_GetString(objPtr); } offset = 0; } else { if (encoding == NULL) { |
︙ | ︙ | |||
4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 | RecycleBuffer(statePtr, bufPtr, 0); statePtr->inQueueHead = nextPtr; if (nextPtr == NULL) { statePtr->inQueueTail = NULL; } } } if (copiedNow < 0) { if (statePtr->flags & CHANNEL_EOF) { break; } if (statePtr->flags & CHANNEL_BLOCKED) { if (statePtr->flags & CHANNEL_NONBLOCKING) { break; | > | 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 | RecycleBuffer(statePtr, bufPtr, 0); statePtr->inQueueHead = nextPtr; if (nextPtr == NULL) { statePtr->inQueueTail = NULL; } } } if (copiedNow < 0) { if (statePtr->flags & CHANNEL_EOF) { break; } if (statePtr->flags & CHANNEL_BLOCKED) { if (statePtr->flags & CHANNEL_NONBLOCKING) { break; |
︙ | ︙ | |||
4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 | goto done; } } else { copied += copiedNow; toRead -= copiedNow; } } statePtr->flags &= ~CHANNEL_BLOCKED; if (encoding == NULL) { Tcl_SetByteArrayLength(objPtr, offset); } else { Tcl_SetObjLength(objPtr, offset); } | > < | | > | | | | | | < | | | | | | | | | < | | | | | | | | | | | | | 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 | goto done; } } else { copied += copiedNow; toRead -= copiedNow; } } statePtr->flags &= ~CHANNEL_BLOCKED; if (encoding == NULL) { Tcl_SetByteArrayLength(objPtr, offset); } else { Tcl_SetObjLength(objPtr, offset); } /* * Update the notifier state so we don't block while there is still data * in the buffers. */ done: UpdateInterest(chanPtr); return copied; } /* *--------------------------------------------------------------------------- * * ReadBytes -- * * Reads from the channel until the requested number of bytes have been * seen, EOF is seen, or the channel would block. Bytes from the channel * are stored in objPtr as a ByteArray object. EOL and EOF translation * are done. * * 'bytesToRead' can safely be a very large number because space is only * allocated to hold data read from the channel as needed. * * Results: * The return value is the number of bytes appended to the object and * *offsetPtr is filled with the total number of bytes in the object * (greater than the return value if there were already bytes in the * object). * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int ReadBytes(statePtr, objPtr, bytesToRead, offsetPtr) ChannelState *statePtr; /* State of the channel to read. */ Tcl_Obj *objPtr; /* Input data is appended to this ByteArray * object. Its length is how much space has * been allocated to hold data, not how many * bytes of data have been stored in the * object. */ int bytesToRead; /* Maximum number of bytes to store, or < 0 to * get all available bytes. Bytes are obtained * from the first buffer in the queue - even * if this number is larger than the number of * bytes available in the first buffer, only * the bytes from the first buffer are * returned. */ int *offsetPtr; /* On input, contains how many bytes of objPtr * have been used to hold data. On output, * filled with how many bytes are now being * used. */ { int toRead, srcLen, offset, length, srcRead, dstWrote; ChannelBuffer *bufPtr; char *src, *dst; offset = *offsetPtr; bufPtr = statePtr->inQueueHead; src = bufPtr->buf + bufPtr->nextRemoved; srcLen = bufPtr->nextAdded - bufPtr->nextRemoved; toRead = bytesToRead; if ((unsigned) toRead > (unsigned) srcLen) { toRead = srcLen; } dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length); if (toRead > length - offset - 1) { /* * Double the existing size of the object or make enough room to hold * all the characters we may get from the source buffer, whichever is * larger. */ length = offset * 2; if (offset < toRead) { length = offset + toRead + 1; } dst = (char *) Tcl_SetByteArrayLength(objPtr, length); |
︙ | ︙ | |||
4647 4648 4649 4650 4651 4652 4653 | } /* *--------------------------------------------------------------------------- * * ReadChars -- * | | | | | | | < | | | < | | | | | | | | | | | < | | | | | | | 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 | } /* *--------------------------------------------------------------------------- * * ReadChars -- * * Reads from the channel until the requested number of UTF-8 characters * have been seen, EOF is seen, or the channel would block. Raw bytes * from the channel are converted to UTF-8 and stored in objPtr. EOL and * EOF translation is done. * * 'charsToRead' can safely be a very large number because space is only * allocated to hold data read from the channel as needed. * * Results: * The return value is the number of characters appended to the object, * *offsetPtr is filled with the number of bytes that were appended, and * *factorPtr is filled with the expansion factor used to guess how many * bytes of UTF-8 to allocate to hold N source bytes. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) ChannelState *statePtr; /* State of channel to read. */ Tcl_Obj *objPtr; /* Input data is appended to this object. * objPtr->length is how much space has been * allocated to hold data, not how many bytes * of data have been stored in the object. */ int charsToRead; /* Maximum number of characters to store, or * -1 to get all available characters. * Characters are obtained from the first * buffer in the queue -- even if this number * is larger than the number of characters * available in the first buffer, only the * characters from the first buffer are * returned. */ int *offsetPtr; /* On input, contains how many bytes of objPtr * have been used to hold data. On output, * filled with how many bytes are now being * used. */ int *factorPtr; /* On input, contains a guess of how many * bytes need to be allocated to hold the * result of converting N source bytes to * UTF-8. On output, contains another guess * based on the data seen so far. */ { int toRead, factor, offset, spaceLeft, length, srcLen, dstNeeded; int srcRead, dstWrote, numChars, dstRead; ChannelBuffer *bufPtr; char *src, *dst; Tcl_EncodingState oldState; factor = *factorPtr; offset = *offsetPtr; bufPtr = statePtr->inQueueHead; src = bufPtr->buf + bufPtr->nextRemoved; srcLen = bufPtr->nextAdded - bufPtr->nextRemoved; toRead = charsToRead; if ((unsigned)toRead > (unsigned)srcLen) { toRead = srcLen; } /* * 'factor' is how much we guess that the bytes in the source buffer will * expand when converted to UTF-8 chars. This guess comes from analyzing * how many characters were produced by the previous pass. */ dstNeeded = toRead * factor / UTF_EXPANSION_FACTOR; spaceLeft = objPtr->length - offset - TCL_UTF_MAX - 1; if (dstNeeded > spaceLeft) { /* * Double the existing size of the object or make enough room to hold * all the characters we want from the source buffer, whichever is * larger. */ length = offset * 2; if (offset < dstNeeded) { length = offset + dstNeeded; } spaceLeft = length - offset; length += TCL_UTF_MAX + 1; Tcl_SetObjLength(objPtr, length); } if (toRead == srcLen) { /* * Want to convert the whole buffer in one pass. If we have enough * space, convert it using all available space in object rather than * using the factor. */ dstNeeded = spaceLeft; } dst = objPtr->bytes + offset; oldState = statePtr->inputEncodingState; |
︙ | ︙ | |||
4781 4782 4783 4784 4785 4786 4787 | } Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, dstNeeded + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); if (srcRead == 0) { /* | | | | | | | | < | | | | | | | | | 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 | } Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, dstNeeded + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); if (srcRead == 0) { /* * Not enough bytes in src buffer to make a complete char. Copy the * bytes to the next buffer to make a new contiguous string, then tell * the caller to fill the buffer with more bytes. */ ChannelBuffer *nextPtr; nextPtr = bufPtr->nextPtr; if (nextPtr == NULL) { if (srcLen > 0) { /* * There isn't enough data in the buffers to complete the next * character, so we need to wait for more data before the next * file event can be delivered. * * SF #478856. * * The exception to this is if the input buffer was completely * empty before we tried to convert its contents. Nothing in, * nothing out, and no incomplete character data. The * conversion before the current one was complete. */ statePtr->flags |= CHANNEL_NEED_MORE_DATA; } return -1; } nextPtr->nextRemoved -= srcLen; memcpy((VOID *) (nextPtr->buf + nextPtr->nextRemoved), (VOID *) src, (size_t) srcLen); RecycleBuffer(statePtr, bufPtr, 0); statePtr->inQueueHead = nextPtr; return ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr); } dstRead = dstWrote; if (TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead) != 0) { /* * Hit EOF char. How many bytes of src correspond to where the EOF was * located in dst? Run the conversion again with an output buffer just * big enough to hold the data so we can get the correct value for * srcRead. */ if (dstWrote == 0) { return -1; } statePtr->inputEncodingState = oldState; Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); } /* * The number of characters that we got may be less than the number that * we started with because "\r\n" sequences may have been turned into just * '\n' in dst. */ numChars -= (dstRead - dstWrote); if ((unsigned) numChars > (unsigned) toRead) { /* * Got too many chars. |
︙ | ︙ | |||
4875 4876 4877 4878 4879 4880 4881 | } /* *--------------------------------------------------------------------------- * * TranslateInputEOL -- * | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 | } /* *--------------------------------------------------------------------------- * * TranslateInputEOL -- * * Perform input EOL and EOF translation on the source buffer, leaving * the translated result in the destination buffer. * * Results: * The return value is 1 if the EOF character was found when copying * bytes to the destination buffer, 0 otherwise. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int TranslateInputEOL(statePtr, dstStart, srcStart, dstLenPtr, srcLenPtr) ChannelState *statePtr; /* Channel being read, for EOL translation and * EOF character. */ char *dstStart; /* Output buffer filled with chars by applying * appropriate EOL translation to source * characters. */ CONST char *srcStart; /* Source characters. */ int *dstLenPtr; /* On entry, the maximum length of output * buffer in bytes; must be <= *srcLenPtr. On * exit, the number of bytes actually used in * output buffer. */ int *srcLenPtr; /* On entry, the length of source buffer. On * exit, the number of bytes read from the * source buffer. */ { int dstLen, srcLen, inEofChar; CONST char *eof; dstLen = *dstLenPtr; eof = NULL; inEofChar = statePtr->inEofChar; if (inEofChar != '\0') { /* * Find EOF in translated buffer then compress out the EOL. The source * buffer may be much longer than the destination buffer - we only * want to return EOF if the EOF has been copied to the destination * buffer. */ CONST char *src, *srcMax; srcMax = srcStart + *srcLenPtr; for (src = srcStart; src < srcMax; src++) { if (*src == inEofChar) { eof = src; srcLen = src - srcStart; if (srcLen < dstLen) { dstLen = srcLen; } *srcLenPtr = srcLen; break; } } } switch (statePtr->inputTranslation) { case TCL_TRANSLATE_LF: if (dstStart != srcStart) { memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); } srcLen = dstLen; break; case TCL_TRANSLATE_CR: { char *dst, *dstEnd; if (dstStart != srcStart) { memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); } dstEnd = dstStart + dstLen; for (dst = dstStart; dst < dstEnd; dst++) { if (*dst == '\r') { *dst = '\n'; } } srcLen = dstLen; break; } case TCL_TRANSLATE_CRLF: { char *dst; CONST char *src, *srcEnd, *srcMax; dst = dstStart; src = srcStart; srcEnd = srcStart + dstLen; srcMax = srcStart + *srcLenPtr; for ( ; src < srcEnd; ) { if (*src == '\r') { src++; if (src >= srcMax) { statePtr->flags |= INPUT_NEED_NL; } else if (*src == '\n') { *dst++ = *src++; } else { *dst++ = '\r'; } } else { *dst++ = *src++; } } srcLen = src - srcStart; dstLen = dst - dstStart; break; } case TCL_TRANSLATE_AUTO: { char *dst; CONST char *src, *srcEnd, *srcMax; dst = dstStart; src = srcStart; srcEnd = srcStart + dstLen; srcMax = srcStart + *srcLenPtr; if ((statePtr->flags & INPUT_SAW_CR) && (src < srcMax)) { if (*src == '\n') { src++; } statePtr->flags &= ~INPUT_SAW_CR; } for ( ; src < srcEnd; ) { if (*src == '\r') { src++; if (src >= srcMax) { statePtr->flags |= INPUT_SAW_CR; } else if (*src == '\n') { if (srcEnd < srcMax) { srcEnd++; } src++; } *dst++ = '\n'; } else { *dst++ = *src++; } } srcLen = src - srcStart; dstLen = dst - dstStart; break; } default: return 0; } *dstLenPtr = dstLen; if ((eof != NULL) && (srcStart + srcLen >= eof)) { /* * EOF character was seen in EOL translated range. Leave current file * position pointing at the EOF character, but don't store the EOF * character in the output string. */ statePtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; statePtr->flags &= ~(INPUT_SAW_CR | INPUT_NEED_NL); return 1; } *srcLenPtr = srcLen; return 0; } /* *---------------------------------------------------------------------- * * Tcl_Ungets -- * * Causes the supplied string to be added to the input queue of the * channel, at either the head or tail of the queue. * * Results: * The number of bytes stored in the channel, or -1 on error. * * Side effects: * Adds input to the input queue of a channel. * *---------------------------------------------------------------------- */ int Tcl_Ungets(chan, str, len, atEnd) Tcl_Channel chan; /* The channel for which to add the input. */ CONST char *str; /* The input itself. */ int len; /* The length of the input. */ int atEnd; /* If non-zero, add at end of queue; otherwise * add at head of queue. */ { Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of actual channel. */ ChannelBuffer *bufPtr; /* Buffer to contain the data. */ int i, flags; chanPtr = (Channel *) chan; |
︙ | ︙ | |||
5093 5094 5095 5096 5097 5098 5099 | if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { len = -1; goto done; } statePtr->flags = flags; /* | | | | | < | 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 | if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { len = -1; goto done; } statePtr->flags = flags; /* * If we have encountered a sticky EOF, just punt without storing (sticky * EOF is set if we have seen the input eofChar, to prevent reading beyond * the eofChar). Otherwise, clear the EOF flags, and clear the BLOCKED * bit. We want to discover these conditions anew in each operation. */ if (statePtr->flags & CHANNEL_STICKY_EOF) { goto done; } statePtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_EOF)); |
︙ | ︙ | |||
5123 5124 5125 5126 5127 5128 5129 | statePtr->inQueueTail->nextPtr = bufPtr; statePtr->inQueueTail = bufPtr; } else { bufPtr->nextPtr = statePtr->inQueueHead; statePtr->inQueueHead = bufPtr; } | < | | > | 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 | statePtr->inQueueTail->nextPtr = bufPtr; statePtr->inQueueTail = bufPtr; } else { bufPtr->nextPtr = statePtr->inQueueHead; statePtr->inQueueHead = bufPtr; } /* * Update the notifier state so we don't block while there is still data * in the buffers. */ done: UpdateInterest(chanPtr); return len; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
5190 5191 5192 5193 5194 5195 5196 | } /* *---------------------------------------------------------------------- * * DiscardInputQueued -- * | | | | | | 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 | } /* *---------------------------------------------------------------------- * * DiscardInputQueued -- * * Discards any input read from the channel but not yet consumed by Tcl * reading commands. * * Results: * None. * * Side effects: * May discard input from the channel. If discardLastBuffer is zero, * leaves one buffer in place for back-filling. * *---------------------------------------------------------------------- */ static void DiscardInputQueued(statePtr, discardSavedBuffers) ChannelState *statePtr; /* Channel on which to discard the queued * input. */ int discardSavedBuffers; /* If non-zero, discard all buffers including * last one. */ { ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */ bufPtr = statePtr->inQueueHead; statePtr->inQueueHead = (ChannelBuffer *) NULL; |
︙ | ︙ | |||
5238 5239 5240 5241 5242 5243 5244 | } /* *--------------------------------------------------------------------------- * * GetInput -- * | | | | 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 | } /* *--------------------------------------------------------------------------- * * GetInput -- * * Reads input data from a device into a channel buffer. * * Results: * The return value is the Posix error code if an error occurred while * reading from the file, or 0 otherwise. * * Side effects: * Reads from the underlying device. * *--------------------------------------------------------------------------- */ |
︙ | ︙ | |||
5272 5273 5274 5275 5276 5277 5278 | */ if (CheckForDeadChannel(NULL, statePtr)) { return EINVAL; } /* | | | | | | | | | | | | | | > | | | | | | | | | | | 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 | */ if (CheckForDeadChannel(NULL, statePtr)) { return EINVAL; } /* * First check for more buffers in the pushback area of the topmost * channel in the stack and use them. They can be the result of a * transformation which went away without reading all the information * placed in the area when it was stacked. * * Two possibilities for the state: No buffers in it, or a single empty * buffer. In the latter case we can recycle it now. */ if (chanPtr->inQueueHead != (ChannelBuffer *) NULL) { if (statePtr->inQueueHead != (ChannelBuffer *) NULL) { RecycleBuffer(statePtr, statePtr->inQueueHead, 0); statePtr->inQueueHead = (ChannelBuffer *) NULL; } statePtr->inQueueHead = chanPtr->inQueueHead; statePtr->inQueueTail = chanPtr->inQueueTail; chanPtr->inQueueHead = (ChannelBuffer *) NULL; chanPtr->inQueueTail = (ChannelBuffer *) NULL; return 0; } /* * Nothing in the pushback area, fall back to the usual handling (driver, * etc.) */ /* * See if we can fill an existing buffer. If we can, read only as much as * will fit in it. Otherwise allocate a new buffer, add it to the input * queue and attempt to fill it to the max. */ bufPtr = statePtr->inQueueTail; if ((bufPtr != NULL) && (bufPtr->nextAdded < bufPtr->bufLength)) { toRead = bufPtr->bufLength - bufPtr->nextAdded; } else { bufPtr = statePtr->saveInBufPtr; statePtr->saveInBufPtr = NULL; /* * Check the actual buffersize against the requested * buffersize. Buffers which are smaller than requested are * squashed. This is done to honor dynamic changes of the buffersize * made by the user. */ if ((bufPtr != NULL) && (bufPtr->bufLength - BUFFER_PADDING < statePtr->bufSize)) { ckfree((char *) bufPtr); bufPtr = NULL; } if (bufPtr == NULL) { bufPtr = AllocChannelBuffer(statePtr->bufSize); } bufPtr->nextPtr = (ChannelBuffer *) NULL; /* * SF #427196: Use the actual size of the buffer to determine the * number of bytes to read from the channel and not the size for new * buffers. They can be different if the buffersize was changed * between reads. * * Note: This affects performance negatively if the buffersize was * extended but this small buffer is reused for all subsequent reads. * The system never uses buffers with the requested bigger size in * that case. An adjunct patch could try and delete all unused buffers * it encounters and which are smaller than the formally requested * buffersize. */ toRead = bufPtr->bufLength - bufPtr->nextAdded; if (statePtr->inQueueTail == NULL) { statePtr->inQueueHead = bufPtr; } else { |
︙ | ︙ | |||
5364 5365 5366 5367 5368 5369 5370 | if (statePtr->flags & CHANNEL_EOF) { return 0; } #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING /* | | | | | > > | | | | | | | 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 | if (statePtr->flags & CHANNEL_EOF) { return 0; } #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING /* * [SF Tcl Bug 943274]. Better emulation of non-blocking channels for * channels without BlockModeProc, by keeping track of true fileevents * generated by the OS == Data waiting and reading if and only if we are * sure to have data. */ if ((statePtr->flags & CHANNEL_NONBLOCKING) && (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) && !(statePtr->flags & CHANNEL_HAS_MORE_DATA)) { /* * Bypass the driver, it would block, as no data is available */ nread = -1; result = EWOULDBLOCK; } else { #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData, bufPtr->buf + bufPtr->nextAdded, toRead, &result); #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ if (nread > 0) { bufPtr->nextAdded += nread; /* * If we get a short read, signal up that we may be BLOCKED. We should * avoid calling the driver because on some platforms we will block in * the low level reading code even though the channel is set into * nonblocking mode. */ if (nread < toRead) { statePtr->flags |= CHANNEL_BLOCKED; } #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING if (nread <= toRead) { /* * [SF Tcl Bug 943274] We have read the available data, clear * flag. */ statePtr->flags &= ~CHANNEL_HAS_MORE_DATA; } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ } else if (nread == 0) { |
︙ | ︙ | |||
5431 5432 5433 5434 5435 5436 5437 | } /* *---------------------------------------------------------------------- * * Tcl_Seek -- * | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_Seek -- * * Implements seeking on Tcl Channels. This is a public function so that * other C facilities may be implemented on top of it. * * Results: * The new access point or -1 on error. If error, use Tcl_GetErrno() to * retrieve the POSIX error code for the error that occurred. * * Side effects: * May flush output on the channel. May discard queued input. * *---------------------------------------------------------------------- */ Tcl_WideInt Tcl_Seek(chan, offset, mode) Tcl_Channel chan; /* The channel on which to seek. */ Tcl_WideInt offset; /* Offset to seek to. */ int mode; /* Relative to which location to seek? */ { Channel *chanPtr = (Channel *) chan; /* The real IO channel. */ ChannelState *statePtr = chanPtr->state; /* state info for channel */ int inputBuffered, outputBuffered; /* # bytes held in buffers. */ int result; /* Of device driver operations. */ Tcl_WideInt curPos; /* Position on the device. */ int wasAsync; /* Was the channel nonblocking before the seek * operation? If so, must restore to * non-blocking mode after the seek. */ if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { return Tcl_LongAsWide(-1); } /* * Disallow seek on dead channels - channels that have been closed but not * yet been deallocated. Such channels can be found if the exit handler * for channel cleanup has run but the channel is still registered in an * interpreter. */ if (CheckForDeadChannel(NULL, statePtr)) { return Tcl_LongAsWide(-1); } /* |
︙ | ︙ | |||
5492 5493 5494 5495 5496 5497 5498 | if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { Tcl_SetErrno(EINVAL); return Tcl_LongAsWide(-1); } /* | | | | | | | | | | | | | | | | | | | | | 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 | if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { Tcl_SetErrno(EINVAL); return Tcl_LongAsWide(-1); } /* * Compute how much input and output is buffered. If both input and output * is buffered, cannot compute the current position. */ inputBuffered = Tcl_InputBuffered(chan); outputBuffered = Tcl_OutputBuffered(chan); if ((inputBuffered != 0) && (outputBuffered != 0)) { Tcl_SetErrno(EFAULT); return Tcl_LongAsWide(-1); } /* * If we are seeking relative to the current position, compute the * corrected offset taking into account the amount of unread input. */ if (mode == SEEK_CUR) { offset -= inputBuffered; } /* * Discard any queued input - this input should not be read after the * seek. */ DiscardInputQueued(statePtr, 0); /* * Reset EOF and BLOCKED flags. We invalidate them by moving the access * point. Also clear CR related flags. */ statePtr->flags &= ~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR); /* * If the channel is in asynchronous output mode, switch it back to * synchronous mode and cancel any async flush that may be scheduled. * After the flush, the channel will be put back into asynchronous output * mode. */ wasAsync = 0; if (statePtr->flags & CHANNEL_NONBLOCKING) { wasAsync = 1; result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING); if (result != 0) { return Tcl_LongAsWide(-1); } statePtr->flags &= (~(CHANNEL_NONBLOCKING)); if (statePtr->flags & BG_FLUSH_SCHEDULED) { statePtr->flags &= (~(BG_FLUSH_SCHEDULED)); } } /* * If there is data buffered in statePtr->curOutPtr then mark the channel * as ready to flush before invoking FlushChannel. */ if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) && (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) { statePtr->flags |= BUFFER_READY; } /* * If the flush fails we cannot recover the original position. In that * case the seek is not attempted because we do not know where the access * position is - instead we return the error. FlushChannel has already * called Tcl_SetErrno() to report the error upwards. If the flush * succeeds we do the seek also. */ if (FlushChannel(NULL, chanPtr, 0) != 0) { curPos = -1; } else { /* * Now seek to the new position in the channel as requested by the * caller. Note that we prefer the wideSeekProc if that is available * and non-NULL... */ if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) && chanPtr->typePtr->wideSeekProc != NULL) { curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData, offset, mode, &result); } else if (offset < Tcl_LongAsWide(LONG_MIN) || |
︙ | ︙ | |||
5598 5599 5600 5601 5602 5603 5604 | Tcl_SetErrno(result); } } /* * Restore to nonblocking mode if that was the previous behavior. * | | | | | | | | | 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 | Tcl_SetErrno(result); } } /* * Restore to nonblocking mode if that was the previous behavior. * * NOTE: Even if there was an async flush active we do not restore it now * because we already flushed all the queued output, above. */ if (wasAsync) { statePtr->flags |= CHANNEL_NONBLOCKING; result = StackSetBlockMode(chanPtr, TCL_MODE_NONBLOCKING); if (result != 0) { return Tcl_LongAsWide(-1); } } return curPos; } /* *---------------------------------------------------------------------- * * Tcl_Tell -- * * Returns the position of the next character to be read/written on this * channel. * * Results: * A nonnegative integer on success, -1 on failure. If failed, use * Tcl_GetErrno() to retrieve the POSIX error code for the error that * occurred. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
5649 5650 5651 5652 5653 5654 5655 | if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { return Tcl_LongAsWide(-1); } /* * Disallow tell on dead channels -- channels that have been closed but * not yet been deallocated. Such channels can be found if the exit | | | | 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 | if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { return Tcl_LongAsWide(-1); } /* * Disallow tell on dead channels -- channels that have been closed but * not yet been deallocated. Such channels can be found if the exit * handler for channel cleanup has run but the channel is still registered * in an interpreter. */ if (CheckForDeadChannel(NULL, statePtr)) { return Tcl_LongAsWide(-1); } /* |
︙ | ︙ | |||
5674 5675 5676 5677 5678 5679 5680 | if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { Tcl_SetErrno(EINVAL); return Tcl_LongAsWide(-1); } /* | | | | | | | 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 | if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { Tcl_SetErrno(EINVAL); return Tcl_LongAsWide(-1); } /* * Compute how much input and output is buffered. If both input and output * is buffered, cannot compute the current position. */ inputBuffered = Tcl_InputBuffered(chan); outputBuffered = Tcl_OutputBuffered(chan); if ((inputBuffered != 0) && (outputBuffered != 0)) { Tcl_SetErrno(EFAULT); return Tcl_LongAsWide(-1); } /* * Get the current position in the device and compute the position where * the next character will be read or written. Note that we prefer the * wideSeekProc if that is available and non-NULL... */ if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) && chanPtr->typePtr->wideSeekProc != NULL) { curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData, Tcl_LongAsWide(0), SEEK_CUR, &result); } else { |
︙ | ︙ | |||
5715 5716 5717 5718 5719 5720 5721 | } /* *--------------------------------------------------------------------------- * * Tcl_SeekOld, Tcl_TellOld -- * | | | | | 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 | } /* *--------------------------------------------------------------------------- * * Tcl_SeekOld, Tcl_TellOld -- * * Backward-compatability versions of the seek/tell interface that do not * support 64-bit offsets. This interface is not documented or expected * to be supported indefinitely. * * Results: * As for Tcl_Seek and Tcl_Tell respectively, except truncated to * whatever value will fit in an 'int'. * * Side effects: * As for Tcl_Seek and Tcl_Tell respectively. |
︙ | ︙ | |||
5755 5756 5757 5758 5759 5760 5761 5762 5763 | wResult = Tcl_Tell(chan); return (int)Tcl_WideAsLong(wResult); } /* *--------------------------------------------------------------------------- * * CheckChannelErrors -- * | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | 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 | wResult = Tcl_Tell(chan); return (int)Tcl_WideAsLong(wResult); } /* *--------------------------------------------------------------------------- * * Tcl_TruncateChannel -- * * Truncate a channel to the given length. * * Results: * TCL_OK on success, TCL_ERROR if the operation failed (e.g. is not * supported by the type of channel, or the underlying OS operation * failed in some way). * * Side effects: * Seeks the channel to the current location. Sets errno on OS error. * *--------------------------------------------------------------------------- */ int Tcl_TruncateChannel(chan, length) Tcl_Channel chan; Tcl_WideInt length; { Channel *chanPtr = (Channel *) chan; Tcl_DriverTruncateProc *truncateProc = Tcl_ChannelTruncateProc(chanPtr->typePtr); int result; if (truncateProc == NULL) { /* * Feature not supported and it's not emulatable. Pretend it's * returned an EINVAL, a very generic error! */ Tcl_SetErrno(EINVAL); return TCL_ERROR; } if (!(chanPtr->state->flags & TCL_WRITABLE)) { /* * We require that the file was opened of writing. Do that check now * so that we only flush if we think we're going to succeed. */ Tcl_SetErrno(EINVAL); return TCL_ERROR; } /* * Seek first to force a total flush of all pending buffers and ditch any * pre-read input data. */ if (Tcl_Seek(chan, 0, SEEK_CUR) == Tcl_LongAsWide(-1)) { return TCL_ERROR; } /* * We're all flushed to disk now and we also don't have any unfortunate * input baggage around either; can truncate with impunity. */ result = truncateProc(chanPtr->instanceData, length); if (result != 0) { Tcl_SetErrno(result); return TCL_ERROR; } return TCL_OK; } /* *--------------------------------------------------------------------------- * * CheckChannelErrors -- * * See if the channel is in an ready state and can perform the desired * operation. * * Results: * The return value is 0 if the channel is OK, otherwise the return value * is -1 and errno is set to indicate the error. * * Side effects: * May clear the EOF and/or BLOCKED bits if reading from channel. * *--------------------------------------------------------------------------- */ |
︙ | ︙ | |||
5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 | /* * Check for unreported error. */ if (statePtr->unreportedError != 0) { Tcl_SetErrno(statePtr->unreportedError); statePtr->unreportedError = 0; return -1; } /* | > > > > > > > > > > | | | 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 | /* * Check for unreported error. */ if (statePtr->unreportedError != 0) { Tcl_SetErrno(statePtr->unreportedError); statePtr->unreportedError = 0; /* TIP #219, Tcl Channel Reflection API. * Move a defered error message back into the channel bypass. */ if (statePtr->chanMsg != NULL) { Tcl_DecrRefCount (statePtr->chanMsg); } statePtr->chanMsg = statePtr->unreportedMsg; statePtr->unreportedMsg = NULL; return -1; } /* * Only the raw read and write operations are allowed during close in * order to drain data from stacked channels. */ if ((statePtr->flags & CHANNEL_CLOSED) && ((flags & CHANNEL_RAW_MODE) == 0)) { Tcl_SetErrno(EACCES); return -1; } |
︙ | ︙ | |||
5825 5826 5827 5828 5829 5830 5831 | if ((statePtr->csPtr != NULL) && ((flags & CHANNEL_RAW_MODE) == 0)) { Tcl_SetErrno(EBUSY); return -1; } if (direction == TCL_READABLE) { /* | | | | | | 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 | if ((statePtr->csPtr != NULL) && ((flags & CHANNEL_RAW_MODE) == 0)) { Tcl_SetErrno(EBUSY); return -1; } if (direction == TCL_READABLE) { /* * If we have not encountered a sticky EOF, clear the EOF bit (sticky * EOF is set if we have seen the input eofChar, to prevent reading * beyond the eofChar). Also, always clear the BLOCKED bit. We want to * discover these conditions anew in each operation. */ if ((statePtr->flags & CHANNEL_STICKY_EOF) == 0) { statePtr->flags &= ~CHANNEL_EOF; } statePtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA); } |
︙ | ︙ | |||
5899 5900 5901 5902 5903 5904 5905 | } /* *---------------------------------------------------------------------- * * Tcl_InputBuffered -- * | | | | | | 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 | } /* *---------------------------------------------------------------------- * * Tcl_InputBuffered -- * * Returns the number of bytes of input currently buffered in the common * internal buffer of a channel. * * Results: * The number of input bytes buffered, or zero if the channel is not open * for reading. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
5945 5946 5947 5948 5949 5950 5951 | } /* *---------------------------------------------------------------------- * * Tcl_OutputBuffered -- * | | | | | | 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 | } /* *---------------------------------------------------------------------- * * Tcl_OutputBuffered -- * * Returns the number of bytes of output currently buffered in the common * internal buffer of a channel. * * Results: * The number of output bytes buffered, or zero if the channel is not open * for writing. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
5990 5991 5992 5993 5994 5995 5996 | * * Tcl_ChannelBuffered -- * * Returns the number of bytes of input currently buffered in the * internal buffer (push back area) of a channel. * * Results: | | | | 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 | * * Tcl_ChannelBuffered -- * * Returns the number of bytes of input currently buffered in the * internal buffer (push back area) of a channel. * * Results: * The number of input bytes buffered, or zero if the channel is not open * for reading. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
6022 6023 6024 6025 6026 6027 6028 | } /* *---------------------------------------------------------------------- * * Tcl_SetChannelBufferSize -- * | | | | | | | | | | 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 | } /* *---------------------------------------------------------------------- * * Tcl_SetChannelBufferSize -- * * Sets the size of buffers to allocate to store input or output in the * channel. The size must be between 1 byte and 1 MByte. * * Results: * None. * * Side effects: * Sets the size of buffers subsequently allocated for this channel. * *---------------------------------------------------------------------- */ void Tcl_SetChannelBufferSize(chan, sz) Tcl_Channel chan; /* The channel whose buffer size to * set. */ int sz; /* The size to set. */ { ChannelState *statePtr; /* State of real channel structure. */ /* * If the buffer size is smaller than 1 byte or larger than one MByte, do * not accept the requested size and leave the current buffer size. */ if (sz < 1) { return; } if (sz > (1024 * 1024)) { return; } statePtr = ((Channel *) chan)->state; statePtr->bufSize = sz; if (statePtr->outputStage != NULL) { ckfree((char *) statePtr->outputStage); statePtr->outputStage = NULL; } if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { statePtr->outputStage = (char *) ckalloc((unsigned) (statePtr->bufSize + 2)); } } /* *---------------------------------------------------------------------- * * Tcl_GetChannelBufferSize -- |
︙ | ︙ | |||
6099 6100 6101 6102 6103 6104 6105 | } /* *---------------------------------------------------------------------- * * Tcl_BadChannelOption -- * | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 | } /* *---------------------------------------------------------------------- * * Tcl_BadChannelOption -- * * This procedure generates a "bad option" error message in an (optional) * interpreter. It is used by channel drivers when a invalid Set/Get * option is requested. Its purpose is to concatenate the generic options * list to the specific ones and factorize the generic options error * message string. * * Results: * TCL_ERROR. * * Side effects: * An error message is generated in interp's result object to indicate * that a command was invoked with the a bad option. The message has the * form: * bad option "blah": should be one of * <...generic options...>+<...specific options...> * "blah" is the optionName argument and "<specific options>" is a space * separated list of specific option words. The function takes good care * of inserting minus signs before each option, commas after, and an "or" * before the last option. * *---------------------------------------------------------------------- */ int Tcl_BadChannelOption(interp, optionName, optionList) Tcl_Interp *interp; /* Current interpreter (can be NULL).*/ CONST char *optionName; /* 'bad option' name */ CONST char *optionList; /* Specific options list to append to * the standard generic options. Can * be NULL for generic options * only. */ { if (interp != NULL) { CONST char *genericopt = "blocking buffering buffersize encoding eofchar translation"; CONST char **argv; int argc, i; Tcl_DString ds; Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, genericopt, -1); if (optionList && (*optionList)) { Tcl_DStringAppend(&ds, " ", 1); Tcl_DStringAppend(&ds, optionList, -1); } if (Tcl_SplitList(interp, Tcl_DStringValue(&ds), &argc, &argv) != TCL_OK) { Tcl_Panic("malformed option list in channel driver"); } Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad option \"", optionName, "\": should be one of ", (char *) NULL); argc--; for (i = 0; i < argc; i++) { Tcl_AppendResult(interp, "-", argv[i], ", ", (char *) NULL); } Tcl_AppendResult(interp, "or -", argv[i], (char *) NULL); Tcl_DStringFree(&ds); ckfree((char *) argv); } Tcl_SetErrno(EINVAL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Tcl_GetChannelOption -- * * Gets a mode associated with an IO channel. If the optionName arg is * non NULL, retrieves the value of that option. If the optionName arg is * NULL, retrieves a list of alternating option names and values for the * given channel. * * Results: * A standard Tcl result. Also sets the supplied DString to the string * value of the option(s) returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
6199 6200 6201 6202 6203 6204 6205 | Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ int flags; /* * Disallow options on dead channels -- channels that have been closed but * not yet been deallocated. Such channels can be found if the exit | | | | 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 | Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ int flags; /* * Disallow options on dead channels -- channels that have been closed but * not yet been deallocated. Such channels can be found if the exit * handler for channel cleanup has run but the channel is still registered * in an interpreter. */ if (CheckForDeadChannel(interp, statePtr)) { return TCL_ERROR; } /* |
︙ | ︙ | |||
6228 6229 6230 6231 6232 6233 6234 | flags = statePtr->csPtr->writeFlags; } } else { flags = statePtr->flags; } /* | | | | 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 | flags = statePtr->csPtr->writeFlags; } } else { flags = statePtr->flags; } /* * If the optionName is NULL it means that we want a list of all options * and values. */ if (optionName == (char *) NULL) { len = 0; } else { len = strlen(optionName); } |
︙ | ︙ | |||
6383 6384 6385 6386 6387 6388 6389 | } if (len > 0) { return TCL_OK; } } if (chanPtr->typePtr->getOptionProc != (Tcl_DriverGetOptionProc *) NULL) { /* | | | | | | | 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 | } if (len > 0) { return TCL_OK; } } if (chanPtr->typePtr->getOptionProc != (Tcl_DriverGetOptionProc *) NULL) { /* * Let the driver specific handle additional options and result code * and message. */ return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData, interp, optionName, dsPtr); } else { /* * No driver specific options case. */ if (len == 0) { return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, NULL); } } /* *--------------------------------------------------------------------------- * * Tcl_SetChannelOption -- * * Sets an option on a channel. * * Results: * A standard Tcl result. On error, sets interp's result object if * interp is not NULL. * * Side effects: * May modify an option on a device. * *--------------------------------------------------------------------------- */ |
︙ | ︙ | |||
6446 6447 6448 6449 6450 6451 6452 | } return TCL_ERROR; } /* * Disallow options on dead channels -- channels that have been closed but * not yet been deallocated. Such channels can be found if the exit | | | | 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 | } return TCL_ERROR; } /* * Disallow options on dead channels -- channels that have been closed but * not yet been deallocated. Such channels can be found if the exit * handler for channel cleanup has run but the channel is still registered * in an interpreter. */ if (CheckForDeadChannel(NULL, statePtr)) { return TCL_ERROR; } /* |
︙ | ︙ | |||
6571 6572 6573 6574 6575 6576 6577 | } } if (argv != NULL) { ckfree((char *) argv); } /* | | | | | 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 | } } if (argv != NULL) { ckfree((char *) argv); } /* * [SF Tcl Bug 930851] Reset EOF and BLOCKED flags. Changing the * character which signals eof can transform a current eof condition * into a 'go ahead'. Ditto for blocked. */ statePtr->flags &= ~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED); return TCL_OK; } else if ((len > 1) && (optionName[1] == 't') && |
︙ | ︙ | |||
6613 6614 6615 6616 6617 6618 6619 | if (*readMode == '\0') { translation = statePtr->inputTranslation; } else if (strcmp(readMode, "auto") == 0) { translation = TCL_TRANSLATE_AUTO; } else if (strcmp(readMode, "binary") == 0) { translation = TCL_TRANSLATE_LF; statePtr->inEofChar = 0; | | | 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 | if (*readMode == '\0') { translation = statePtr->inputTranslation; } else if (strcmp(readMode, "auto") == 0) { translation = TCL_TRANSLATE_AUTO; } else if (strcmp(readMode, "binary") == 0) { translation = TCL_TRANSLATE_LF; statePtr->inEofChar = 0; Tcl_FreeEncoding(statePtr->encoding); statePtr->encoding = NULL; } else if (strcmp(readMode, "lf") == 0) { translation = TCL_TRANSLATE_LF; } else if (strcmp(readMode, "cr") == 0) { translation = TCL_TRANSLATE_CR; } else if (strcmp(readMode, "crlf") == 0) { translation = TCL_TRANSLATE_CRLF; |
︙ | ︙ | |||
6635 6636 6637 6638 6639 6640 6641 | " or platform", (char *) NULL); } ckfree((char *) argv); return TCL_ERROR; } /* | | | | | | | < | | | 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 | " or platform", (char *) NULL); } ckfree((char *) argv); return TCL_ERROR; } /* * Reset the EOL flags since we need to look at any buffered data * to see if the new translation mode allows us to complete the * line. */ if (translation != statePtr->inputTranslation) { statePtr->inputTranslation = translation; statePtr->flags &= ~(INPUT_SAW_CR); statePtr->flags &= ~(CHANNEL_NEED_MORE_DATA); UpdateInterest(chanPtr); } } if (writeMode) { if (*writeMode == '\0') { /* Do nothing. */ } else if (strcmp(writeMode, "auto") == 0) { /* * This is a hack to get TCP sockets to produce output in CRLF * mode if they are being set into AUTO mode. A better * solution for achieving this effect will be coded later. */ if (strcmp(Tcl_ChannelName(chanPtr->typePtr), "tcp") == 0) { statePtr->outputTranslation = TCL_TRANSLATE_CRLF; } else { statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; } } else if (strcmp(writeMode, "binary") == 0) { statePtr->outEofChar = 0; statePtr->outputTranslation = TCL_TRANSLATE_LF; Tcl_FreeEncoding(statePtr->encoding); statePtr->encoding = NULL; } else if (strcmp(writeMode, "lf") == 0) { statePtr->outputTranslation = TCL_TRANSLATE_LF; } else if (strcmp(writeMode, "cr") == 0) { statePtr->outputTranslation = TCL_TRANSLATE_CR; } else if (strcmp(writeMode, "crlf") == 0) { statePtr->outputTranslation = TCL_TRANSLATE_CRLF; } else if (strcmp(writeMode, "platform") == 0) { statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; } else { if (interp) { Tcl_AppendResult(interp, "bad value for -translation: ", "must be one of auto, binary, cr, lf, crlf,", " or platform", (char *) NULL); } ckfree((char *) argv); return TCL_ERROR; } } ckfree((char *) argv); return TCL_OK; } else if (chanPtr->typePtr->setOptionProc != NULL) { return (*chanPtr->typePtr->setOptionProc)(chanPtr->instanceData, interp, optionName, newValue); } else { return Tcl_BadChannelOption(interp, optionName, (char *) NULL); } |
︙ | ︙ | |||
6723 6724 6725 6726 6727 6728 6729 | */ if (statePtr->outputStage != NULL) { ckfree((char *) statePtr->outputStage); statePtr->outputStage = NULL; } if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { | | | | | | < | | | 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 | */ if (statePtr->outputStage != NULL) { ckfree((char *) statePtr->outputStage); statePtr->outputStage = NULL; } if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { statePtr->outputStage = (char *) ckalloc((unsigned) (statePtr->bufSize + 2)); } return TCL_OK; } /* *---------------------------------------------------------------------- * * CleanupChannelHandlers -- * * Removes channel handlers that refer to the supplied interpreter, so * that if the actual channel is not closed now, these handlers will not * run on subsequent events on the channel. This would be erroneous, * because the interpreter no longer has a reference to this channel. * * Results: * None. * * Side effects: * Removes channel handlers. * *---------------------------------------------------------------------- */ static void CleanupChannelHandlers(interp, chanPtr) Tcl_Interp *interp; Channel *chanPtr; { ChannelState *statePtr = chanPtr->state; /* state info for channel */ EventScriptRecord *sPtr, *prevPtr, *nextPtr; /* * Remove fileevent records on this channel that refer to the given * interpreter. */ for (sPtr = statePtr->scriptRecordPtr, prevPtr = (EventScriptRecord *) NULL; sPtr != (EventScriptRecord *) NULL; sPtr = nextPtr) { nextPtr = sPtr->nextPtr; |
︙ | ︙ | |||
6790 6791 6792 6793 6794 6795 6796 | } /* *---------------------------------------------------------------------- * * Tcl_NotifyChannel -- * | | | | < | 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 7111 7112 7113 7114 7115 | } /* *---------------------------------------------------------------------- * * Tcl_NotifyChannel -- * * This procedure is called by a channel driver when a driver detects an * event on a channel. This procedure is responsible for actually * handling the event by invoking any channel handler callbacks. * * Results: * None. * * Side effects: * Whatever the channel handler callback procedure does. * |
︙ | ︙ | |||
6820 6821 6822 6823 6824 6825 6826 | ChannelHandler *chPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); NextChannelHandler nh; Channel *upChanPtr; Tcl_ChannelType *upTypePtr; #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING | | | | | | | | | | | | | | | | | | | | | | < | 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 | ChannelHandler *chPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); NextChannelHandler nh; Channel *upChanPtr; Tcl_ChannelType *upTypePtr; #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING /* * [SF Tcl Bug 943274] For a non-blocking channel without blockmodeproc we * keep track of actual input coming from the OS so that we can do a * credible imitation of non-blocking behaviour. */ if ((mask & TCL_READABLE) && (statePtr->flags & CHANNEL_NONBLOCKING) && (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) && !(statePtr->flags & CHANNEL_TIMER_FEV)) { statePtr->flags |= CHANNEL_HAS_MORE_DATA; } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ /* * In contrast to the other API functions this procedure walks towards the * top of a stack and not down from it. * * The channel calling this procedure is the one who generated the event, * and thus does not take part in handling it. IOW, its HandlerProc is not * called, instead we begin with the channel above it. * * This behaviour also allows the transformation channels to generate * their own events and pass them upward. */ while (mask && (chanPtr->upChanPtr != ((Channel *) NULL))) { Tcl_DriverHandlerProc *upHandlerProc; upChanPtr = chanPtr->upChanPtr; upTypePtr = upChanPtr->typePtr; upHandlerProc = Tcl_ChannelHandlerProc(upTypePtr); if (upHandlerProc != NULL) { mask = (*upHandlerProc) (upChanPtr->instanceData, mask); } /* * ELSE: Ignore transformations which are unable to handle the event * coming from below. Assume that they don't change the mask and pass * it on. */ chanPtr = upChanPtr; } channel = (Tcl_Channel) chanPtr; /* * Here we have either reached the top of the stack or the mask is empty. * We break out of the procedure if it is the latter. */ if (!mask) { return; } /* * We are now above the topmost channel in a stack and have events left. * Now call the channel handlers as usual. * * Preserve the channel struct in case the script closes it. */ Tcl_Preserve((ClientData) channel); Tcl_Preserve((ClientData) statePtr); /* * If we are flushing in the background, be sure to call FlushChannel for * writable events. Note that we have to discard the writable event so we * don't call any write handlers before the flush is complete. */ if ((statePtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) { FlushChannel(NULL, chanPtr, 1); mask &= ~TCL_WRITABLE; } |
︙ | ︙ | |||
6924 6925 6926 6927 6928 6929 6930 | chPtr = nh.nextHandlerPtr; } else { chPtr = chPtr->nextPtr; } } /* | | | | | | | | | 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 7268 7269 7270 7271 7272 7273 7274 7275 7276 7277 7278 7279 7280 7281 7282 7283 7284 7285 7286 | chPtr = nh.nextHandlerPtr; } else { chPtr = chPtr->nextPtr; } } /* * Update the notifier interest, since it may have changed after invoking * event handlers. Skip that if the channel was deleted in the call to the * channel handler. */ if (chanPtr->typePtr != NULL) { UpdateInterest(chanPtr); } Tcl_Release((ClientData) statePtr); Tcl_Release((ClientData) channel); tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr; } /* *---------------------------------------------------------------------- * * UpdateInterest -- * * Arrange for the notifier to call us back at appropriate times based on * the current state of the channel. * * Results: * None. * * Side effects: * May schedule a timer or driver handler. * *---------------------------------------------------------------------- */ static void UpdateInterest(chanPtr) Channel *chanPtr; /* Channel to update. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ int mask = statePtr->interestMask; /* * If there are flushed buffers waiting to be written, then we need to * watch for the channel to become writable. */ if (statePtr->flags & BG_FLUSH_SCHEDULED) { mask |= TCL_WRITABLE; } /* |
︙ | ︙ | |||
6989 6990 6991 6992 6993 6994 6995 | && (statePtr->inQueueHead->nextRemoved < statePtr->inQueueHead->nextAdded)) { mask &= ~TCL_READABLE; /* * Andreas Kupries, April 11, 2003 * | | | | < | | < | | | | | | | | | | | | | | | | | | | 7296 7297 7298 7299 7300 7301 7302 7303 7304 7305 7306 7307 7308 7309 7310 7311 7312 7313 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 | && (statePtr->inQueueHead->nextRemoved < statePtr->inQueueHead->nextAdded)) { mask &= ~TCL_READABLE; /* * Andreas Kupries, April 11, 2003 * * Some operating systems (Solaris 2.6 and higher (but not Solaris * 2.5, go figure)) generate READABLE and EXCEPTION events when * select()'ing [*] on a plain file, even if EOF was not yet * reached. This is a problem in the following situation: * * - An extension asks to get both READABLE and EXCEPTION events. * - It reads data into a buffer smaller than the buffer used by * Tcl itself. * - It does not process all events in the event queue, but only * one, at least in some situations. * * In that case we can get into a situation where * * - Tcl drops READABLE here, because it has data in its own * buffers waiting to be read by the extension. * - A READABLE event is syntesized via timer. * - The OS still reports the EXCEPTION condition on the file. * - And the extension gets the EXCPTION event first, and handles * this as EOF. * * End result ==> Premature end of reading from a file. * * The concrete example is 'Expect', and its [expect] command * (and at the C-level, deep in the bowels of Expect, * 'exp_get_next_event'. See marker 'SunOS' for commentary in * that function too). * * [*] As the Tcl notifier does. See also for marker 'SunOS' in * file 'exp_event.c' of Expect. * * Our solution here is to drop the interest in the EXCEPTION * events too. This compiles on all platforms, and also passes the * testsuite on all of them. */ mask &= ~TCL_EXCEPTION; if (!statePtr->timer) { statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc, (ClientData) chanPtr); } } } (chanPtr->typePtr->watchProc)(chanPtr->instanceData, mask); } /* *---------------------------------------------------------------------- * * ChannelTimerProc -- * * Timer handler scheduled by UpdateInterest to monitor the channel * buffers until they are empty. * * Results: * None. * * Side effects: * May invoke channel handlers. * |
︙ | ︙ | |||
7067 7068 7069 7070 7071 7072 7073 | if (!(statePtr->flags & CHANNEL_NEED_MORE_DATA) && (statePtr->interestMask & TCL_READABLE) && (statePtr->inQueueHead != (ChannelBuffer *) NULL) && (statePtr->inQueueHead->nextRemoved < statePtr->inQueueHead->nextAdded)) { /* | | | > | | | | | | | | < | | | | | | | | | | | | | | | 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 7430 7431 7432 7433 7434 7435 7436 7437 7438 7439 7440 7441 7442 7443 7444 7445 7446 7447 7448 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 | if (!(statePtr->flags & CHANNEL_NEED_MORE_DATA) && (statePtr->interestMask & TCL_READABLE) && (statePtr->inQueueHead != (ChannelBuffer *) NULL) && (statePtr->inQueueHead->nextRemoved < statePtr->inQueueHead->nextAdded)) { /* * Restart the timer in case a channel handler reenters the event loop * before UpdateInterest gets called by Tcl_NotifyChannel. */ statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc, (ClientData) chanPtr); #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING /* * Set the TIMER flag to notify the higher levels that the driver * might have no data for us. We do this only if we are in * non-blocking mode and the driver has no BlockModeProc because only * then we really don't know if the driver will block or not. A * similar test is done in "PeekAhead". */ if ((statePtr->flags & CHANNEL_NONBLOCKING) && (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) { statePtr->flags |= CHANNEL_TIMER_FEV; } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ Tcl_Preserve((ClientData) statePtr); Tcl_NotifyChannel((Tcl_Channel)chanPtr, TCL_READABLE); #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING statePtr->flags &= ~CHANNEL_TIMER_FEV; #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ Tcl_Release((ClientData) statePtr); } else { statePtr->timer = NULL; UpdateInterest(chanPtr); } } /* *---------------------------------------------------------------------- * * Tcl_CreateChannelHandler -- * * Arrange for a given procedure to be invoked whenever the channel * indicated by the chanPtr arg becomes readable or writable. * * Results: * None. * * Side effects: * From now on, whenever the I/O channel given by chanPtr becomes ready * in the way indicated by mask, proc will be invoked. See the manual * entry for details on the calling sequence to proc. If there is already * an event handler for chan, proc and clientData, then the mask will be * updated. * *---------------------------------------------------------------------- */ void Tcl_CreateChannelHandler(chan, mask, proc, clientData) Tcl_Channel chan; /* The channel to create the handler for. */ int mask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. Use 0 to disable a registered * handler. */ Tcl_ChannelProc *proc; /* Procedure to call for each selected * event. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { ChannelHandler *chPtr; Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ /* * Check whether this channel handler is not already registered. If it is * not, create a new record, else reuse existing record (smash current * values). */ for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; chPtr = chPtr->nextPtr) { if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) && (chPtr->clientData == clientData)) { |
︙ | ︙ | |||
7165 7166 7167 7168 7169 7170 7171 | chPtr->clientData = clientData; chPtr->chanPtr = chanPtr; chPtr->nextPtr = statePtr->chPtr; statePtr->chPtr = chPtr; } /* | | | < | | | < | | | | 7470 7471 7472 7473 7474 7475 7476 7477 7478 7479 7480 7481 7482 7483 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 | chPtr->clientData = clientData; chPtr->chanPtr = chanPtr; chPtr->nextPtr = statePtr->chPtr; statePtr->chPtr = chPtr; } /* * The remainder of the initialization below is done regardless of whether * or not this is a new record or a modification of an old one. */ chPtr->mask = mask; /* * Recompute the interest mask for the channel - this call may actually be * disabling an existing handler. */ statePtr->interestMask = 0; for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; chPtr = chPtr->nextPtr) { statePtr->interestMask |= chPtr->mask; } UpdateInterest(statePtr->topChanPtr); } /* *---------------------------------------------------------------------- * * Tcl_DeleteChannelHandler -- * * Cancel a previously arranged callback arrangement for an IO channel. * * Results: * None. * * Side effects: * If a callback was previously registered for this chan, proc and * clientData, it is removed and the callback will no longer be called * when the channel becomes ready for IO. * *---------------------------------------------------------------------- */ void Tcl_DeleteChannelHandler(chan, proc, clientData) Tcl_Channel chan; /* The channel for which to remove the * callback. */ Tcl_ChannelProc *proc; /* The procedure in the callback to delete. */ ClientData clientData; /* The client data in the callback to * delete. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ChannelHandler *chPtr, *prevChPtr; Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ NextChannelHandler *nhPtr; |
︙ | ︙ | |||
7268 7269 7270 7271 7272 7273 7274 | } else { prevChPtr->nextPtr = chPtr->nextPtr; } ckfree((char *) chPtr); /* * Recompute the interest list for the channel, so that infinite loops | | < | | | | | | | 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 7583 7584 7585 7586 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 | } else { prevChPtr->nextPtr = chPtr->nextPtr; } ckfree((char *) chPtr); /* * Recompute the interest list for the channel, so that infinite loops * will not result if Tcl_DeleteChannelHandler is called inside an event. */ statePtr->interestMask = 0; for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; chPtr = chPtr->nextPtr) { statePtr->interestMask |= chPtr->mask; } UpdateInterest(statePtr->topChanPtr); } /* *---------------------------------------------------------------------- * * DeleteScriptRecord -- * * Delete a script record for this combination of channel, interp and * mask. * * Results: * None. * * Side effects: * Deletes a script record and cancels a channel event handler. * *---------------------------------------------------------------------- */ static void DeleteScriptRecord(interp, chanPtr, mask) Tcl_Interp *interp; /* Interpreter in which script was to be * executed. */ Channel *chanPtr; /* The channel for which to delete the script * record (if any). */ int mask; /* Events in mask must exactly match mask of * script to delete. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ EventScriptRecord *esPtr, *prevEsPtr; for (esPtr = statePtr->scriptRecordPtr, prevEsPtr = (EventScriptRecord *) NULL; esPtr != (EventScriptRecord *) NULL; |
︙ | ︙ | |||
7352 7353 7354 7355 7356 7357 7358 | * Causes the script to be stored for later execution. * *---------------------------------------------------------------------- */ static void CreateScriptRecord(interp, chanPtr, mask, scriptPtr) | | | | | | | | 7654 7655 7656 7657 7658 7659 7660 7661 7662 7663 7664 7665 7666 7667 7668 7669 7670 7671 7672 7673 | * Causes the script to be stored for later execution. * *---------------------------------------------------------------------- */ static void CreateScriptRecord(interp, chanPtr, mask, scriptPtr) Tcl_Interp *interp; /* Interpreter in which to execute the * stored script. */ Channel *chanPtr; /* Channel for which script is to be * stored. */ int mask; /* Set of events for which script will * be invoked. */ Tcl_Obj *scriptPtr; /* Pointer to script object. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ EventScriptRecord *esPtr; for (esPtr = statePtr->scriptRecordPtr; esPtr != (EventScriptRecord *) NULL; |
︙ | ︙ | |||
7392 7393 7394 7395 7396 7397 7398 | } /* *---------------------------------------------------------------------- * * TclChannelEventScriptInvoker -- * | | | | | 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 | } /* *---------------------------------------------------------------------- * * TclChannelEventScriptInvoker -- * * Invokes a script scheduled by "fileevent" for when the channel becomes * ready for IO. This function is invoked by the channel handler which * was created by the Tcl "fileevent" command. * * Results: * None. * * Side effects: * Whatever the script does. * |
︙ | ︙ | |||
7423 7424 7425 7426 7427 7428 7429 | esPtr = (EventScriptRecord *) clientData; chanPtr = esPtr->chanPtr; mask = esPtr->mask; interp = esPtr->interp; /* | | | | | | | | | | | | | | | 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 | esPtr = (EventScriptRecord *) clientData; chanPtr = esPtr->chanPtr; mask = esPtr->mask; interp = esPtr->interp; /* * We must preserve the interpreter so we can report errors on it later. * Note that we do not need to preserve the channel because that is done * by Tcl_NotifyChannel before calling channel handlers. */ Tcl_Preserve((ClientData) interp); result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL); /* * On error, cause a background error and remove the channel handler and * the script record. * * NOTE: Must delete channel handler before causing the background error * because the background error may want to reinstall the handler. */ if (result != TCL_OK) { if (chanPtr->typePtr != NULL) { DeleteScriptRecord(interp, chanPtr, mask); } Tcl_BackgroundError(interp); } Tcl_Release((ClientData) interp); } /* *---------------------------------------------------------------------- * * Tcl_FileEventObjCmd -- * * This procedure implements the "fileevent" Tcl command. See the user * documentation for details on what it does. This command is based on * the Tk command "fileevent" which in turn is based on work contributed * by Mark Diekhans. * * Results: * A standard Tcl result. * * Side effects: * May create a channel handler for the specified channel. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_FileEventObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter in which the channel * for which to create the handler is * found. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Channel *chanPtr; /* The channel to create the handler * for. */ ChannelState *statePtr; /* state info for channel */ Tcl_Channel chan; /* The opaque type for the channel. */ char *chanName; int modeIndex; /* Index of mode argument. */ int mask; static CONST char *modeOptions[] = {"readable", "writable", NULL}; static int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; |
︙ | ︙ | |||
7538 7539 7540 7541 7542 7543 7544 | if (*(Tcl_GetString(objv[3])) == '\0') { DeleteScriptRecord(interp, chanPtr, mask); return TCL_OK; } /* | | | | | | | | | | | 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 | if (*(Tcl_GetString(objv[3])) == '\0') { DeleteScriptRecord(interp, chanPtr, mask); return TCL_OK; } /* * Make the script record that will link between the event and the script * to invoke. This also creates a channel event handler which will * evaluate the script in the supplied interpreter. */ CreateScriptRecord(interp, chanPtr, mask, objv[3]); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCopyChannel -- * * This routine copies data from one channel to another, either * synchronously or asynchronously. If a command script is supplied, the * operation runs in the background. The script is invoked when the copy * completes. Otherwise the function waits until the copy is completed * before returning. * * Results: * A standard Tcl result. * * Side effects: * May schedule a background copy operation that causes both channels to * be marked busy. * *---------------------------------------------------------------------- */ int TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr) Tcl_Interp *interp; /* Current interpreter. */ |
︙ | ︙ | |||
7603 7604 7605 7606 7607 7608 7609 | } readFlags = inStatePtr->flags; writeFlags = outStatePtr->flags; /* * Set up the blocking mode appropriately. Background copies need | | | | | 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 | } readFlags = inStatePtr->flags; writeFlags = outStatePtr->flags; /* * Set up the blocking mode appropriately. Background copies need * non-blocking channels. Foreground copies need blocking channels. If * there is an error, restore the old blocking mode. */ if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) { if (SetBlockMode(interp, inPtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING) != TCL_OK) { return TCL_ERROR; } } if (inPtr != outPtr) { if (nonBlocking != (writeFlags & CHANNEL_NONBLOCKING)) { if (SetBlockMode(NULL, outPtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING) != TCL_OK) { if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) { SetBlockMode(NULL, inPtr, |
︙ | ︙ | |||
7670 7671 7672 7673 7674 7675 7676 | } /* *---------------------------------------------------------------------- * * CopyData -- * | | | > | | | | > | > | | 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 8032 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 | } /* *---------------------------------------------------------------------- * * CopyData -- * * This function implements the lowest level of the copying mechanism for * TclCopyChannel. * * Results: * Returns TCL_OK on success, else TCL_ERROR. * * Side effects: * Moves data between channels, may create channel handlers. * *---------------------------------------------------------------------- */ static int CopyData(csPtr, mask) CopyState *csPtr; /* State of copy operation. */ int mask; /* Current channel event flags. */ { Tcl_Interp *interp; Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL; Tcl_Obj* msg = NULL; Tcl_Channel inChan, outChan; ChannelState *inStatePtr, *outStatePtr; int result = TCL_OK, size, total, sizeb; char *buffer; int inBinary, outBinary, sameEncoding; /* Encoding control */ int underflow; /* input underflow */ inChan = (Tcl_Channel) csPtr->readPtr; outChan = (Tcl_Channel) csPtr->writePtr; inStatePtr = csPtr->readPtr->state; outStatePtr = csPtr->writePtr->state; interp = csPtr->interp; cmdPtr = csPtr->cmdPtr; /* * Copy the data the slow way, using the translation mechanism. * * Note: We have make sure that we use the topmost channel in a stack for * the copying. The caller uses Tcl_GetChannel to access it, and thus gets * the bottom of the stack. */ inBinary = (inStatePtr->encoding == NULL); outBinary = (outStatePtr->encoding == NULL); sameEncoding = (inStatePtr->encoding == outStatePtr->encoding); if (!(inBinary || sameEncoding)) { TclNewObj(bufObj); Tcl_IncrRefCount(bufObj); } while (csPtr->toRead != 0) { /* * Check for unreported background errors. */ Tcl_GetChannelError (inChan, &msg); if ((inStatePtr->unreportedError != 0) || (msg != NULL)) { Tcl_SetErrno(inStatePtr->unreportedError); inStatePtr->unreportedError = 0; goto readError; } Tcl_GetChannelError (outChan, &msg); if ((outStatePtr->unreportedError != 0) || (msg != NULL)) { Tcl_SetErrno(outStatePtr->unreportedError); outStatePtr->unreportedError = 0; goto writeError; } /* * Read up to bufSize bytes. |
︙ | ︙ | |||
7755 7756 7757 7758 7759 7760 7761 | size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb); } else { size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, 0 /* No append */); } underflow = (size >= 0) && (size < sizeb); /* input underflow */ if (size < 0) { | | | > > > > > | > > | | | | 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 | size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb); } else { size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, 0 /* No append */); } underflow = (size >= 0) && (size < sizeb); /* input underflow */ if (size < 0) { readError: TclNewObj(errObj); Tcl_AppendStringsToObj(errObj, "error reading \"", Tcl_GetChannelName(inChan), "\": ", (char *) NULL); if (msg != NULL) { Tcl_AppendObjToObj(errObj,msg); } else { Tcl_AppendStringsToObj(errObj, Tcl_PosixError(interp), (char *) NULL); } break; } else if (underflow) { /* * We had an underflow on the read side. If we are at EOF, then * the copying is done, otherwise set up a channel handler to * detect when the channel becomes readable again. */ if ((size == 0) && Tcl_Eof(inChan)) { break; } if (! Tcl_Eof(inChan) && !(mask & TCL_READABLE)) { if (mask & TCL_WRITABLE) { |
︙ | ︙ | |||
7811 7812 7813 7814 7815 7816 7817 | if (inBinary || sameEncoding) { /* Both read and write counted bytes */ size = sizeb; } /* else : Read counted characters, write counted bytes, i.e. size != sizeb */ if (sizeb < 0) { | | | > > > > > | > > | | | | | 8123 8124 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 | if (inBinary || sameEncoding) { /* Both read and write counted bytes */ size = sizeb; } /* else : Read counted characters, write counted bytes, i.e. size != sizeb */ if (sizeb < 0) { writeError: TclNewObj(errObj); Tcl_AppendStringsToObj(errObj, "error writing \"", Tcl_GetChannelName(outChan), "\": ", (char *) NULL); if (msg != NULL) { Tcl_AppendObjToObj(errObj,msg); } else { Tcl_AppendStringsToObj(errObj, Tcl_PosixError(interp), (char *) NULL); } break; } /* * Update the current byte count. Do it now so the count is valid * before a return or break takes us out of the loop. The invariant at * the top of the loop should be that csPtr->toRead holds the number * of bytes left to copy. */ if (csPtr->toRead != -1) { csPtr->toRead -= size; } csPtr->total += size; |
︙ | ︙ | |||
7863 7864 7865 7866 7867 7868 7869 | TclDecrRefCount(bufObj); bufObj = (Tcl_Obj *) NULL; } return TCL_OK; } /* | | | | | | | | | | | 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 8214 8215 8216 8217 8218 8219 8220 8221 8222 8223 8224 8225 8226 8227 8228 8229 8230 8231 8232 8233 | TclDecrRefCount(bufObj); bufObj = (Tcl_Obj *) NULL; } return TCL_OK; } /* * For background copies, we only do one buffer per invocation so we * don't starve the rest of the system. */ if (cmdPtr) { /* * The first time we enter this code, there won't be a channel * handler established yet, so do it here. */ if (mask == 0) { Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, CopyEventProc, (ClientData) csPtr); } if (bufObj != (Tcl_Obj *) NULL) { TclDecrRefCount(bufObj); bufObj = (Tcl_Obj *) NULL; } return TCL_OK; } } /* while */ if (bufObj != (Tcl_Obj *) NULL) { TclDecrRefCount(bufObj); bufObj = (Tcl_Obj *) NULL; } /* * Make the callback or return the number of bytes transferred. The local * total is used because StopCopy frees csPtr. */ total = csPtr->total; if (cmdPtr) { /* * Get a private copy of the command so we can mutate it by adding * arguments. Note that StopCopy frees our saved reference to the * original command obj. */ cmdPtr = Tcl_DuplicateObj(cmdPtr); Tcl_IncrRefCount(cmdPtr); StopCopy(csPtr); Tcl_Preserve((ClientData) interp); |
︙ | ︙ | |||
7941 7942 7943 7944 7945 7946 7947 | * DoRead -- * * Reads a given number of bytes from a channel. * * No encoding conversions are applied to the bytes being read. * * Results: | | | | | | | | | | | 8260 8261 8262 8263 8264 8265 8266 8267 8268 8269 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 | * DoRead -- * * Reads a given number of bytes from a channel. * * No encoding conversions are applied to the bytes being read. * * Results: * The number of characters read, or -1 on error. Use Tcl_GetErrno() to * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. * *---------------------------------------------------------------------- */ static int DoRead(chanPtr, bufPtr, toRead) Channel *chanPtr; /* The channel from which to read. */ char *bufPtr; /* Where to store input read. */ int toRead; /* Maximum number of bytes to read. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ int copied; /* How many characters were copied into the * result string? */ int copiedNow; /* How many characters were copied from the * current input buffer? */ int result; /* Of calling GetInput. */ /* * If we have not encountered a sticky EOF, clear the EOF bit. Either way * clear the BLOCKED bit. We want to discover these anew during each * operation. */ if (!(statePtr->flags & CHANNEL_STICKY_EOF)) { statePtr->flags &= ~CHANNEL_EOF; } statePtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA); |
︙ | ︙ | |||
7999 8000 8001 8002 8003 8004 8005 | goto done; } } } statePtr->flags &= (~(CHANNEL_BLOCKED)); | < | | > | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | < | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | < | | | | | | | | | | | | | | < | | | | | | | | | | | | | < | | | | | | 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 | goto done; } } } statePtr->flags &= (~(CHANNEL_BLOCKED)); /* * Update the notifier state so we don't block while there is still data * in the buffers. */ done: UpdateInterest(chanPtr); return copied; } /* *---------------------------------------------------------------------- * * CopyAndTranslateBuffer -- * * Copy at most one buffer of input to the result space, doing eol * translations according to mode in effect currently. * * Results: * Number of bytes stored in the result buffer (as opposed to the number * of bytes read from the channel). May return zero if no input is * available to be translated. * * Side effects: * Consumes buffered input. May deallocate one buffer. * *---------------------------------------------------------------------- */ static int CopyAndTranslateBuffer(statePtr, result, space) ChannelState *statePtr; /* Channel state from which to read input. */ char *result; /* Where to store the copied input. */ int space; /* How many bytes are available in result to * store the copied input? */ { ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ int bytesInBuffer; /* How many bytes are available to be copied * in the current input buffer? */ int copied; /* How many characters were already copied * into the destination space? */ int i; /* Iterates over the copied input looking for * the input eofChar. */ /* * If there is no input at all, return zero. The invariant is that either * there is no buffer in the queue, or if the first buffer is empty, it is * also the last buffer (and thus there is no input in the queue). Note * also that if the buffer is empty, we leave it in the queue. */ if (statePtr->inQueueHead == (ChannelBuffer *) NULL) { return 0; } bufPtr = statePtr->inQueueHead; bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved; copied = 0; switch (statePtr->inputTranslation) { case TCL_TRANSLATE_LF: if (bytesInBuffer == 0) { return 0; } /* * Copy the current chunk into the result buffer. */ if (bytesInBuffer < space) { space = bytesInBuffer; } memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), (size_t) space); bufPtr->nextRemoved += space; copied = space; break; case TCL_TRANSLATE_CR: { char *end; if (bytesInBuffer == 0) { return 0; } /* * Copy the current chunk into the result buffer, then replace all \r * with \n. */ if (bytesInBuffer < space) { space = bytesInBuffer; } memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), (size_t) space); bufPtr->nextRemoved += space; copied = space; for (end = result + copied; result < end; result++) { if (*result == '\r') { *result = '\n'; } } break; } case TCL_TRANSLATE_CRLF: { char *src, *end, *dst; int curByte; /* * If there is a held-back "\r" at EOF, produce it now. */ if (bytesInBuffer == 0) { if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == (INPUT_SAW_CR | CHANNEL_EOF)) { result[0] = '\r'; statePtr->flags &= ~INPUT_SAW_CR; return 1; } return 0; } /* * Copy the current chunk and replace "\r\n" with "\n" * (but not standalone "\r"!). */ if (bytesInBuffer < space) { space = bytesInBuffer; } memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), (size_t) space); bufPtr->nextRemoved += space; copied = space; end = result + copied; dst = result; for (src = result; src < end; src++) { curByte = *src; if (curByte == '\n') { statePtr->flags &= ~INPUT_SAW_CR; } else if (statePtr->flags & INPUT_SAW_CR) { statePtr->flags &= ~INPUT_SAW_CR; *dst = '\r'; dst++; } if (curByte == '\r') { statePtr->flags |= INPUT_SAW_CR; } else { *dst = (char) curByte; dst++; } } copied = dst - result; break; } case TCL_TRANSLATE_AUTO: { char *src, *end, *dst; int curByte; if (bytesInBuffer == 0) { return 0; } /* * Loop over the current buffer, converting "\r" and "\r\n" to "\n". */ if (bytesInBuffer < space) { space = bytesInBuffer; } memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), (size_t) space); bufPtr->nextRemoved += space; copied = space; end = result + copied; dst = result; for (src = result; src < end; src++) { curByte = *src; if (curByte == '\r') { statePtr->flags |= INPUT_SAW_CR; *dst = '\n'; dst++; } else { if ((curByte != '\n') || !(statePtr->flags & INPUT_SAW_CR)) { *dst = (char) curByte; dst++; } statePtr->flags &= ~INPUT_SAW_CR; } } copied = dst - result; break; } default: Tcl_Panic("unknown eol translation mode"); } /* * If an in-stream EOF character is set for this channel, check that the * input we copied so far does not contain the EOF char. If it does, copy * only up to and excluding that character. */ if (statePtr->inEofChar != 0) { for (i = 0; i < copied; i++) { if (result[i] == (char) statePtr->inEofChar) { /* * Set sticky EOF so that no further input is presented to the * caller. */ statePtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; copied = i; break; } |
︙ | ︙ | |||
8240 8241 8242 8243 8244 8245 8246 | if (statePtr->inQueueHead == (ChannelBuffer *) NULL) { statePtr->inQueueTail = (ChannelBuffer *) NULL; } RecycleBuffer(statePtr, bufPtr, 0); } /* | | | | | | | | | | | | | | | | 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 8601 8602 8603 8604 8605 8606 8607 8608 | if (statePtr->inQueueHead == (ChannelBuffer *) NULL) { statePtr->inQueueTail = (ChannelBuffer *) NULL; } RecycleBuffer(statePtr, bufPtr, 0); } /* * Return the number of characters copied into the result buffer. This may * be different from the number of bytes consumed, because of EOL * translations. */ return copied; } /* *---------------------------------------------------------------------- * * CopyBuffer -- * * Copy at most one buffer of input to the result space. * * Results: * Number of bytes stored in the result buffer. May return zero if no * input is available. * * Side effects: * Consumes buffered input. May deallocate one buffer. * *---------------------------------------------------------------------- */ static int CopyBuffer(chanPtr, result, space) Channel *chanPtr; /* Channel from which to read input. */ char *result; /* Where to store the copied input. */ int space; /* How many bytes are available in result to * store the copied input? */ { ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ int bytesInBuffer; /* How many bytes are available to be copied * in the current input buffer? */ int copied; /* How many characters were already copied * into the destination space? */ /* * If there is no input at all, return zero. The invariant is that either * there is no buffer in the queue, or if the first buffer is empty, it is * also the last buffer (and thus there is no input in the queue). Note * also that if the buffer is empty, we don't leave it in the queue, but * recycle it. */ if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { return 0; } bufPtr = chanPtr->inQueueHead; bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved; |
︙ | ︙ | |||
8309 8310 8311 8312 8313 8314 8315 | * Copy the current chunk into the result buffer. */ if (bytesInBuffer < space) { space = bytesInBuffer; } | < | | | | | | 8620 8621 8622 8623 8624 8625 8626 8627 8628 8629 8630 8631 8632 8633 8634 8635 8636 8637 8638 8639 8640 8641 8642 | * Copy the current chunk into the result buffer. */ if (bytesInBuffer < space) { space = bytesInBuffer; } memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), (size_t) space); bufPtr->nextRemoved += space; copied = space; /* * We don't care about in-stream EOF characters here as the data read here * may still flow through one or more transformations, i.e. is not in its * final state yet. */ /* * If the current buffer is empty recycle it. */ if (bufPtr->nextRemoved == bufPtr->nextAdded) { |
︙ | ︙ | |||
8374 8375 8376 8377 8378 8379 8380 | ChannelState *statePtr = chanPtr->state; /* state info for channel */ ChannelBuffer *outBufPtr; /* Current output buffer. */ int foundNewline; /* Did we find a newline in output? */ char *dPtr; CONST char *sPtr; /* Search variables for newline. */ int crsent; /* In CRLF eol translation mode, * remember the fact that a CR was | | | | | | | | 8684 8685 8686 8687 8688 8689 8690 8691 8692 8693 8694 8695 8696 8697 8698 8699 8700 8701 8702 8703 8704 8705 8706 8707 | ChannelState *statePtr = chanPtr->state; /* state info for channel */ ChannelBuffer *outBufPtr; /* Current output buffer. */ int foundNewline; /* Did we find a newline in output? */ char *dPtr; CONST char *sPtr; /* Search variables for newline. */ int crsent; /* In CRLF eol translation mode, * remember the fact that a CR was * output to the channel without its * following NL. */ int i; /* Loop index for newline search. */ int destCopied; /* How many bytes were used in this * destination buffer to hold the * output? */ int totalDestCopied; /* How many bytes total were copied to * the channel buffer? */ int srcCopied; /* How many bytes were copied from the * source string? */ char *destPtr; /* Where in line to copy to? */ /* * If we are in network (or windows) translation mode, record the fact * that we have not yet sent a CR to the channel. */ |
︙ | ︙ | |||
8420 8421 8422 8423 8424 8425 8426 | destCopied = outBufPtr->bufLength - outBufPtr->nextAdded; if (destCopied > srcLen) { destCopied = srcLen; } destPtr = outBufPtr->buf + outBufPtr->nextAdded; switch (statePtr->outputTranslation) { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 8730 8731 8732 8733 8734 8735 8736 8737 8738 8739 8740 8741 8742 8743 8744 8745 8746 8747 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 8778 | destCopied = outBufPtr->bufLength - outBufPtr->nextAdded; if (destCopied > srcLen) { destCopied = srcLen; } destPtr = outBufPtr->buf + outBufPtr->nextAdded; switch (statePtr->outputTranslation) { case TCL_TRANSLATE_LF: srcCopied = destCopied; memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); break; case TCL_TRANSLATE_CR: srcCopied = destCopied; memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { if (*dPtr == '\n') { *dPtr = '\r'; } } break; case TCL_TRANSLATE_CRLF: for (srcCopied = 0, dPtr = destPtr, sPtr = src; dPtr < destPtr + destCopied; dPtr++, sPtr++, srcCopied++) { if (*sPtr == '\n') { if (crsent) { *dPtr = '\n'; crsent = 0; } else { *dPtr = '\r'; crsent = 1; sPtr--, srcCopied--; } } else { *dPtr = *sPtr; } } break; case TCL_TRANSLATE_AUTO: Tcl_Panic("Tcl_Write: AUTO output translation mode not supported"); default: Tcl_Panic("Tcl_Write: unknown output translation mode"); } /* * The current buffer is ready for output if it is full, or if it * contains a newline and this channel is line-buffered, or if it * contains any output and this channel is unbuffered. */ |
︙ | ︙ | |||
8503 8504 8505 8506 8507 8508 8509 | } /* *---------------------------------------------------------------------- * * CopyEventProc -- * | | | | | | | | 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 8825 8826 8827 8828 8829 8830 8831 8832 8833 8834 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 8860 | } /* *---------------------------------------------------------------------- * * CopyEventProc -- * * This routine is invoked as a channel event handler for the background * copy operation. It is just a trivial wrapper around the CopyData * routine. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void CopyEventProc(clientData, mask) ClientData clientData; int mask; { (void) CopyData((CopyState *) clientData, mask); } /* *---------------------------------------------------------------------- * * StopCopy -- * * This routine halts a copy that is in progress. * * Results: * None. * * Side effects: * Removes any pending channel handlers and restores the blocking and * buffering modes of the channels. The CopyState is freed. * *---------------------------------------------------------------------- */ static void StopCopy(csPtr) CopyState *csPtr; /* State for bg copy to stop . */ |
︙ | ︙ | |||
8573 8574 8575 8576 8577 8578 8579 | if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) { SetBlockMode(NULL, csPtr->writePtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); } } outStatePtr->flags &= ~(CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); outStatePtr->flags |= | | | | | | | | | | | 8883 8884 8885 8886 8887 8888 8889 8890 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 8914 8915 8916 8917 8918 8919 8920 8921 8922 8923 8924 8925 8926 | if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) { SetBlockMode(NULL, csPtr->writePtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); } } outStatePtr->flags &= ~(CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); outStatePtr->flags |= csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); if (csPtr->cmdPtr) { Tcl_DeleteChannelHandler((Tcl_Channel) csPtr->readPtr, CopyEventProc, (ClientData) csPtr); if (csPtr->readPtr != csPtr->writePtr) { Tcl_DeleteChannelHandler((Tcl_Channel) csPtr->writePtr, CopyEventProc, (ClientData) csPtr); } TclDecrRefCount(csPtr->cmdPtr); } inStatePtr->csPtr = NULL; outStatePtr->csPtr = NULL; ckfree((char *) csPtr); } /* *---------------------------------------------------------------------- * * StackSetBlockMode -- * * This function sets the blocking mode for a channel, iterating through * each channel in a stack and updates the state flags. * * Results: * 0 if OK, result code from failed blockModeProc otherwise. * * Side effects: * Modifies the blocking mode of the channel and possibly generates an * error. * *---------------------------------------------------------------------- */ static int StackSetBlockMode(chanPtr, mode) Channel *chanPtr; /* Channel to modify. */ |
︙ | ︙ | |||
8640 8641 8642 8643 8644 8645 8646 | } /* *---------------------------------------------------------------------- * * SetBlockMode -- * | | | | | > > > > > > > > > > | | > > > > > > > > | 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 8977 8978 8979 8980 8981 8982 8983 8984 8985 8986 8987 8988 8989 8990 8991 8992 8993 8994 8995 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 | } /* *---------------------------------------------------------------------- * * SetBlockMode -- * * This function sets the blocking mode for a channel and updates the * state flags. * * Results: * A standard Tcl result. * * Side effects: * Modifies the blocking mode of the channel and possibly generates an * error. * *---------------------------------------------------------------------- */ static int SetBlockMode(interp, chanPtr, mode) Tcl_Interp *interp; /* Interp for error reporting. */ Channel *chanPtr; /* Channel to modify. */ int mode; /* One of TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ int result = 0; result = StackSetBlockMode(chanPtr, mode); if (result != 0) { if (interp != (Tcl_Interp *) NULL) { /* TIP #219. * Move error messages put by the driver into the bypass area and * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. * * Note that we cannot have a message in the interpreter bypass * area, StackSetBlockMode is restricted to the channel bypass. * We still need the interp as the destination of the move. */ if (!TclChanCaughtErrorBypass (interp, (Tcl_Channel) chanPtr)) { Tcl_AppendResult(interp, "error setting blocking mode: ", Tcl_PosixError(interp), (char *) NULL); } } else { /* TIP #219. * If we have no interpreter to put a bypass message into we have * to clear it, to prevent its propagation and use in other places * unrelated to the actual occurence of the problem. */ Tcl_SetChannelError ((Tcl_Channel) chanPtr, NULL); } return TCL_ERROR; } if (mode == TCL_MODE_BLOCKING) { statePtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED)); } else { statePtr->flags |= CHANNEL_NONBLOCKING; |
︙ | ︙ | |||
8707 8708 8709 8710 8711 8712 8713 | } /* *---------------------------------------------------------------------- * * Tcl_GetChannelNamesEx -- * | | | | | 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 | } /* *---------------------------------------------------------------------- * * Tcl_GetChannelNamesEx -- * * Return the names of open channels in the interp filtered filtered * through a pattern. If pattern is NULL, it returns all the open * channels. * * Results: * TCL_OK or TCL_ERROR. * * Side effects: * Interp result modified with list of channel names. * |
︙ | ︙ | |||
8738 8739 8740 8741 8742 8743 8744 | Tcl_HashSearch hSearch; /* Search variable. */ if (interp == (Tcl_Interp *) NULL) { return TCL_OK; } /* | | | > > > > > > > | > > | | > > > | | | | | | | 9066 9067 9068 9069 9070 9071 9072 9073 9074 9075 9076 9077 9078 9079 9080 9081 9082 9083 9084 9085 9086 9087 9088 9089 9090 9091 9092 9093 9094 9095 9096 9097 9098 9099 9100 9101 9102 9103 9104 9105 9106 9107 9108 9109 9110 9111 9112 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 9123 9124 9125 9126 9127 9128 9129 9130 9131 9132 9133 9134 9135 9136 9137 9138 9139 9140 9141 9142 9143 9144 9145 9146 9147 9148 9149 9150 9151 9152 9153 9154 9155 9156 9157 9158 9159 | Tcl_HashSearch hSearch; /* Search variable. */ if (interp == (Tcl_Interp *) NULL) { return TCL_OK; } /* * Get the channel table that stores the channels registered for this * interpreter. */ hTblPtr = GetChannelTable(interp); TclNewObj(resultPtr); if ((pattern != NULL) && TclMatchIsTrivial(pattern) && !((pattern[0] == 's') && (pattern[1] == 't') && (pattern[2] == 'd'))) { if ((Tcl_FindHashEntry(hTblPtr, pattern) != NULL) && (Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(pattern, -1)) != TCL_OK)) { goto error; } goto done; } for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != (Tcl_HashEntry *) NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { statePtr = ((Channel *) Tcl_GetHashValue(hPtr))->state; if (statePtr->topChanPtr == (Channel *) tsdPtr->stdinChannel) { name = "stdin"; } else if (statePtr->topChanPtr == (Channel *) tsdPtr->stdoutChannel) { name = "stdout"; } else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) { name = "stderr"; } else { /* * This is also stored in Tcl_GetHashKey(hTblPtr, hPtr), but it's * simpler to just grab the name from the statePtr. */ name = statePtr->channelName; } if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) && (Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(name, -1)) != TCL_OK)) { error: TclDecrRefCount(resultPtr); return TCL_ERROR; } } done: Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_IsChannelRegistered -- * * Checks whether the channel is associated with the interp. See also * Tcl_RegisterChannel and Tcl_UnregisterChannel. * * Results: * 0 if the channel is not registered in the interpreter, 1 else. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_IsChannelRegistered(interp, chan) Tcl_Interp *interp; /* The interp to query of the channel */ Tcl_Channel chan; /* The channel to check */ { Tcl_HashTable *hTblPtr; /* Hash table of channels. */ Tcl_HashEntry *hPtr; /* Search variable. */ Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of the real channel. */ /* * Always check bottom-most channel in the stack. This is the one that * gets registered. */ chanPtr = ((Channel *) chan)->state->bottomChanPtr; statePtr = chanPtr->state; hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); if (hTblPtr == (Tcl_HashTable *) NULL) { |
︙ | ︙ | |||
8858 8859 8860 8861 8862 8863 8864 | /* *---------------------------------------------------------------------- * * Tcl_IsChannelExisting -- * * Checks whether a channel of the given name exists in the | | | | 9198 9199 9200 9201 9202 9203 9204 9205 9206 9207 9208 9209 9210 9211 9212 9213 | /* *---------------------------------------------------------------------- * * Tcl_IsChannelExisting -- * * Checks whether a channel of the given name exists in the * (thread)-global list of all channels. See Tcl_GetChannelNamesEx for * function exposed at the Tcl level. * * Results: * A boolean value (0 = Does not exist, 1 = Does exist). * * Side effects: * None. * |
︙ | ︙ | |||
8949 8950 8951 8952 8953 8954 8955 8956 8957 | Tcl_ChannelVersion(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) { return TCL_CHANNEL_VERSION_2; } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_3) { return TCL_CHANNEL_VERSION_3; } else { /* | > > | | | 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 9300 9301 9302 9303 9304 9305 9306 9307 9308 | Tcl_ChannelVersion(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) { return TCL_CHANNEL_VERSION_2; } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_3) { return TCL_CHANNEL_VERSION_3; } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_4) { return TCL_CHANNEL_VERSION_4; } else { /* * In <v2 channel versions, the version field is occupied by the * Tcl_DriverBlockModeProc */ return TCL_CHANNEL_VERSION_1; } } /* |
︙ | ︙ | |||
9303 9304 9305 9306 9307 9308 9309 9310 9311 9312 | { if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_3)) { return chanTypePtr->wideSeekProc; } else { return NULL; } } #if 0 /* | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > | > | | | | | | | | | | | | | | | | | > | > > > > > > > > | 9645 9646 9647 9648 9649 9650 9651 9652 9653 9654 9655 9656 9657 9658 9659 9660 9661 9662 9663 9664 9665 9666 9667 9668 9669 9670 9671 9672 9673 9674 9675 9676 9677 9678 9679 9680 9681 9682 9683 9684 9685 9686 9687 9688 9689 9690 9691 9692 9693 9694 9695 9696 9697 9698 9699 9700 9701 9702 9703 9704 9705 9706 9707 9708 9709 9710 9711 9712 9713 9714 9715 9716 9717 9718 9719 9720 9721 9722 9723 9724 9725 9726 9727 9728 9729 9730 9731 9732 9733 9734 9735 9736 9737 9738 9739 9740 9741 9742 9743 9744 9745 9746 9747 9748 9749 9750 9751 9752 9753 9754 9755 9756 9757 9758 9759 9760 9761 9762 9763 9764 9765 9766 9767 9768 9769 9770 9771 9772 9773 9774 9775 9776 9777 9778 9779 9780 9781 9782 9783 9784 9785 9786 9787 9788 9789 9790 9791 9792 9793 9794 9795 9796 9797 9798 9799 9800 9801 9802 9803 9804 9805 9806 9807 9808 9809 9810 9811 9812 9813 9814 9815 9816 9817 9818 9819 9820 9821 9822 9823 9824 9825 9826 9827 9828 9829 9830 9831 9832 9833 9834 9835 9836 9837 9838 9839 9840 9841 9842 9843 9844 9845 9846 9847 9848 9849 9850 9851 9852 9853 9854 9855 9856 9857 9858 9859 9860 9861 9862 9863 9864 9865 9866 9867 9868 9869 9870 9871 9872 9873 9874 9875 9876 9877 9878 9879 9880 9881 9882 9883 9884 9885 9886 9887 9888 9889 9890 9891 9892 9893 9894 9895 9896 9897 9898 9899 9900 9901 9902 9903 9904 9905 9906 9907 9908 9909 9910 9911 9912 9913 9914 9915 9916 9917 9918 9919 9920 9921 9922 9923 9924 9925 9926 9927 9928 9929 9930 9931 9932 9933 9934 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 9945 9946 9947 9948 9949 9950 9951 9952 9953 9954 9955 9956 9957 9958 9959 9960 9961 9962 9963 9964 9965 9966 9967 9968 9969 9970 9971 9972 9973 9974 9975 9976 9977 9978 9979 9980 9981 9982 9983 9984 9985 9986 9987 9988 9989 9990 9991 9992 9993 9994 9995 9996 9997 9998 9999 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 | { if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_3)) { return chanTypePtr->wideSeekProc; } else { return NULL; } } /* *---------------------------------------------------------------------- * * Tcl_ChannelThreadActionProc -- * * TIP #218, Channel Thread Actions. Return the * Tcl_DriverThreadActionProc of the channel type. * * Results: * A pointer to the proc. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_4)) { return chanTypePtr->threadActionProc; } else { return NULL; } } /* *---------------------------------------------------------------------- * * Tcl_SetChannelErrorInterp -- * * TIP #219, Tcl Channel Reflection API. * Store an error message for the I/O system. * * Results: * None. * * Side effects: * Discards a previously stored message. * *---------------------------------------------------------------------- */ void Tcl_SetChannelErrorInterp (interp, msg) Tcl_Interp* interp; /* Interp to store the data into. */ Tcl_Obj* msg; /* Error message to store. */ { Interp* iPtr = (Interp*) interp; if (iPtr->chanMsg != NULL) { Tcl_DecrRefCount (iPtr->chanMsg); iPtr->chanMsg = NULL; } if (msg != NULL) { iPtr->chanMsg = FixLevelCode (msg); Tcl_IncrRefCount (iPtr->chanMsg); } return; } /* *---------------------------------------------------------------------- * * Tcl_SetChannelError -- * * TIP #219, Tcl Channel Reflection API. * Store an error message for the I/O system. * * Results: * None. * * Side effects: * Discards a previously stored message. * *---------------------------------------------------------------------- */ void Tcl_SetChannelError (chan, msg) Tcl_Channel chan; /* Channel to store the data into. */ Tcl_Obj* msg; /* Error message to store. */ { ChannelState* statePtr = ((Channel*) chan)->state; if (statePtr->chanMsg != NULL) { Tcl_DecrRefCount (statePtr->chanMsg); statePtr->chanMsg = NULL; } if (msg != NULL) { statePtr->chanMsg = FixLevelCode (msg); Tcl_IncrRefCount (statePtr->chanMsg); } return; } /* *---------------------------------------------------------------------- * * FixLevelCode -- * * TIP #219, Tcl Channel Reflection API. * Scans an error message for bad -code / -level * directives. Returns a modified copy with such * directives corrected, and the input if it had * no problems. * * Results: * A Tcl_Obj* * * Side effects: * None. * *---------------------------------------------------------------------- */ static Tcl_Obj* FixLevelCode (msg) Tcl_Obj* msg; { int lc; Tcl_Obj** lv; int explicitResult; int numOptions; int lcn; Tcl_Obj** lvn; int res, i, j, val, lignore, cignore; Tcl_Obj* newlevel = NULL; Tcl_Obj* newcode = NULL; /* ASSERT msg != NULL */ /* Process the caught message. * * Syntax = (option value)... ?message? * * Bad syntax causes a panic. Because the other side uses * Tcl_GetReturnOptions and list construction functions to marshall the * information. */ res = Tcl_ListObjGetElements (NULL, msg, &lc, &lv); if (res != TCL_OK) { Tcl_Panic ("Tcl_SetChannelError(Interp): Bad syntax of message"); } explicitResult = (1 == (lc % 2)); numOptions = lc - explicitResult; /* No options, nothing to do. */ if (numOptions == 0) { return msg; } /* Check for -code x, x != 1|error, and -level x, x != 0 */ for (i = 0; i < numOptions; i += 2) { if (0 == strcmp (Tcl_GetString (lv [i]), "-code")) { /* !"error", !integer, integer != 1 (numeric code for error) */ res = Tcl_GetIntFromObj (NULL, lv [i+1], &val); if (((res == TCL_OK) && (val != 1)) || ((res != TCL_OK) && (0 != strcmp (Tcl_GetString (lv [i+1]), "error")))) { newcode = Tcl_NewIntObj (1); } } else if (0 == strcmp (Tcl_GetString (lv [i]), "-level")) { /* !integer, integer != 0 */ res = Tcl_GetIntFromObj (NULL, lv [i+1], &val); if ((res != TCL_OK) || (val != 0)) { newlevel = Tcl_NewIntObj (0); } } } /* -code, -level are either not present or ok. Nothing to do. */ if (!newlevel && !newcode) { return msg; } lcn = numOptions; if (explicitResult) lcn ++; if (newlevel) lcn += 2; if (newcode) lcn += 2; lvn = (Tcl_Obj**) ckalloc (lcn * sizeof (Tcl_Obj*)); /* New level/code information is spliced into the first occurence of * -level, -code, further occurences are ignored. The options cannot be * not present, we would not come here. Options which are ok are simply * copied over. */ lignore = cignore = 0; for (i = 0, j = 0; i < numOptions; i += 2) { if (0 == strcmp (Tcl_GetString (lv [i]), "-level")) { if (newlevel) { lvn [j] = lv [i]; j++; lvn [j] = newlevel; j++; newlevel = NULL; lignore = 1; continue; } else if (lignore) { continue; } } else if (0 == strcmp (Tcl_GetString (lv [i]), "-code")) { if (newcode) { lvn [j] = lv [i]; j++; lvn [j] = newcode; j++; newcode = NULL; cignore = 1; continue; } else if (cignore) { continue; } } /* Keep everything else, possibly copied down */ lvn [j] = lv [i]; j++; lvn [j] = lv [i+1]; j++; } if (explicitResult) { lvn [j] = lv [i]; j++; } msg = Tcl_NewListObj (j, lvn); ckfree ((char*) lvn); return msg; } /* *---------------------------------------------------------------------- * * Tcl_GetChannelErrorInterp -- * * TIP #219, Tcl Channel Reflection API. * Return the message stored by the channel driver. * * Results: * Tcl error message object. * * Side effects: * Resets the stored data to NULL. * *---------------------------------------------------------------------- */ void Tcl_GetChannelErrorInterp (interp, msg) Tcl_Interp* interp; /* Interp to query. */ Tcl_Obj** msg; /* Place for error message. */ { Interp* iPtr = (Interp*) interp; *msg = iPtr->chanMsg; iPtr->chanMsg = NULL; } /* *---------------------------------------------------------------------- * * Tcl_GetChannelError -- * * TIP #219, Tcl Channel Reflection API. * Return the message stored by the channel driver. * * Results: * Tcl error message object. * * Side effects: * Resets the stored data to NULL. * *---------------------------------------------------------------------- */ void Tcl_GetChannelError (chan, msg) Tcl_Channel chan; /* Channel to query. */ Tcl_Obj** msg; /* Place for error message. */ { ChannelState* statePtr = ((Channel*) chan)->state; *msg = statePtr->chanMsg; statePtr->chanMsg = NULL; } /* *---------------------------------------------------------------------- * * Tcl_ChannelTruncateProc -- * * TIP #208 (subsection relating to truncation, based on TIP #206). * Return the Tcl_DriverTruncateProc of the channel type. * * Results: * A pointer to the proc. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_4)) { return chanTypePtr->truncateProc; } else { return NULL; } } #if 0 /* * For future debugging work, a simple function to print the flags of a * channel in semi-readable form. */ static int DumpFlags(str, flags) char *str; int flags; { char buf[20]; int i = 0; #define ChanFlag(chr,bit) (buf[i++] = ((flags & (bit)) ? (chr) : '_')) ChanFlag('r', TCL_READABLE); ChanFlag('w', TCL_WRITABLE); ChanFlag('n', CHANNEL_NONBLOCKING); ChanFlag('l', CHANNEL_LINEBUFFERED); ChanFlag('u', CHANNEL_UNBUFFERED); ChanFlag('R', BUFFER_READY); ChanFlag('F', BG_FLUSH_SCHEDULED); ChanFlag('c', CHANNEL_CLOSED); ChanFlag('E', CHANNEL_EOF); ChanFlag('S', CHANNEL_STICKY_EOF); ChanFlag('B', CHANNEL_BLOCKED); ChanFlag('/', INPUT_SAW_CR); ChanFlag('*', INPUT_NEED_NL); ChanFlag('D', CHANNEL_DEAD); ChanFlag('R', CHANNEL_RAW_MODE); #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING ChanFlag('T', CHANNEL_TIMER_FEV); ChanFlag('H', CHANNEL_HAS_MORE_DATA); #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ ChanFlag('x', CHANNEL_INCLOSE); buf[i] ='\0'; fprintf(stderr, "%s: %s\n", str, buf); return 0; } #endif /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclIO.h.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclIO.h -- * * This file provides the generic portions (those that are the same on * all platforms and for all channel types) of Tcl's IO facilities. * * Copyright (c) 1998-2000 Ajuba Solutions * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclIO.h -- * * This file provides the generic portions (those that are the same on * all platforms and for all channel types) of Tcl's IO facilities. * * Copyright (c) 1998-2000 Ajuba Solutions * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclIO.h,v 1.7.2.1 2005/08/25 15:46:31 dgp Exp $ */ /* * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not * compile on systems where neither is defined. We want both defined so * that we can test safely for both. In the code we still have to test for * both because there may be systems on which both are defined and have |
︙ | ︙ | |||
231 232 233 234 235 236 237 238 239 240 241 242 243 244 | Channel *bottomChanPtr; /* Refers to bottommost channel in a stack. * This channel can be relied on to live as * long as the channel state. Never NULL. */ struct ChannelState *nextCSPtr; /* Next in list of channels currently open. */ Tcl_ThreadId managingThread; /* TIP #10: Id of the thread managing * this stack of channels. */ } ChannelState; /* * Values for the flags field in Channel. Any ORed combination of the * following flags can be stored in the field. These flags record various * options and state bits about the channel. In addition to the flags below, * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set. | > > > > > > > > > > > > > > | 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 | Channel *bottomChanPtr; /* Refers to bottommost channel in a stack. * This channel can be relied on to live as * long as the channel state. Never NULL. */ struct ChannelState *nextCSPtr; /* Next in list of channels currently open. */ Tcl_ThreadId managingThread; /* TIP #10: Id of the thread managing * this stack of channels. */ /* TIP #219 ... Info for the I/O system ... * Error message set by channel drivers, for the propagation of * arbitrary Tcl errors. This information, if present (chanMsg not * NULL), takes precedence over a posix error code returned by a * channel operation. */ Tcl_Obj* chanMsg; Tcl_Obj* unreportedMsg; /* Non-NULL if an error report was * deferred because it happened in the * background. The value is the * chanMg, if any. #219's companion to * 'unreportedError'. */ } ChannelState; /* * Values for the flags field in Channel. Any ORed combination of the * following flags can be stored in the field. These flags record various * options and state bits about the channel. In addition to the flags below, * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set. |
︙ | ︙ |
Changes to generic/tclIOCmd.c.
|
| | | | | | | | | | | | | | | | | | | | | | < > | | | | | | | | | | > > > > > > | | > | | | | | > > > > > > | | > | | | | | | | > > > > > > > | | | > | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 | /* * tclIOCmd.c -- * * Contains the definitions of most of the Tcl commands relating to IO. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclIOCmd.c,v 1.22.2.4 2005/08/25 15:46:31 dgp Exp $ */ #include "tclInt.h" /* * Callback structure for accept callback in a TCP server. */ typedef struct AcceptCallback { char *script; /* Script to invoke. */ Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; /* * Static functions for this file: */ static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData, Tcl_Channel chan, char *address, int port)); static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr)); static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData)); static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_(( Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr)); /* *---------------------------------------------------------------------- * * Tcl_PutsObjCmd -- * * This procedure is invoked to process the "puts" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * Produces output on a channel. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_PutsObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to puts on. */ Tcl_Obj *string; /* String to write. */ int newline; /* Add a newline at end? */ char *channelId; /* Name of channel for puts. */ int result; /* Result of puts operation. */ int mode; /* Mode in which channel is opened. */ switch (objc) { case 2: /* [puts $x] */ string = objv[1]; newline = 1; channelId = "stdout"; break; case 3: /* [puts -nonewline $x] or [puts $chan $x] */ if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { newline = 0; channelId = "stdout"; } else { newline = 1; channelId = Tcl_GetString(objv[1]); } string = objv[2]; break; case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */ if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { channelId = Tcl_GetString(objv[2]); string = objv[3]; } else { /* * The code below provides backwards compatibility with an old * form of the command that is no longer recommended or * documented. */ char *arg; int length; arg = Tcl_GetStringFromObj(objv[3], &length); if ((length != 9) || (strncmp(arg, "nonewline", (size_t) length) != 0)) { Tcl_AppendResult(interp, "bad argument \"", arg, "\": should be \"nonewline\"", (char *) NULL); return TCL_ERROR; } channelId = Tcl_GetString(objv[1]); string = objv[2]; } newline = 0; break; default: /* [puts] or [puts some bad number of arguments...] */ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); return TCL_ERROR; } chan = Tcl_GetChannel(interp, channelId, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { Tcl_AppendResult(interp, "channel \"", channelId, "\" wasn't opened for writing", (char *) NULL); return TCL_ERROR; } result = Tcl_WriteObj(chan, string); if (result < 0) { goto error; } if (newline != 0) { result = Tcl_WriteChars(chan, "\n", 1); if (result < 0) { goto error; } } return TCL_OK; error: /* TIP #219. * Capture error messages put by the driver into the bypass area and put * them into the regular interpreter result. Fall back to the regular * message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass (interp, chan)) { Tcl_AppendResult(interp, "error writing \"", channelId, "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Tcl_FlushObjCmd -- * * This procedure is called to process the Tcl "flush" command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * May cause output to appear on the specified channel. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_FlushObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to flush on. */ char *channelId; int mode; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } channelId = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, channelId, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { Tcl_AppendResult(interp, "channel \"", channelId, "\" wasn't opened for writing", (char *) NULL); return TCL_ERROR; } if (Tcl_Flush(chan) != TCL_OK) { /* TIP #219. * Capture error messages put by the driver into the bypass area and * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass (interp, chan)) { Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetsObjCmd -- * * This procedure is called to process the Tcl "gets" command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * May consume input from channel. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_GetsObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ int lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ char *name; Tcl_Obj *linePtr; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?"); return TCL_ERROR; } name = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, name, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", name, "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } linePtr = Tcl_NewObj(); lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { Tcl_DecrRefCount(linePtr); /* TIP #219. * Capture error messages put by the driver into the bypass area * and put them into the regular interpreter result. Fall back to * the regular message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass (interp, chan)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading \"", name, "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } lineLen = -1; } if (objc == 3) { if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(linePtr); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); return TCL_OK; } else { Tcl_SetObjResult(interp, linePtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ReadObjCmd -- * * This procedure is invoked to process the Tcl "read" command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * May consume input from channel. * |
︙ | ︙ | |||
301 302 303 304 305 306 307 | int toRead; /* How many bytes to read? */ int charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ char *name; Tcl_Obj *resultPtr; if ((objc != 2) && (objc != 3)) { | > > | > | > > > > > > | > | | | | | | | | | > > > > > > | | | | > | | | | | | | 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 | int toRead; /* How many bytes to read? */ int charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ char *name; Tcl_Obj *resultPtr; if ((objc != 2) && (objc != 3)) { Interp *iPtr; argerror: iPtr = (Interp *) interp; Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?"); /* * Do not append directly; that makes ensembles using this command as * a subcommand produce the wrong message. */ iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId"); iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; return TCL_ERROR; } i = 1; newline = 0; if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { newline = 1; i++; } if (i == objc) { goto argerror; } name = Tcl_GetString(objv[i]); chan = Tcl_GetChannel(interp, name, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", name, "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } i++; /* Consumed channel name. */ /* * Compute how many bytes to read, and see whether the final newline * should be dropped. */ toRead = -1; if (i < objc) { char *arg; arg = Tcl_GetString(objv[i]); if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { return TCL_ERROR; } } else if (strcmp(arg, "nonewline") == 0) { newline = 1; } else { Tcl_AppendResult(interp, "bad argument \"", arg, "\": should be \"nonewline\"", (char *) NULL); return TCL_ERROR; } } resultPtr = Tcl_NewObj(); Tcl_IncrRefCount(resultPtr); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { /* TIP #219. * Capture error messages put by the driver into the bypass area and * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass (interp, chan)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading \"", name, "\": ", Tcl_PosixError(interp), (char *) NULL); Tcl_DecrRefCount(resultPtr); } return TCL_ERROR; } /* * If requested, remove the last newline in the channel if at EOF. */ if ((charactersRead > 0) && (newline != 0)) { char *result; int length; result = Tcl_GetStringFromObj(resultPtr, &length); if (result[length - 1] == '\n') { Tcl_SetObjLength(resultPtr, length - 1); } } Tcl_SetObjResult(interp, resultPtr); Tcl_DecrRefCount(resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SeekObjCmd -- * * This procedure is invoked to process the Tcl "seek" command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * Moves the position of the access point on the specified channel. May * flush queued output. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SeekObjCmd(clientData, interp, objc, objv) |
︙ | ︙ | |||
443 444 445 446 447 448 449 | return TCL_ERROR; } mode = modeArray[optionIndex]; } result = Tcl_Seek(chan, offset, mode); if (result == Tcl_LongAsWide(-1)) { | > > > > > > | | > > | | | > > | | | > > > > > > > > > > > | | | | 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 | return TCL_ERROR; } mode = modeArray[optionIndex]; } result = Tcl_Seek(chan, offset, mode); if (result == Tcl_LongAsWide(-1)) { /* TIP #219. * Capture error messages put by the driver into the bypass area and * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass (interp, chan)) { Tcl_AppendResult(interp, "error during seek on \"", chanName, "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_TellObjCmd -- * * This procedure is invoked to process the Tcl "tell" command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_TellObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to tell on. */ char *chanName; Tcl_WideInt newLoc; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } /* * Try to find a channel with the right name and permissions in the IO * channel table of this interpreter. */ chanName = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } newLoc = Tcl_Tell(chan); /* TIP #219. * Capture error messages put by the driver into the bypass area and put * them into the regular interpreter result. */ if (TclChanCaughtErrorBypass (interp, chan)) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc)); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_CloseObjCmd -- * * This procedure is invoked to process the Tcl "close" command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * May discard queued input; may flush queued output. * |
︙ | ︙ | |||
536 537 538 539 540 541 542 | arg = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, arg, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { | | | | | | | | | | | | | | | | 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 | arg = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, arg, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { /* * If there is an error message and it ends with a newline, remove the * newline. This is done for command pipeline channels where the error * output from the subprocesses is stored in interp's result. * * NOTE: This is likely to not have any effect on regular error * messages produced by drivers during the closing of a channel, * because the Tcl convention is that such error messages do not have * a terminating newline. */ Tcl_Obj *resultPtr; char *string; int len; resultPtr = Tcl_GetObjResult(interp); if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); Tcl_SetObjResult(interp, resultPtr); } string = Tcl_GetStringFromObj(resultPtr, &len); if ((len > 0) && (string[len - 1] == '\n')) { Tcl_SetObjLength(resultPtr, len - 1); } return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
594 595 596 597 598 599 600 | Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *chanName, *optionName, *valueName; Tcl_Channel chan; /* The channel to set a mode on. */ int i; /* Iterate over arg-value pairs. */ | | | | > | > | | | | | < | | | | | | | | > | | | > | | | | | | | | 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 | Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *chanName, *optionName, *valueName; Tcl_Channel chan; /* The channel to set a mode on. */ int i; /* Iterate over arg-value pairs. */ Tcl_DString ds; /* DString to hold result of calling * Tcl_GetChannelOption. */ if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?optionName? ?value? ?optionName value?..."); return TCL_ERROR; } chanName = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if (objc == 2) { Tcl_DStringInit(&ds); if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) { Tcl_DStringFree(&ds); return TCL_ERROR; } Tcl_DStringResult(interp, &ds); return TCL_OK; } else if (objc == 3) { Tcl_DStringInit(&ds); optionName = Tcl_GetString(objv[2]); if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) { Tcl_DStringFree(&ds); return TCL_ERROR; } Tcl_DStringResult(interp, &ds); return TCL_OK; } for (i = 3; i < objc; i += 2) { optionName = Tcl_GetString(objv[i-1]); valueName = Tcl_GetString(objv[i]); if (Tcl_SetChannelOption(interp, chan, optionName, valueName) != TCL_OK) { return TCL_ERROR; } } return TCL_OK; } /* *--------------------------------------------------------------------------- * * Tcl_EofObjCmd -- * * This procedure is invoked to process the Tcl "eof" command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * Sets interp's result to boolean true or false depending on whether the * specified channel has an EOF condition. * *--------------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_EofObjCmd(unused, interp, objc, objv) ClientData unused; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; int dummy; char *arg; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } arg = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, arg, &dummy); if (chan == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_Eof(chan))); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ExecObjCmd -- * * This procedure is invoked to process the "exec" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
761 762 763 764 765 766 767 | * See if the command is to be run in background. */ background = 0; string = Tcl_GetString(objv[objc - 1]); if ((string[0] == '&') && (string[1] == '\0')) { objc--; | | | | < | | | | | > > > > > > | | | | > > | | | | | | | | | | | | | | | | | | | 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 | * See if the command is to be run in background. */ background = 0; string = Tcl_GetString(objv[objc - 1]); if ((string[0] == '&') && (string[1] == '\0')) { objc--; background = 1; } /* * Create the string argument array "argv". Make sure argv is large enough * to hold the argc arguments plus 1 extra for the zero end-of-argv word. */ argv = argStorage; argc = objc - skip; if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) { argv = (CONST char **) ckalloc((unsigned)(argc + 1) * sizeof(char *)); } /* * Copy the string conversions of each (post option) object into the * argument vector. */ for (i = 0; i < argc; i++) { argv[i] = Tcl_GetString(objv[i + skip]); } argv[argc] = NULL; chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 : TCL_STDOUT | TCL_STDERR)); /* * Free the argv array if malloc'ed storage was used. */ if (argv != argStorage) { ckfree((char *)argv); } if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if (background) { /* * Store the list of PIDs from the pipeline in interp's result and * detach the PIDs (instead of waiting for them). */ TclGetAndDetachPids(interp, chan); if (Tcl_Close(interp, chan) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } resultPtr = Tcl_NewObj(); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { /* TIP #219. * Capture error messages put by the driver into the bypass area * and put them into the regular interpreter result. Fall back to * the regular message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass (interp, chan)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading output from command: ", Tcl_PosixError(interp), (char *) NULL); Tcl_DecrRefCount(resultPtr); } return TCL_ERROR; } } /* * If the process produced anything on stderr, it will have been returned * in the interpreter result. It needs to be appended to the result * string. */ result = Tcl_Close(interp, chan); Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); /* * If the last character of the result is a newline, then remove the * newline character. */ if (keepNewline == 0) { string = Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && (string[length - 1] == '\n')) { Tcl_SetObjLength(resultPtr, length - 1); } } Tcl_SetObjResult(interp, resultPtr); return result; } /* *--------------------------------------------------------------------------- * * Tcl_FblockedObjCmd -- * * This procedure is invoked to process the Tcl "fblocked" command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * Sets interp's result to boolean true or false depending on whether the * preceeding input operation on the channel would have blocked. * *--------------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_FblockedObjCmd(unused, interp, objc, objv) ClientData unused; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; int mode; char *arg; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } arg = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, arg, &mode); if (chan == NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", arg, "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_InputBlocked(chan))); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_OpenObjCmd -- * * This procedure is invoked to process the "open" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
954 955 956 957 958 959 960 | } /* * Open the file or create a process pipeline. */ if (!pipeline) { | | | | | | | | | > | | | | | | | | | | | | > > | > | | | | | | | | | | | | | | | | | | < | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | } /* * Open the file or create a process pipeline. */ if (!pipeline) { chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { int mode, seekFlag, cmdObjc, binary; CONST char **cmdArgv; if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { return TCL_ERROR; } mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); if (mode == -1) { chan = NULL; } else { int flags = TCL_STDERR | TCL_ENFORCE_MODE; switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { case O_RDONLY: flags |= TCL_STDOUT; break; case O_WRONLY: flags |= TCL_STDIN; break; case O_RDWR: flags |= (TCL_STDIN | TCL_STDOUT); break; default: Tcl_Panic("Tcl_OpenCmd: invalid mode value"); break; } chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); if (binary) { Tcl_SetChannelOption(interp, chan, "-translation", "binary"); } } ckfree((char *) cmdArgv); } if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); return TCL_OK; } /* *---------------------------------------------------------------------- * * TcpAcceptCallbacksDeleteProc -- * * Assocdata cleanup routine called when an interpreter is being deleted * to set the interp field of all the accept callback records registered * with the interpreter to NULL. This will prevent the interpreter from * being used in the future to eval accept scripts. * * Results: * None. * * Side effects: * Deallocates memory and sets the interp field of all the accept * callback records to NULL to prevent this interpreter from being used * subsequently to eval accept scripts. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void TcpAcceptCallbacksDeleteProc(clientData, interp) ClientData clientData; /* Data which was passed when the assocdata * was registered. */ Tcl_Interp *interp; /* Interpreter being deleted - not used. */ { Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; AcceptCallback *acceptCallbackPtr; hTblPtr = (Tcl_HashTable *) clientData; for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != (Tcl_HashEntry *) NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); acceptCallbackPtr->interp = (Tcl_Interp *) NULL; } Tcl_DeleteHashTable(hTblPtr); ckfree((char *) hTblPtr); } /* *---------------------------------------------------------------------- * * RegisterTcpServerInterpCleanup -- * * Registers an accept callback record to have its interp field set to * NULL when the interpreter is deleted. * * Results: * None. * * Side effects: * When, in the future, the interpreter is deleted, the interp field of * the accept callback data structure will be set to NULL. This will * prevent attempts to eval the accept script in a deleted interpreter. * *---------------------------------------------------------------------- */ static void RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) Tcl_Interp *interp; /* Interpreter for which we want to be * informed of deletion. */ AcceptCallback *acceptCallbackPtr; /* The accept callback record whose interp * field we want set to NULL when the * interpreter is deleted. */ { Tcl_HashTable *hTblPtr; /* Hash table for accept callback records to * smash when the interpreter will be * deleted. */ Tcl_HashEntry *hPtr; /* Entry for this record. */ int new; /* Is the entry new? */ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); if (hTblPtr == (Tcl_HashTable *) NULL) { hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); } hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new); if (!new) { Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); } Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr); } /* *---------------------------------------------------------------------- * * UnregisterTcpServerInterpCleanupProc -- * * Unregister a previously registered accept callback record. The interp * field of this record will no longer be set to NULL in the future when * the interpreter is deleted. * * Results: * None. * * Side effects: * Prevents the interp field of the accept callback record from being set * to NULL in the future when the interpreter is deleted. * *---------------------------------------------------------------------- */ static void UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) Tcl_Interp *interp; /* Interpreter in which the accept callback * record was registered. */ AcceptCallback *acceptCallbackPtr; /* The record for which to delete the * registration. */ { Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); if (hTblPtr == (Tcl_HashTable *) NULL) { return; } hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); if (hPtr == (Tcl_HashEntry *) NULL) { return; } Tcl_DeleteHashEntry(hPtr); } /* *---------------------------------------------------------------------- * * AcceptCallbackProc -- * * This callback is invoked by the TCP channel driver when it accepts a * new connection from a client on a server socket. * * Results: * None. * * Side effects: * Whatever the script does. * *---------------------------------------------------------------------- */ static void AcceptCallbackProc(callbackData, chan, address, port) ClientData callbackData; /* The data stored when the callback * was created in the call to * Tcl_OpenTcpServer. */ Tcl_Channel chan; /* Channel for the newly accepted * connection. */ char *address; /* Address of client that was * accepted. */ int port; /* Port of client that was accepted. */ { AcceptCallback *acceptCallbackPtr; Tcl_Interp *interp; char *script; char portBuf[TCL_INTEGER_SPACE]; int result; acceptCallbackPtr = (AcceptCallback *) callbackData; /* * Check if the callback is still valid; the interpreter may have gone * away, this is signalled by setting the interp field of the callback * data to NULL. */ if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { script = acceptCallbackPtr->script; interp = acceptCallbackPtr->interp; Tcl_Preserve((ClientData) script); Tcl_Preserve((ClientData) interp); TclFormatInt(portBuf, port); Tcl_RegisterChannel(interp, chan); /* * Artificially bump the refcount to protect the channel from being * deleted while the script is being evaluated. */ Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), " ", address, " ", portBuf, (char *) NULL); if (result != TCL_OK) { Tcl_BackgroundError(interp); Tcl_UnregisterChannel(interp, chan); } /* * Decrement the artificially bumped refcount. After this it is not * safe anymore to use "chan", because it may now be deleted. */ Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan); Tcl_Release((ClientData) interp); Tcl_Release((ClientData) script); } else { /* * The interpreter has been deleted, so there is no useful way to * utilize the client socket - just close it. */ Tcl_Close((Tcl_Interp *) NULL, chan); } } /* *---------------------------------------------------------------------- * * TcpServerCloseProc -- * * This callback is called when the TCP server channel for which it was * registered is being closed. It informs the interpreter in which the * accept script is evaluated (if that interpreter still exists) that * this channel no longer needs to be informed if the interpreter is * deleted. * * Results: * None. * * Side effects: * In the future, if the interpreter is deleted this channel will no * longer be informed. * *---------------------------------------------------------------------- */ static void TcpServerCloseProc(callbackData) ClientData callbackData; /* The data passed in the call to * Tcl_CreateCloseHandler. */ { AcceptCallback *acceptCallbackPtr; /* The actual data. */ acceptCallbackPtr = (AcceptCallback *) callbackData; if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, acceptCallbackPtr); } Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC); ckfree((char *) acceptCallbackPtr); } /* *---------------------------------------------------------------------- * * Tcl_SocketObjCmd -- * * This procedure is invoked to process the "socket" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * Creates a socket based channel. * |
︙ | ︙ | |||
1284 1285 1286 1287 1288 1289 1290 | int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *socketOptions[] = { "-async", "-myaddr", "-myport","-server", (char *) NULL }; enum socketOptions { | | | | | | | | | | | | < | | | | | < | | | | < | | > | | | | < | | | | < | | | | | | | | | | | | | | | | < | | | | < | | < | > > | | | | > | | < > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *socketOptions[] = { "-async", "-myaddr", "-myport","-server", (char *) NULL }; enum socketOptions { SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER }; int optionIndex, a, server, port; char *arg, *copyScript, *host, *script; char *myaddr = NULL; int myport = 0; int async = 0; Tcl_Channel chan; AcceptCallback *acceptCallbackPtr; server = 0; script = NULL; if (TclpHasSockets(interp) != TCL_OK) { return TCL_ERROR; } for (a = 1; a < objc; a++) { arg = Tcl_GetString(objv[a]); if (arg[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option", TCL_EXACT, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum socketOptions) optionIndex) { case SKT_ASYNC: if (server == 1) { Tcl_AppendResult(interp, "cannot set -async option for server sockets", (char *) NULL); return TCL_ERROR; } async = 1; break; case SKT_MYADDR: a++; if (a >= objc) { Tcl_AppendResult(interp, "no argument given for -myaddr option", (char *) NULL); return TCL_ERROR; } myaddr = Tcl_GetString(objv[a]); break; case SKT_MYPORT: { char *myPortName; a++; if (a >= objc) { Tcl_AppendResult(interp, "no argument given for -myport option", (char *) NULL); return TCL_ERROR; } myPortName = Tcl_GetString(objv[a]); if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) { return TCL_ERROR; } break; } case SKT_SERVER: if (async == 1) { Tcl_AppendResult(interp, "cannot set -async option for server sockets", (char *) NULL); return TCL_ERROR; } server = 1; a++; if (a >= objc) { Tcl_AppendResult(interp, "no argument given for -server option", (char *) NULL); return TCL_ERROR; } script = Tcl_GetString(objv[a]); break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); } } if (server) { host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { Tcl_AppendResult(interp, "Option -myport is not valid for servers", NULL); return TCL_ERROR; } } else if (a < objc) { host = Tcl_GetString(objv[a]); a++; } else { Interp *iPtr; wrongNumArgs: iPtr = (Interp *) interp; Tcl_WrongNumArgs(interp, 1, objv, "?-myaddr addr? ?-myport myport? ?-async? host port"); iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, "-server command ?-myaddr addr? port"); iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; return TCL_ERROR; } if (a == objc-1) { if (TclSockGetPort(interp, Tcl_GetString(objv[a]), "tcp", &port) != TCL_OK) { return TCL_ERROR; } } else { goto wrongNumArgs; } if (server) { acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) sizeof(AcceptCallback)); copyScript = ckalloc((unsigned) strlen(script) + 1); strcpy(copyScript, script); acceptCallbackPtr->script = copyScript; acceptCallbackPtr->interp = interp; chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, (ClientData) acceptCallbackPtr); if (chan == (Tcl_Channel) NULL) { ckfree(copyScript); ckfree((char *) acceptCallbackPtr); return TCL_ERROR; } /* * Register with the interpreter to let us know when the interpreter * is deleted (by having the callback set the interp field of the * acceptCallbackPtr's structure to NULL). This is to avoid trying to * eval the script in a deleted interpreter. */ RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); /* * Register a close callback. This callback will inform the * interpreter (if it still exists) that this channel does not need to * be informed when the interpreter is deleted. */ Tcl_CreateCloseHandler(chan, TcpServerCloseProc, (ClientData) acceptCallbackPtr); } else { chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } } Tcl_RegisterChannel(interp, chan); Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_FcopyObjCmd -- * * This procedure is invoked to process the "fcopy" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * Moves data between two channels and possibly sets up a background copy * handler. * *---------------------------------------------------------------------- */ int Tcl_FcopyObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
1485 1486 1487 1488 1489 1490 1491 | if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { Tcl_WrongNumArgs(interp, 1, objv, "input output ?-size size? ?-command callback?"); return TCL_ERROR; } /* | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { Tcl_WrongNumArgs(interp, 1, objv, "input output ?-size size? ?-command callback?"); return TCL_ERROR; } /* * Parse the channel arguments and verify that they are readable or * writable, as appropriate. */ arg = Tcl_GetString(objv[1]); inChan = Tcl_GetChannel(interp, arg, &mode); if (inChan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", arg, "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } arg = Tcl_GetString(objv[2]); outChan = Tcl_GetChannel(interp, arg, &mode); if (outChan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { Tcl_AppendResult(interp, "channel \"", arg, "\" wasn't opened for writing", (char *) NULL); return TCL_ERROR; } toRead = -1; cmdPtr = NULL; for (i = 3; i < objc; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0, (int *) &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case FcopySize: if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { return TCL_ERROR; } break; case FcopyCommand: cmdPtr = objv[i+1]; break; } } return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr); } /* *---------------------------------------------------------------------- * * Tcl_ChanTruncateObjCmd -- * * This procedure is invoked to process the "chan truncate" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * Truncates a channel (or rather a file underlying a channel). * *---------------------------------------------------------------------- */ int TclChanTruncateObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; int mode; Tcl_WideInt length; char *chanName; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?length?"); return TCL_ERROR; } chanName = TclGetString(objv[1]); chan = Tcl_GetChannel(interp, chanName, &mode); if (chan == NULL) { return TCL_ERROR; } if (objc == 3) { /* * User is supplying an explicit length. */ if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) { return TCL_ERROR; } if (length < 0) { Tcl_AppendResult(interp, "cannot truncate to negative length of file", NULL); return TCL_ERROR; } } else { /* * User wants to truncate to the current file position. */ length = Tcl_Tell(chan); if (length == Tcl_WideAsLong(-1)) { Tcl_AppendResult(interp, "could not determine current location in \"", chanName, "\": ", Tcl_PosixError(interp), NULL); return TCL_ERROR; } } if (Tcl_TruncateChannel(chan, length) != TCL_OK) { Tcl_AppendResult(interp, "error during truncate on \"", chanName, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclIOGT.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclIOGT.c -- * * Implements a generic transformation exposing the underlying API * at the script level. Contributed by Andreas Kupries. * * Copyright (c) 2000 Ajuba Solutions * Copyright (c) 1999-2000 Andreas Kupries ([email protected]) * * See the file "license.terms" for information on usage and redistribution * of this file, and 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 | /* * tclIOGT.c -- * * Implements a generic transformation exposing the underlying API * at the script level. Contributed by Andreas Kupries. * * Copyright (c) 2000 Ajuba Solutions * Copyright (c) 1999-2000 Andreas Kupries ([email protected]) * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * CVS: $Id: tclIOGT.c,v 1.12.2.1 2005/08/02 18:15:32 dgp Exp $ */ #include "tclInt.h" #include "tclIO.h" /* * Forward declarations of internal procedures. First the driver procedures * of the transformation. */ static int TransformBlockModeProc _ANSI_ARGS_(( ClientData instanceData, int mode)); static int TransformCloseProc _ANSI_ARGS_(( ClientData instanceData, Tcl_Interp* interp)); static int TransformInputProc _ANSI_ARGS_(( ClientData instanceData, char *buf, int toRead, int *errorCodePtr)); static int TransformOutputProc _ANSI_ARGS_(( ClientData instanceData, CONST char *buf, int toWrite, int *errorCodePtr)); static int TransformSeekProc _ANSI_ARGS_(( ClientData instanceData, long offset, int mode, int *errorCodePtr)); static int TransformSetOptionProc _ANSI_ARGS_(( ClientData instanceData, Tcl_Interp *interp, CONST char *optionName, CONST char *value)); static int TransformGetOptionProc _ANSI_ARGS_(( ClientData instanceData, Tcl_Interp *interp, CONST char *optionName, Tcl_DString *dsPtr)); static void TransformWatchProc _ANSI_ARGS_(( ClientData instanceData, int mask)); static int TransformGetFileHandleProc _ANSI_ARGS_(( ClientData instanceData, int direction, ClientData *handlePtr)); static int TransformNotifyProc _ANSI_ARGS_(( ClientData instanceData, int mask)); static Tcl_WideInt TransformWideSeekProc _ANSI_ARGS_(( ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCodePtr)); /* * Forward declarations of internal procedures. Secondly the procedures for * handling and generating fileeevents. */ static void TransformChannelHandlerTimer _ANSI_ARGS_(( ClientData clientData)); /* * Forward declarations of internal procedures. Third, helper procedures * encapsulating essential tasks. */ typedef struct TransformChannelData TransformChannelData; static int ExecuteCallback _ANSI_ARGS_(( TransformChannelData *ctrl, Tcl_Interp *interp, unsigned char *op, unsigned char *buf, int bufLen, int transmit, int preserve)); /* * Action codes to give to 'ExecuteCallback' (argument 'transmit') confering * to the procedure what to do with the result of the script it calls. */ #define TRANSMIT_DONT (0) /* No transfer to do */ #define TRANSMIT_DOWN (1) /* Transfer to the underlying channel */ #define TRANSMIT_SELF (2) /* Transfer into our channel. */ #define TRANSMIT_IBUF (3) /* Transfer to internal input buffer */ #define TRANSMIT_NUM (4) /* Transfer number to 'maxRead' */ /* * Codes for 'preserve' of 'ExecuteCallback' */ #define P_PRESERVE (1) #define P_NO_PRESERVE (0) /* * Strings for the action codes delivered to the script implementing a * transformation. Argument 'op' of 'ExecuteCallback'. */ #define A_CREATE_WRITE (UCHARP("create/write")) #define A_DELETE_WRITE (UCHARP("delete/write")) #define A_FLUSH_WRITE (UCHARP("flush/write")) #define A_WRITE (UCHARP("write")) #define A_CREATE_READ (UCHARP("create/read")) #define A_DELETE_READ (UCHARP("delete/read")) #define A_FLUSH_READ (UCHARP("flush/read")) #define A_READ (UCHARP("read")) #define A_QUERY_MAXREAD (UCHARP("query/maxRead")) #define A_CLEAR_READ (UCHARP("clear/read")) /* * Management of a simple buffer. */ typedef struct ResultBuffer ResultBuffer; static void ResultClear _ANSI_ARGS_((ResultBuffer *r)); static void ResultInit _ANSI_ARGS_((ResultBuffer *r)); static int ResultLength _ANSI_ARGS_((ResultBuffer *r)); static int ResultCopy _ANSI_ARGS_((ResultBuffer *r, unsigned char *buf, int toRead)); static void ResultAdd _ANSI_ARGS_((ResultBuffer *r, unsigned char *buf, int toWrite)); /* * This structure describes the channel type structure for Tcl based * transformations. */ static Tcl_ChannelType transformChannelType = { "transform", /* Type name. */ TCL_CHANNEL_VERSION_3, TransformCloseProc, /* Close proc. */ |
︙ | ︙ | |||
154 155 156 157 158 159 160 | /* * Definition of the structure containing the information about the * internal input buffer. */ struct ResultBuffer { | | | | > | | | | | | < | | | | | | | | | | > | | | | | | | | | | | < | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | < | | | | < | | | | | > | | | | | | | | | | | | | | 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 | /* * Definition of the structure containing the information about the * internal input buffer. */ struct ResultBuffer { unsigned char *buf; /* Reference to the buffer area. */ int allocated; /* Allocated size of the buffer area. */ int used; /* Number of bytes in the buffer, <= * allocated. */ }; /* * Additional bytes to allocate during buffer expansion */ #define INCREMENT (512) /* * Number of milliseconds to wait before firing an event to flush out * information waiting in buffers (fileevent support). */ #define FLUSH_DELAY (5) /* * Convenience macro to make some casts easier to use. */ #define UCHARP(x) ((unsigned char *) (x)) #define NO_INTERP ((Tcl_Interp *) NULL) /* * Definition of a structure used by all transformations generated here to * maintain their local state. */ struct TransformChannelData { /* * General section. Data to integrate the transformation into the channel * system. */ Tcl_Channel self; /* Our own Channel handle. */ int readIsFlushed; /* Flag to note whether in.flushProc was * called or not. */ int flags; /* Currently CHANNEL_ASYNC or zero. */ int watchMask; /* Current watch/event/interest mask. */ int mode; /* Mode of parent channel, OR'ed combination * of TCL_READABLE, TCL_WRITABLE. */ Tcl_TimerToken timer; /* Timer for automatic flushing of information * sitting in an internal buffer. Required for * full fileevent support. */ /* * Transformation specific data. */ int maxRead; /* Maximum allowed number of bytes to read, as * given to us by the tcl script implementing * the transformation. */ Tcl_Interp *interp; /* Reference to the interpreter which created * the transformation. Used to execute the * code below. */ Tcl_Obj *command; /* Tcl code to execute for a buffer */ ResultBuffer result; /* Internal buffer used to store the result of * a transformation of incoming data. * Additionally serves as buffer of all data * not yet consumed by the reader. */ }; /* *---------------------------------------------------------------------- * * TclChannelTransform -- * * Implements the Tcl "testchannel transform" debugging command. This is * part of the testing environment. This sets up a tcl script (cmdObjPtr) * to be used as a transform on the channel. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int TclChannelTransform(interp, chan, cmdObjPtr) Tcl_Interp *interp; /* Interpreter for result. */ Tcl_Channel chan; /* Channel to transform. */ Tcl_Obj *cmdObjPtr; /* Script to use for transform. */ { Channel *chanPtr; /* The actual channel. */ ChannelState *statePtr; /* state info for channel */ int mode; /* rw mode of the channel */ TransformChannelData *dataPtr; int res; Tcl_DString ds; if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } chanPtr = (Channel *) chan; statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; chan = (Tcl_Channel) chanPtr; mode = (statePtr->flags & (TCL_READABLE|TCL_WRITABLE)); /* * Now initialize the transformation state and stack it upon the specified * channel. One of the necessary things to do is to retrieve the blocking * regime of the underlying channel and to use the same for us too. */ dataPtr = (TransformChannelData *) ckalloc(sizeof(TransformChannelData)); Tcl_DStringInit (&ds); Tcl_GetChannelOption(interp, chan, "-blocking", &ds); dataPtr->readIsFlushed = 0; dataPtr->flags = 0; if (ds.string[0] == '0') { dataPtr->flags |= CHANNEL_ASYNC; } Tcl_DStringFree(&ds); dataPtr->self = chan; dataPtr->watchMask = 0; dataPtr->mode = mode; dataPtr->timer = (Tcl_TimerToken) NULL; dataPtr->maxRead = 4096; /* Initial value not relevant */ dataPtr->interp = interp; dataPtr->command = cmdObjPtr; Tcl_IncrRefCount(dataPtr->command); ResultInit(&dataPtr->result); dataPtr->self = Tcl_StackChannel(interp, &transformChannelType, (ClientData) dataPtr, mode, chan); if (dataPtr->self == (Tcl_Channel) NULL) { Tcl_AppendResult(interp, "\nfailed to stack channel \"", Tcl_GetChannelName(chan), "\"", (char *) NULL); Tcl_DecrRefCount(dataPtr->command); ResultClear(&dataPtr->result); ckfree((char *) dataPtr); return TCL_ERROR; } /* * At last initialize the transformation at the script level. */ if (dataPtr->mode & TCL_WRITABLE) { res = ExecuteCallback(dataPtr, NO_INTERP, A_CREATE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); if (res != TCL_OK) { Tcl_UnstackChannel(interp, chan); return TCL_ERROR; } } if (dataPtr->mode & TCL_READABLE) { res = ExecuteCallback(dataPtr, NO_INTERP, A_CREATE_READ, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); if (res != TCL_OK) { ExecuteCallback(dataPtr, NO_INTERP, A_DELETE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); Tcl_UnstackChannel(interp, chan); return TCL_ERROR; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * ExecuteCallback -- * * Executes the defined callback for buffer and operation. * * Side effects: * As of the executed tcl script. * * Result: * A standard TCL error code. In case of an error a message is left in * the result area of the specified interpreter. * *---------------------------------------------------------------------- */ static int ExecuteCallback(dataPtr, interp, op, buf, bufLen, transmit, preserve) TransformChannelData *dataPtr; /* Transformation with the callback */ Tcl_Interp *interp; /* Current interpreter, possibly * NULL. */ unsigned char *op; /* Operation invoking the callback */ unsigned char *buf; /* Buffer to give to the script. */ int bufLen; /* And its length */ int transmit; /* Flag, determines whether the result * of the callback is sent to the * underlying channel or not. */ int preserve; /* Flag. If true the procedure will * preserver the result state of all * accessed interpreters. */ { /* * Step 1, create the complete command to execute. Do this by appending * operation and buffer to operate upon to a copy of the callback * definition. We *cannot* create a list containing 3 objects and then use * 'Tcl_EvalObjv', because the command may contain additional prefixed * arguments. Feather's curried commands would come in handy here. */ Tcl_Obj *resObj; /* See below, switch (transmit) */ int resLen; unsigned char *resBuf; Tcl_InterpState state = NULL; int res = TCL_OK; Tcl_Obj *command = Tcl_DuplicateObj(dataPtr->command); Tcl_Obj *temp; if (preserve) { state = Tcl_SaveInterpState(dataPtr->interp, res); } if (command == (Tcl_Obj*) NULL) { /* Memory allocation problem */ |
︙ | ︙ | |||
410 411 412 413 414 415 416 | res = Tcl_ListObjAppendElement(dataPtr->interp, command, temp); if (res != TCL_OK) { goto cleanup; } /* | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | < | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | > | | | | | | | | | | | | > | | | | | < | | | | | | > | | | | > | | | | | | | < | | | | | | | | | > | | < | | | | | | < | | | | < | < | | | | | | | | | | > | | | | | | | | | | | | | | | < | | | | | < < | | < | < | | < | | | | | | | > | | | | | > > | | | < | | | | | | | | | | | < | | | | | | | | | | | | > > > | | | < | | | | | | > | | > | | < | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | > | | | | | | | | | < | | < | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | < | | | | | < | | | | | > | > | | > | | < | | > | | | | | | < | | | | | | | | | > | | | > > > > > > > > | 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 | res = Tcl_ListObjAppendElement(dataPtr->interp, command, temp); if (res != TCL_OK) { goto cleanup; } /* * Use a byte-array to prevent the misinterpretation of binary data coming * through as UTF while at the tcl level. */ temp = Tcl_NewByteArrayObj(buf, bufLen); if (temp == (Tcl_Obj*) NULL) { /* Memory allocation problem */ res = TCL_ERROR; goto cleanup; } res = Tcl_ListObjAppendElement(dataPtr->interp, command, temp); if (res != TCL_OK) { goto cleanup; } /* * Step 2, execute the command at the global level of the interpreter used * to create the transformation. Destroy the command afterward. If an * error occured and the current interpreter is defined and not equal to * the interpreter for the callback, then copy the error message into * current interpreter. Don't copy if in preservation mode. */ res = Tcl_GlobalEvalObj(dataPtr->interp, command); Tcl_DecrRefCount(command); command = (Tcl_Obj*) NULL; if ((res != TCL_OK) && (interp != NO_INTERP) && (dataPtr->interp != interp) && !preserve) { Tcl_SetObjResult(interp, Tcl_GetObjResult(dataPtr->interp)); return res; } /* * Step 3, transmit a possible conversion result to the underlying * channel, or ourselves. */ switch (transmit) { case TRANSMIT_DONT: /* nothing to do */ break; case TRANSMIT_DOWN: resObj = Tcl_GetObjResult(dataPtr->interp); resBuf = (unsigned char *) Tcl_GetByteArrayFromObj(resObj, &resLen); Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf, resLen); break; case TRANSMIT_SELF: resObj = Tcl_GetObjResult(dataPtr->interp); resBuf = (unsigned char *) Tcl_GetByteArrayFromObj(resObj, &resLen); Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); break; case TRANSMIT_IBUF: resObj = Tcl_GetObjResult(dataPtr->interp); resBuf = (unsigned char *) Tcl_GetByteArrayFromObj(resObj, &resLen); ResultAdd(&dataPtr->result, resBuf, resLen); break; case TRANSMIT_NUM: /* Interpret result as integer number */ resObj = Tcl_GetObjResult(dataPtr->interp); Tcl_GetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead); break; } Tcl_ResetResult(dataPtr->interp); if (preserve) { (void) Tcl_RestoreInterpState(dataPtr->interp, state); } return res; cleanup: if (preserve) { (void) Tcl_RestoreInterpState(dataPtr->interp, state); } if (command != (Tcl_Obj*) NULL) { Tcl_DecrRefCount(command); } return res; } /* *---------------------------------------------------------------------- * * TransformBlockModeProc -- * * Trap handler. Called by the generic IO system during option processing * to change the blocking mode of the channel. * * Side effects: * Forwards the request to the underlying channel. * * Result: * 0 if successful, errno when failed. * *---------------------------------------------------------------------- */ static int TransformBlockModeProc(instanceData, mode) ClientData instanceData; /* State of transformation */ int mode; /* New blocking mode */ { TransformChannelData *dataPtr = (TransformChannelData *) instanceData; if (mode == TCL_MODE_NONBLOCKING) { dataPtr->flags |= CHANNEL_ASYNC; } else { dataPtr->flags &= ~(CHANNEL_ASYNC); } return 0; } /* *---------------------------------------------------------------------- * * TransformCloseProc -- * * Trap handler. Called by the generic IO system during destruction of * the transformation channel. * * Side effects: * Releases the memory allocated in 'Tcl_TransformObjCmd'. * * Result: * None. * *---------------------------------------------------------------------- */ static int TransformCloseProc(instanceData, interp) ClientData instanceData; Tcl_Interp *interp; { TransformChannelData *dataPtr = (TransformChannelData *) instanceData; /* * Important: In this procedure 'dataPtr->self' already points to the * underlying channel. */ /* * There is no need to cancel an existing channel handler, this is already * done. Either by 'Tcl_UnstackChannel' or by the general cleanup in * 'Tcl_Close'. * * But we have to cancel an active timer to prevent it from firing on the * removed channel. */ if (dataPtr->timer != (Tcl_TimerToken) NULL) { Tcl_DeleteTimerHandler(dataPtr->timer); dataPtr->timer = (Tcl_TimerToken) NULL; } /* * Now flush data waiting in internal buffers to output and input. The * input must be done despite the fact that there is no real receiver for * it anymore. But the scripts might have sideeffects other parts of the * system rely on (f.e. signaling the close to interested parties). */ if (dataPtr->mode & TCL_WRITABLE) { ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, 1); } if ((dataPtr->mode & TCL_READABLE) && !dataPtr->readIsFlushed) { dataPtr->readIsFlushed = 1; ExecuteCallback(dataPtr, interp, A_FLUSH_READ, NULL, 0, TRANSMIT_IBUF, 1); } if (dataPtr->mode & TCL_WRITABLE) { ExecuteCallback(dataPtr, interp, A_DELETE_WRITE, NULL, 0, TRANSMIT_DONT, 1); } if (dataPtr->mode & TCL_READABLE) { ExecuteCallback(dataPtr, interp, A_DELETE_READ, NULL, 0, TRANSMIT_DONT, 1); } /* * General cleanup */ ResultClear(&dataPtr->result); Tcl_DecrRefCount(dataPtr->command); ckfree((char *) dataPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TransformInputProc -- * * Called by the generic IO system to convert read data. * * Side effects: * As defined by the conversion. * * Result: * A transformed buffer. * *---------------------------------------------------------------------- */ static int TransformInputProc(instanceData, buf, toRead, errorCodePtr) ClientData instanceData; char *buf; int toRead; int *errorCodePtr; { TransformChannelData* dataPtr = (TransformChannelData *) instanceData; int gotBytes, read, res, copied; Tcl_Channel downChan; /* should assert (dataPtr->mode & TCL_READABLE) */ if (toRead == 0) { /* * Catch a no-op. */ return 0; } gotBytes = 0; downChan = Tcl_GetStackedChannel(dataPtr->self); while (toRead > 0) { /* * Loop until the request is satisfied (or no data is available from * below, possibly EOF). */ copied = ResultCopy(&dataPtr->result, UCHARP(buf), toRead); toRead -= copied; buf += copied; gotBytes += copied; if (toRead == 0) { /* * The request was completely satisfied from our buffers. We can * break out of the loop and return to the caller. */ return gotBytes; } /* * Length (dataPtr->result) == 0, toRead > 0 here. Use the incoming * 'buf'! as target to store the intermediary information read from * the underlying channel. * * Ask the tcl level how much data it allows us to read from the * underlying channel. This feature allows the transform to signal EOF * upstream although there is none downstream. Useful to control an * unbounded 'fcopy', either through counting bytes, or by pattern * matching. */ ExecuteCallback(dataPtr, NO_INTERP, A_QUERY_MAXREAD, NULL, 0, TRANSMIT_NUM /* -> maxRead */, 1); if (dataPtr->maxRead >= 0) { if (dataPtr->maxRead < toRead) { toRead = dataPtr->maxRead; } } /* else: 'maxRead < 0' == Accept the current value of toRead */ if (toRead <= 0) { return gotBytes; } read = Tcl_ReadRaw(downChan, buf, toRead); if (read < 0) { /* * Report errors to caller. EAGAIN is a special situation. If we * had some data before we report that instead of the request to * re-try. */ if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) { return gotBytes; } *errorCodePtr = Tcl_GetErrno(); return -1; } if (read == 0) { /* * Check wether we hit on EOF in the underlying channel or not. If * not differentiate between blocking and non-blocking modes. In * non-blocking mode we ran temporarily out of data. Signal this * to the caller via EWOULDBLOCK and error return (-1). In the * other cases we simply return what we got and let the caller * wait for more. On the other hand, if we got an EOF we have to * convert and flush all waiting partial data. */ if (! Tcl_Eof(downChan)) { if ((gotBytes == 0) && (dataPtr->flags & CHANNEL_ASYNC)) { *errorCodePtr = EWOULDBLOCK; return -1; } else { return gotBytes; } } else { if (dataPtr->readIsFlushed) { /* * Already flushed, nothing to do anymore. */ return gotBytes; } dataPtr->readIsFlushed = 1; ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_READ, NULL, 0, TRANSMIT_IBUF, P_PRESERVE); if (ResultLength(&dataPtr->result) == 0) { /* we had nothing to flush */ return gotBytes; } continue; /* at: while (toRead > 0) */ } } /* read == 0 */ /* * Transform the read chunk and add the result to our read buffer * (dataPtr->result) */ res = ExecuteCallback(dataPtr, NO_INTERP, A_READ, UCHARP(buf), read, TRANSMIT_IBUF, P_PRESERVE); if (res != TCL_OK) { *errorCodePtr = EINVAL; return -1; } } /* while toRead > 0 */ return gotBytes; } /* *---------------------------------------------------------------------- * * TransformOutputProc -- * * Called by the generic IO system to convert data waiting to be written. * * Side effects: * As defined by the transformation. * * Result: * A transformed buffer. * *---------------------------------------------------------------------- */ static int TransformOutputProc(instanceData, buf, toWrite, errorCodePtr) ClientData instanceData; CONST char *buf; int toWrite; int *errorCodePtr; { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; int res; /* should assert (dataPtr->mode & TCL_WRITABLE) */ if (toWrite == 0) { /* * Catch a no-op. */ return 0; } res = ExecuteCallback(dataPtr, NO_INTERP, A_WRITE, UCHARP(buf), toWrite, TRANSMIT_DOWN, P_NO_PRESERVE); if (res != TCL_OK) { *errorCodePtr = EINVAL; return -1; } return toWrite; } /* *---------------------------------------------------------------------- * * TransformSeekProc -- * * This procedure is called by the generic IO level to move the access * point in a channel. * * Side effects: * Moves the location at which the channel will be accessed in future * operations. Flushes all transformation buffers, then forwards it to * the underlying channel. * * Result: * -1 if failed, the new position if successful. An output argument * contains the POSIX error code if an error occurred, or zero. * *---------------------------------------------------------------------- */ static int TransformSeekProc(instanceData, offset, mode, errorCodePtr) ClientData instanceData; /* The channel to manipulate */ long offset; /* Size of movement. */ int mode; /* How to move */ int *errorCodePtr; /* Location of error flag. */ { TransformChannelData *dataPtr = (TransformChannelData *) instanceData; Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType); if ((offset == 0) && (mode == SEEK_CUR)) { /* * This is no seek but a request to tell the caller the current * location. Simply pass the request down. */ return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent), offset, mode, errorCodePtr); } /* * It is a real request to change the position. Flush all data waiting for * output and discard everything in the input buffers. Then pass the * request down, unchanged. */ if (dataPtr->mode & TCL_WRITABLE) { ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); } if (dataPtr->mode & TCL_READABLE) { ExecuteCallback(dataPtr, NO_INTERP, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; } return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent), offset, mode, errorCodePtr); } /* *---------------------------------------------------------------------- * * TransformWideSeekProc -- * * This procedure is called by the generic IO level to move the access * point in a channel, with a (potentially) 64-bit offset. * * Side effects: * Moves the location at which the channel will be accessed in future * operations. Flushes all transformation buffers, then forwards it to * the underlying channel. * * Result: * -1 if failed, the new position if successful. An output argument * contains the POSIX error code if an error occurred, or zero. * *---------------------------------------------------------------------- */ static Tcl_WideInt TransformWideSeekProc(instanceData, offset, mode, errorCodePtr) ClientData instanceData; /* The channel to manipulate */ Tcl_WideInt offset; /* Size of movement. */ int mode; /* How to move */ int *errorCodePtr; /* Location of error flag. */ { TransformChannelData * dataPtr = (TransformChannelData *) instanceData; Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); Tcl_ChannelType* parentType = Tcl_GetChannelType(parent); Tcl_DriverSeekProc* parentSeekProc = Tcl_ChannelSeekProc(parentType); Tcl_DriverWideSeekProc* parentWideSeekProc = Tcl_ChannelWideSeekProc(parentType); ClientData parentData = Tcl_GetChannelInstanceData(parent); if ((offset == Tcl_LongAsWide(0)) && (mode == SEEK_CUR)) { /* * This is no seek but a request to tell the caller the current * location. Simply pass the request down. */ if (parentWideSeekProc != NULL) { return (*parentWideSeekProc) (parentData, offset, mode, errorCodePtr); } return Tcl_LongAsWide((*parentSeekProc) (parentData, 0, mode, errorCodePtr)); } /* * It is a real request to change the position. Flush all data waiting for * output and discard everything in the input buffers. Then pass the * request down, unchanged. */ if (dataPtr->mode & TCL_WRITABLE) { ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); } if (dataPtr->mode & TCL_READABLE) { ExecuteCallback(dataPtr, NO_INTERP, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; } /* * If we have a wide seek capability, we should stick with that. */ if (parentWideSeekProc != NULL) { return (*parentWideSeekProc) (parentData, offset, mode, errorCodePtr); } /* * We're transferring to narrow seeks at this point; this is a bit complex * because we have to check whether the seek is possible first (i.e. * whether we are losing information in truncating the bits of the * offset.) Luckily, there's a defined error for what happens when trying * to go out of the representable range. */ if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) { *errorCodePtr = EOVERFLOW; return Tcl_LongAsWide(-1); } return Tcl_LongAsWide((*parentSeekProc) (parentData, Tcl_WideAsLong(offset), mode, errorCodePtr)); } /* *---------------------------------------------------------------------- * * TransformSetOptionProc -- * * Called by generic layer to handle the reconfiguration of channel * specific options. As this channel type does not have such, it simply * passes all requests downstream. * * Side effects: * As defined by the channel downstream. * * Result: * A standard TCL error code. * *---------------------------------------------------------------------- */ static int TransformSetOptionProc(instanceData, interp, optionName, value) ClientData instanceData; Tcl_Interp *interp; CONST char *optionName; CONST char *value; { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self); Tcl_DriverSetOptionProc *setOptionProc; setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan)); if (setOptionProc != NULL) { return (*setOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, value); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TransformGetOptionProc -- * * Called by generic layer to handle requests for the values of channel * specific options. As this channel type does not have such, it simply * passes all requests downstream. * * Side effects: * As defined by the channel downstream. * * Result: * A standard TCL error code. * *---------------------------------------------------------------------- */ static int TransformGetOptionProc(instanceData, interp, optionName, dsPtr) ClientData instanceData; Tcl_Interp *interp; CONST char *optionName; Tcl_DString *dsPtr; { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self); Tcl_DriverGetOptionProc *getOptionProc; getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan)); if (getOptionProc != NULL) { return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, dsPtr); } else if (optionName == (CONST char*) NULL) { /* * Request is query for all options, this is ok. */ return TCL_OK; } /* * Request for a specific option has to fail, we don't have any. */ return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TransformWatchProc -- * * Initialize the notifier to watch for events from this channel. * * Side effects: * Sets up the notifier so that a future event on the channel will be * seen by Tcl. * * Result: * None. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void TransformWatchProc(instanceData, mask) ClientData instanceData; /* Channel to watch */ int mask; /* Events of interest */ { /* * The caller expressed interest in events occuring for this channel. We * are forwarding the call to the underlying channel now. */ TransformChannelData *dataPtr = (TransformChannelData *) instanceData; Tcl_Channel downChan; dataPtr->watchMask = mask; /* * No channel handlers any more. We will be notified automatically about * events on the channel below via a call to our 'TransformNotifyProc'. * But we have to pass the interest down now. We are allowed to add * additional 'interest' to the mask if we want to. But this * transformation has no such interest. It just passes the request down, * unchanged. */ downChan = Tcl_GetStackedChannel(dataPtr->self); Tcl_GetChannelType(downChan)->watchProc( Tcl_GetChannelInstanceData(downChan), mask); /* * Management of the internal timer. */ if ((dataPtr->timer != (Tcl_TimerToken) NULL) && (!(mask & TCL_READABLE) || ResultLength(&dataPtr->result)==0)) { /* * A pending timer exists, but either is there no (more) interest in * the events it generates or nothing is availablee for reading, so * remove it. */ Tcl_DeleteTimerHandler(dataPtr->timer); dataPtr->timer = (Tcl_TimerToken) NULL; } if ((dataPtr->timer == (Tcl_TimerToken) NULL) && (mask & TCL_READABLE) && (ResultLength(&dataPtr->result) > 0)) { /* * There is no pending timer, but there is interest in readable events * and we actually have data waiting, so generate a timer to flush * that. */ dataPtr->timer = Tcl_CreateTimerHandler(FLUSH_DELAY, TransformChannelHandlerTimer, (ClientData) dataPtr); } } /* *---------------------------------------------------------------------- * * TransformGetFileHandleProc -- * * Called from Tcl_GetChannelHandle to retrieve OS specific file handle * from inside this channel. * * Side effects: * None. * * Result: * The appropriate Tcl_File or NULL if not present. * *---------------------------------------------------------------------- */ static int TransformGetFileHandleProc(instanceData, direction, handlePtr) ClientData instanceData; /* Channel to query */ int direction; /* Direction of interest */ ClientData *handlePtr; /* Place to store the handle into */ { /* * Return the handle belonging to parent channel. IOW, pass the request * down and the result up. */ TransformChannelData *dataPtr = (TransformChannelData *) instanceData; return Tcl_GetChannelHandle(Tcl_GetStackedChannel(dataPtr->self), direction, handlePtr); } /* *---------------------------------------------------------------------- * * TransformNotifyProc -- * * Handler called by Tcl to inform us of activity on the underlying * channel. * * Side effects: * May process the incoming event by itself. * * Result: * None. * *---------------------------------------------------------------------- */ static int TransformNotifyProc(clientData, mask) ClientData clientData; /* The state of the notified transformation */ int mask; /* The mask of occuring events */ { TransformChannelData *dataPtr = (TransformChannelData *) clientData; /* * An event occured in the underlying channel. This transformation * doesn't process such events thus returns the incoming mask unchanged. */ if (dataPtr->timer != (Tcl_TimerToken) NULL) { /* * Delete an existing timer. It was not fired, yet we are here, so the * channel below generated such an event and we don't have to. The * renewal of the interest after the execution of channel handlers * will eventually cause us to recreate the timer (in * TransformWatchProc). */ Tcl_DeleteTimerHandler(dataPtr->timer); dataPtr->timer = (Tcl_TimerToken) NULL; } return mask; } /* *---------------------------------------------------------------------- * * TransformChannelHandlerTimer -- * * Called by the notifier (-> timer) to flush out information waiting in * the input buffer. * * Side effects: * As of 'Tcl_NotifyChannel'. * * Result: * None. * *---------------------------------------------------------------------- */ static void TransformChannelHandlerTimer(clientData) ClientData clientData; /* Transformation to query */ { TransformChannelData *dataPtr = (TransformChannelData *) clientData; dataPtr->timer = (Tcl_TimerToken) NULL; if (!(dataPtr->watchMask & TCL_READABLE) || (ResultLength(&dataPtr->result) == 0)) { /* * The timer fired, but either is there no (more) interest in the * events it generates or nothing is available for reading, so ignore * it and don't recreate it. */ return; } Tcl_NotifyChannel(dataPtr->self, TCL_READABLE); } /* *---------------------------------------------------------------------- * * ResultClear -- * * Deallocates any memory allocated by 'ResultAdd'. * * Side effects: * See above. * * Result: * None. * *---------------------------------------------------------------------- */ static void ResultClear(r) ResultBuffer *r; /* Reference to the buffer to clear out. */ { r->used = 0; if (r->allocated) { ckfree((char *) r->buf); r->buf = UCHARP(NULL); r->allocated = 0; } } /* *---------------------------------------------------------------------- * * ResultInit -- * * Initializes the specified buffer structure. The structure will contain * valid information for an emtpy buffer. * * Side effects: * See above. * * Result: * None. * *---------------------------------------------------------------------- */ static void ResultInit(r) ResultBuffer *r; /* Reference to the structure to initialize */ { r->used = 0; r->allocated = 0; r->buf = UCHARP(NULL); } /* *---------------------------------------------------------------------- * * ResultLength -- * * Returns the number of bytes stored in the buffer. * * Side effects: * None. * * Result: * An integer, see above too. * *---------------------------------------------------------------------- */ static int ResultLength(r) ResultBuffer *r; /* The structure to query */ { return r->used; } /* *---------------------------------------------------------------------- * * ResultCopy -- * * Copies the requested number of bytes from the buffer into the * specified array and removes them from the buffer afterward. Copies * less if there is not enough data in the buffer. * * Side effects: * See above. * * Result: * The number of actually copied bytes, possibly less than 'toRead'. * *---------------------------------------------------------------------- */ static int ResultCopy(r, buf, toRead) ResultBuffer *r; /* The buffer to read from. */ unsigned char *buf; /* The buffer to copy into. */ int toRead; /* Number of requested bytes. */ { if (r->used == 0) { /* * Nothing to copy in the case of an empty buffer. */ return 0; } if (r->used == toRead) { /* * We have just enough. Copy everything to the caller. */ memcpy((VOID *) buf, (VOID *) r->buf, (size_t) toRead); r->used = 0; return toRead; } if (r->used > toRead) { /* * The internal buffer contains more than requested. Copy the * requested subset to the caller, and shift the remaining bytes down. */ memcpy((VOID *) buf, (VOID *) r->buf, (size_t) toRead); memmove((VOID *) r->buf, (VOID *) (r->buf + toRead), (size_t) r->used - toRead); r->used -= toRead; return toRead; } /* * There is not enough in the buffer to satisfy the caller, so take * everything. */ memcpy((VOID *) buf, (VOID *) r->buf, (size_t) r->used); toRead = r->used; r->used = 0; return toRead; } /* *---------------------------------------------------------------------- * * ResultAdd -- * * Adds the bytes in the specified array to the buffer, by appending it. * * Side effects: * See above. * * Result: * None. * *---------------------------------------------------------------------- */ static void ResultAdd(r, buf, toWrite) ResultBuffer *r; /* The buffer to extend */ unsigned char *buf; /* The buffer to read from */ int toWrite; /* The number of bytes in 'buf' */ { if ((r->used + toWrite) > r->allocated) { /* * Extension of the internal buffer is required. */ if (r->allocated == 0) { r->allocated = toWrite + INCREMENT; r->buf = UCHARP(ckalloc((unsigned) r->allocated)); } else { r->allocated += toWrite + INCREMENT; r->buf = UCHARP(ckrealloc((char *) r->buf, (unsigned) r->allocated)); } } /* now copy data */ memcpy(r->buf + r->used, buf, (size_t) toWrite); r->used += toWrite; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Added generic/tclIORChan.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 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 | /* * tclIORChan.c -- * * This file contains the implementation of Tcl's generic * channel reflection code, which allows the implementation * of Tcl channels in Tcl code. * * Parts of this file are based on code contributed by * Jean-Claude Wippler. * * See TIP #219 for the specification of this functionality. * * Copyright (c) 2004-2005 ActiveState, a divison of Sophos * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclIORChan.c,v 1.1.2.6 2005/10/08 13:44:37 dgp Exp $ */ #include <tclInt.h> #include <tclIO.h> #include <assert.h> #ifndef EINVAL #define EINVAL 9 #endif #ifndef EOK #define EOK 0 #endif /* * Signatures of all functions used in the C layer of the reflection. */ /* Required */ static int RcClose _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); /* Required, "read" is optional despite this. */ static int RcInput _ANSI_ARGS_((ClientData clientData, char *buf, int toRead, int *errorCodePtr)); /* Required, "write" is optional despite this. */ static int RcOutput _ANSI_ARGS_((ClientData clientData, CONST char *buf, int toWrite, int *errorCodePtr)); /* Required */ static void RcWatch _ANSI_ARGS_((ClientData clientData, int mask)); /* NULL'able - "blocking", is optional */ static int RcBlock _ANSI_ARGS_((ClientData clientData, int mode)); /* NULL'able - "seek", is optional */ static Tcl_WideInt RcSeekWide _ANSI_ARGS_((ClientData clientData, Tcl_WideInt offset, int mode, int *errorCodePtr)); static int RcSeek _ANSI_ARGS_((ClientData clientData, long offset, int mode, int *errorCodePtr)); /* NULL'able - "cget" / "cgetall", are optional */ static int RcGetOption _ANSI_ARGS_((ClientData clientData, Tcl_Interp* interp, CONST char *optionName, Tcl_DString *dsPtr)); /* NULL'able - "configure", is optional */ static int RcSetOption _ANSI_ARGS_((ClientData clientData, Tcl_Interp* interp, CONST char *optionName, CONST char *newValue)); /* * The C layer channel type/driver definition used by the reflection. * This is a version 3 structure. */ static Tcl_ChannelType tclRChannelType = { "tclrchannel", /* Type name. */ TCL_CHANNEL_VERSION_3, RcClose, /* Close channel, clean instance data */ RcInput, /* Handle read request */ RcOutput, /* Handle write request */ RcSeek, /* Move location of access point. NULL'able */ RcSetOption, /* Set options. NULL'able */ RcGetOption, /* Get options. NULL'able */ RcWatch, /* Initialize notifier */ NULL, /* Get OS handle from the channel. NULL'able */ NULL, /* No close2 support. NULL'able */ RcBlock, /* Set blocking/nonblocking. NULL'able */ NULL, /* Flush channel. Not used by core. NULL'able */ NULL, /* Handle events. NULL'able */ RcSeekWide /* Move access point (64 bit). NULL'able */ }; /* * Instance data for a reflected channel. =========================== */ typedef struct { Tcl_Channel chan; /* Back reference to generic channel structure. */ Tcl_Interp* interp; /* Reference to the interpreter containing the * Tcl level part of the channel. */ #ifdef TCL_THREADS Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ #endif /* See [==] as well. * Storage for the command prefix and the additional words required * for the invocation of methods in the command handler. * * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] * cmd ... pfx | method chan | detail1 detail2 * ~~~~ CT ~~~ ~~ CT ~~ * * CT = Belongs to the 'Command handler Thread'. */ int argc; /* Number of preallocated words - 2 */ Tcl_Obj** argv; /* Preallocated array for calling the handler. * args [0] is placeholder for cmd word. * Followed by the arguments in the prefix, * plus 4 placeholders for method, channel, * and at most two varying (method specific) * words. */ int methods; /* Bitmask of supported methods */ /* ---------------------------------------- */ /* NOTE (9): Should we have predefined shared literals * NOTE (9): for the method names ? */ /* ---------------------------------------- */ int mode; /* Mask of R/W mode */ int interest; /* Mask of events the channel is interested in. */ /* Note regarding the usage of timers. * * Most channel implementations need a timer in the * C level to ensure that data in buffers is flushed * out through the generation of fake file events. * * See 'rechan', 'memchan', etc. * * Here this is _not_ required. Interest in events is * posted to the Tcl level via 'watch'. And posting of * events is possible from the Tcl level as well, via * 'chan postevent'. This means that the generation of * all events, fake or not, timer based or not, is * completely in the hands of the Tcl level. Therefore * no timer here. */ } ReflectingChannel; /* * Event literals. ================================================== */ static CONST char *eventOptions[] = { "read", "write", (char *) NULL }; typedef enum { EVENT_READ, EVENT_WRITE } EventOption; /* * Method literals. ================================================== */ static CONST char *methodNames[] = { "blocking", /* OPT */ "cget", /* OPT \/ Together or none */ "cgetall", /* OPT /\ of these two */ "configure", /* OPT */ "finalize", /* */ "initialize", /* */ "read", /* OPT */ "seek", /* OPT */ "watch", /* */ "write", /* OPT */ (char *) NULL }; typedef enum { METH_BLOCKING, METH_CGET, METH_CGETALL, METH_CONFIGURE, METH_FINAL, METH_INIT, METH_READ, METH_SEEK, METH_WATCH, METH_WRITE, } MethodName; #define FLAG(m) (1 << (m)) #define REQUIRED_METHODS (FLAG (METH_INIT) | FLAG (METH_FINAL) | FLAG (METH_WATCH)) #define NULLABLE_METHODS (FLAG (METH_BLOCKING) | FLAG (METH_SEEK) | \ FLAG (METH_CONFIGURE) | FLAG (METH_CGET) | FLAG (METH_CGETALL)) #define RANDW (TCL_READABLE|TCL_WRITABLE) #define IMPLIES(a,b) ((!(a)) || (b)) #define NEGIMPL(a,b) #define HAS(x,f) (x & FLAG(f)) #ifdef TCL_THREADS /* * Thread specific types and structures. * * We are here essentially creating a very specific implementation of * 'thread send'. */ /* * Enumeration of all operations which can be forwarded. */ typedef enum { RcOpClose, RcOpInput, RcOpOutput, RcOpSeek, RcOpWatch, RcOpBlock, RcOpSetOpt, RcOpGetOpt, RcOpGetOptAll } RcOperation; /* * Event used to forward driver invocations to the thread actually * managing the channel. We cannot construct the command to execute * and forward that. Because then it will contain a mixture of * Tcl_Obj's belonging to both the command handler thread (CT), and * the thread managing the channel (MT), executed in CT. Tcl_Obj's are * not allowed to cross thread boundaries. So we forward an operation * code, the argument details ,and reference to results. The command * is assembled in the CT and belongs fully to that thread. No sharing * problems. */ typedef struct RcForwardParamBase { int code; /* O: Ok/Fail of the cmd handler */ char* msg; /* O: Error message for handler failure */ int vol; /* O: True - msg is allocated, False - msg is static */ } RcForwardParamBase; /* * Operation specific parameter/result structures. */ typedef struct RcForwardParamClose { RcForwardParamBase b; } RcForwardParamClose; typedef struct RcForwardParamInput { RcForwardParamBase b; char* buf; /* O: Where to store the read bytes */ int toRead; /* I: #bytes to read, * O: #bytes actually read */ } RcForwardParamInput; typedef struct RcForwardParamOutput { RcForwardParamBase b; CONST char* buf; /* I: Where the bytes to write come from */ int toWrite; /* I: #bytes to write, * O: #bytes actually written */ } RcForwardParamOutput; typedef struct RcForwardParamSeek { RcForwardParamBase b; int seekMode; /* I: How to seek */ Tcl_WideInt offset; /* I: Where to seek, * O: New location */ } RcForwardParamSeek; typedef struct RcForwardParamWatch { RcForwardParamBase b; int mask; /* I: What events to watch for */ } RcForwardParamWatch; typedef struct RcForwardParamBlock { RcForwardParamBase b; int nonblocking; /* I: What mode to activate */ } RcForwardParamBlock; typedef struct RcForwardParamSetOpt { RcForwardParamBase b; CONST char* name; /* Name of option to set */ CONST char* value; /* Value to set */ } RcForwardParamSetOpt; typedef struct RcForwardParamGetOpt { RcForwardParamBase b; CONST char* name; /* Name of option to get, maybe NULL */ Tcl_DString* value; /* Result */ } RcForwardParamGetOpt; /* * General event structure, with reference to * operation specific data. */ typedef struct RcForwardingEvent { Tcl_Event event; /* Basic event data, has to be first item */ struct RcForwardingResult* resultPtr; RcOperation op; /* Forwarded driver operation */ ReflectingChannel* rcPtr; /* Channel instance */ CONST RcForwardParamBase* param; /* Arguments, a RcForwardParamXXX pointer */ } RcForwardingEvent; /* * Structure to manage the result of the forwarding. This is not the * result of the operation itself, but about the success of the * forward event itself. The event can be successful, even if the * operation which was forwarded failed. It is also there to manage * the synchronization between the involved threads. */ typedef struct RcForwardingResult { Tcl_ThreadId src; /* Originating thread. */ Tcl_ThreadId dst; /* Thread the op was forwarded to. */ Tcl_Condition done; /* Condition variable the forwarder blocks on. */ int result; /* TCL_OK or TCL_ERROR */ struct RcForwardingEvent* evPtr; /* Event the result belongs to. */ struct RcForwardingResult* prevPtr; /* Links into the list of pending */ struct RcForwardingResult* nextPtr; /* forwarded results. */ } RcForwardingResult; /* * List of forwarded operations which have not completed yet, plus the * mutex to protect the access to this process global list. */ static RcForwardingResult* forwardList = (RcForwardingResult*) NULL; TCL_DECLARE_MUTEX (rcForwardMutex) /* * Function containing the generic code executing a forward, and * wrapper macros for the actual operations we wish to forward. */ static void RcForwardOp _ANSI_ARGS_ ((ReflectingChannel* rcPtr, RcOperation op, Tcl_ThreadId dst, CONST VOID* param)); /* * The event function executed by the thread receiving a forwarding * event. Executes the appropriate function and collects the result, * if any. */ static int RcForwardProc _ANSI_ARGS_ ((Tcl_Event *evPtr, int mask)); /* * Helpers which intercept when threads are going away, and clean up * after pending forwarding events. Different actions depending on * which thread went away, originator (src), or receiver (dst). */ static void RcSrcExitProc _ANSI_ARGS_ ((ClientData clientData)); static void RcDstExitProc _ANSI_ARGS_ ((ClientData clientData)); #define RcFreeReceivedError(pb) \ if ((pb).vol) {ckfree ((pb).msg);} #define RcPassReceivedErrorInterp(i,pb) \ if ((i)) {Tcl_SetChannelErrorInterp ((i), Tcl_NewStringObj ((pb).msg,-1));} \ RcFreeReceivedError (pb) #define RcPassReceivedError(c,pb) \ Tcl_SetChannelError ((c), Tcl_NewStringObj ((pb).msg,-1)); \ RcFreeReceivedError (pb) #define RcForwardSetStaticError(p,emsg) \ (p)->code = TCL_ERROR; (p)->vol = 0; (p)->msg = (char*) (emsg); #define RcForwardSetDynError(p,emsg) \ (p)->code = TCL_ERROR; (p)->vol = 1; (p)->msg = (char*) (emsg); static void RcForwardSetObjError _ANSI_ARGS_ ((RcForwardParamBase* p, Tcl_Obj* obj)); #endif /* TCL_THREADS */ #define RcSetChannelErrorStr(c,msg) \ Tcl_SetChannelError ((c), Tcl_NewStringObj ((msg),-1)) static Tcl_Obj* RcErrorMarshall _ANSI_ARGS_ ((Tcl_Interp *interp)); static void RcErrorReturn _ANSI_ARGS_ ((Tcl_Interp* interp, Tcl_Obj* msg)); /* * Static functions for this file: */ static int RcEncodeEventMask _ANSI_ARGS_((Tcl_Interp* interp, CONST char* objName, Tcl_Obj* obj, int* mask)); static Tcl_Obj* RcDecodeEventMask _ANSI_ARGS_ ((int mask)); static ReflectingChannel* RcNew _ANSI_ARGS_ ((Tcl_Interp* interp, Tcl_Obj* cmdpfxObj, int mode, Tcl_Obj* id)); static Tcl_Obj* RcNewHandle _ANSI_ARGS_ ((void)); static void RcFree _ANSI_ARGS_ ((ReflectingChannel* rcPtr)); static void RcInvokeTclMethod _ANSI_ARGS_((ReflectingChannel* rcPtr, CONST char* method, Tcl_Obj* argone, Tcl_Obj* argtwo, int* result, Tcl_Obj** resultObj, int capture)); #define NO_CAPTURE (0) #define DO_CAPTURE (1) /* * Global constant strings (messages). ================== * These string are used directly as bypass errors, thus they have to be valid * Tcl lists where the last element is the message itself. Hence the * list-quoting to keep the words of the message together. See also [x]. */ static CONST char* msg_read_unsup = "{read not supported by Tcl driver}"; static CONST char* msg_read_toomuch = "{read delivered more than requested}"; static CONST char* msg_write_unsup = "{write not supported by Tcl driver}"; static CONST char* msg_write_toomuch = "{write wrote more than requested}"; static CONST char* msg_seek_beforestart = "{Tried to seek before origin}"; #ifdef TCL_THREADS static CONST char* msg_send_originlost = "{Origin thread lost}"; static CONST char* msg_send_dstlost = "{Destination thread lost}"; #endif /* TCL_THREADS */ /* * Main methods to plug into the 'chan' ensemble'. ================== */ /* *---------------------------------------------------------------------- * * TclChanCreateObjCmd -- * * This procedure is invoked to process the "chan create" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * The handle of the new channel is placed in the interp result. * * Side effects: * Creates a new channel. * *---------------------------------------------------------------------- */ int TclChanCreateObjCmd (/*ignored*/ clientData, interp, objc, objv) ClientData clientData; Tcl_Interp* interp; int objc; Tcl_Obj* CONST* objv; { ReflectingChannel* rcPtr; /* Instance data of the new channel */ Tcl_Obj* rcId; /* Handle of the new channel */ int mode; /* R/W mode of new channel. Has to * match abilities of handler commands */ Tcl_Obj* cmdObj; /* Command prefix, list of words */ Tcl_Obj* cmdNameObj; /* Command name */ Tcl_Channel chan; /* Token for the new channel */ Tcl_Obj* modeObj; /* mode in obj form for method call */ int listc; /* Result of 'initialize', and of */ Tcl_Obj** listv; /* its sublist in the 2nd element */ int methIndex; /* Encoded method name */ int res; /* Result code for 'initialize' */ Tcl_Obj* resObj; /* Result data for 'initialize' */ int methods; /* Bitmask for supported methods. */ Channel* chanPtr; /* 'chan' resolved to internal struct. */ /* Syntax: chan create MODE CMDPREFIX * [0] [1] [2] [3] * * Actually: rCreate MODE CMDPREFIX * [0] [1] [2] */ #define MODE (1) #define CMD (2) /* Number of arguments ... */ if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "mode cmdprefix"); return TCL_ERROR; } /* First argument is a list of modes. Allowed entries are "read", * "write". Expect at least one list element. Abbreviations are * ok. */ modeObj = objv [MODE]; if (RcEncodeEventMask (interp, "mode", objv [MODE], &mode) != TCL_OK) { return TCL_ERROR; } /* Second argument is command prefix, i.e. list of words, first * word is name of handler command, other words are fixed * arguments. Run 'initialize' method to get the list of supported * methods. Validate this. */ cmdObj = objv [CMD]; /* Basic check that the command prefix truly is a list. */ if (Tcl_ListObjIndex(interp, cmdObj, 0, &cmdNameObj) != TCL_OK) { return TCL_ERROR; } /* Now create the channel. */ rcId = RcNewHandle (); rcPtr = RcNew (interp, cmdObj, mode, rcId); chan = Tcl_CreateChannel (&tclRChannelType, Tcl_GetString (rcId), rcPtr, mode); rcPtr->chan = chan; chanPtr = (Channel*) chan; /* Invoke 'initialize' and validate that the handler * is present and ok. Squash the channel if not. */ /* Note: The conversion of 'mode' back into a Tcl_Obj ensures that * 'initialize' is invoked with canonical mode names, and no * abbreviations. Using modeObj directly could feed abbreviations * into the handler, and the handler is not specified to handle * such. */ modeObj = RcDecodeEventMask (mode); RcInvokeTclMethod (rcPtr, "initialize", modeObj, NULL, &res, &resObj, NO_CAPTURE); Tcl_DecrRefCount (modeObj); if (res != TCL_OK) { Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1); Tcl_AppendObjToObj(err,resObj); Tcl_SetObjResult (interp,err); Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ goto error; } /* Verify the result. * - List, of method names. Convert to mask. * Check for non-optionals through the mask. * Compare open mode against optional r/w. */ Tcl_AppendResult (interp, "Initialize failure: ", (char*) NULL); if (Tcl_ListObjGetElements (interp, resObj, &listc, &listv) != TCL_OK) { /* The function above replaces my prefix in case of an error, * so more work for us to get the prefix back into the error * message */ Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1); Tcl_AppendObjToObj(err,Tcl_GetObjResult (interp)); Tcl_SetObjResult (interp,err); goto error; } methods = 0; while (listc > 0) { if (Tcl_GetIndexFromObj (interp, listv [listc-1], methodNames, "method", TCL_EXACT, &methIndex) != TCL_OK) { Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1); Tcl_AppendObjToObj(err,Tcl_GetObjResult (interp)); Tcl_SetObjResult (interp,err); goto error; } methods |= FLAG (methIndex); listc --; } if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { Tcl_AppendResult (interp, "Not all required methods supported", (char*) NULL); goto error; } if ((mode & TCL_READABLE) && !HAS(methods,METH_READ)) { Tcl_AppendResult (interp, "Reading not supported, but requested", (char*) NULL); goto error; } if ((mode & TCL_WRITABLE) && !HAS(methods,METH_WRITE)) { Tcl_AppendResult (interp, "Writing not supported, but requested", (char*) NULL); goto error; } if (!IMPLIES (HAS(methods,METH_CGET), HAS(methods,METH_CGETALL))) { Tcl_AppendResult (interp, "'cgetall' not supported, but should be, as 'cget' is", (char*) NULL); goto error; } if (!IMPLIES (HAS(methods,METH_CGETALL),HAS(methods,METH_CGET))) { Tcl_AppendResult (interp, "'cget' not supported, but should be, as 'cgetall' is", (char*) NULL); goto error; } Tcl_ResetResult (interp); /* Everything is fine now */ rcPtr->methods = methods; if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) { /* Some of the nullable methods are not supported. We clone * the channel type, null the associated C functions, and use * the result as the actual channel type. */ Tcl_ChannelType* clonePtr = (Tcl_ChannelType*) ckalloc (sizeof (Tcl_ChannelType)); if (clonePtr == (Tcl_ChannelType*) NULL) { Tcl_Panic ("Out of memory in Tcl_RcCreate"); } memcpy (clonePtr, &tclRChannelType, sizeof (Tcl_ChannelType)); if (!(methods & FLAG (METH_CONFIGURE))) { clonePtr->setOptionProc = NULL; } if ( !(methods & FLAG (METH_CGET)) && !(methods & FLAG (METH_CGETALL)) ) { clonePtr->getOptionProc = NULL; } if (!(methods & FLAG (METH_BLOCKING))) { clonePtr->blockModeProc = NULL; } if (!(methods & FLAG (METH_SEEK))) { clonePtr->seekProc = NULL; clonePtr->wideSeekProc = NULL; } chanPtr->typePtr = clonePtr; } Tcl_RegisterChannel (interp, chan); /* Return handle as result of command */ Tcl_SetObjResult (interp, rcId); return TCL_OK; error: /* Signal to RcClose to not call 'finalize' */ rcPtr->methods = 0; Tcl_Close (interp, chan); return TCL_ERROR; #undef MODE #undef CMD } /* *---------------------------------------------------------------------- * * TclChanPostEventObjCmd -- * * This procedure is invoked to process the "chan postevent" * Tcl command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * Posts events to a reflected channel, invokes event handlers. * The latter implies that arbitrary side effects are possible. * *---------------------------------------------------------------------- */ int TclChanPostEventObjCmd (/*ignored*/ clientData, interp, objc, objv) ClientData clientData; Tcl_Interp* interp; int objc; Tcl_Obj* CONST* objv; { /* Syntax: chan postevent CHANNEL EVENTSPEC * [0] [1] [2] [3] * * Actually: rPostevent CHANNEL EVENTSPEC * [0] [1] [2] * * where EVENTSPEC = {read write ...} (Abbreviations allowed as well. */ #define CHAN (1) #define EVENT (2) CONST char* chanId; /* Tcl level channel handle */ Tcl_Channel chan; /* Channel associated to the handle */ Tcl_ChannelType* chanTypePtr; /* Its associated driver structure */ ReflectingChannel* rcPtr; /* Associated instance data */ int mode; /* Dummy, r|w mode of the channel */ int events; /* Mask of events to post */ /* Number of arguments ... */ if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "channel eventspec"); return TCL_ERROR; } /* First argument is a channel, a reflected channel, and the call * of this command is done from the interp defining the channel * handler cmd. */ chanId = Tcl_GetString (objv [CHAN]); chan = Tcl_GetChannel(interp, chanId, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } chanTypePtr = Tcl_GetChannelType (chan); /* We use a function referenced by the channel type as our cookie * to detect calls to non-reflecting channels. The channel type * itself is not suitable, as it might not be the static * definition in this file, but a clone thereof. And while we have * reserved the name of the type nothing in the core checks * against violation, so someone else might have created a channel * type using our name, clashing with ourselves. */ if (chanTypePtr->watchProc != &RcWatch) { Tcl_AppendResult(interp, "channel \"", chanId, "\" is not a reflected channel", (char *) NULL); return TCL_ERROR; } rcPtr = (ReflectingChannel*) Tcl_GetChannelInstanceData (chan); if (rcPtr->interp != interp) { Tcl_AppendResult(interp, "postevent for channel \"", chanId, "\" called from outside interpreter", (char *) NULL); return TCL_ERROR; } /* Second argument is a list of events. Allowed entries are * "read", "write". Expect at least one list element. * Abbreviations are ok. */ if (RcEncodeEventMask (interp, "event", objv [EVENT], &events) != TCL_OK) { return TCL_ERROR; } /* Check that the channel is actually interested in the provided * events. */ if (events & ~rcPtr->interest) { Tcl_AppendResult(interp, "tried to post events channel \"", chanId, "\" is not interested in", (char *) NULL); return TCL_ERROR; } /* We have the channel and the events to post. */ Tcl_NotifyChannel (chan, events); /* Squash interp results left by the event script. */ Tcl_ResetResult (interp); return TCL_OK; #undef CHAN #undef EVENT } static Tcl_Obj* RcErrorMarshall (interp) Tcl_Interp *interp; { /* Capture the result status of the interpreter into a string. * => List of options and values, followed by the error message. * The result has refCount 0. */ Tcl_Obj* returnOpt = Tcl_GetReturnOptions (interp, TCL_ERROR); /* => returnOpt.refCount == 0. We can append directly. */ Tcl_ListObjAppendElement (NULL, returnOpt, Tcl_GetObjResult (interp)); return returnOpt; } static void RcErrorReturn (interp, msg) Tcl_Interp *interp; Tcl_Obj *msg; { int res; int lc; Tcl_Obj** lv; int explicitResult; int numOptions; /* Process the caught message. * * Syntax = (option value)... ?message? * * Bad syntax causes a panic. Because the other side uses * Tcl_GetReturnOptions and list construction functions to marshall the * information. */ res = Tcl_ListObjGetElements (interp, msg, &lc, &lv); if (res != TCL_OK) { Tcl_Panic ("TclChanCaughtErrorBypass: Bad syntax of caught result"); } explicitResult = (1 == (lc % 2)); numOptions = lc - explicitResult; if (explicitResult) { Tcl_SetObjResult (interp, lv [lc-1]); } (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj (numOptions, lv)); } int TclChanCaughtErrorBypass (interp, chan) Tcl_Interp *interp; Tcl_Channel chan; { Tcl_Obj* msgc = NULL; Tcl_Obj* msgi = NULL; Tcl_Obj* msg = NULL; /* Get a bypassed error message from channel and/or interpreter, save the * reference, then kill the returned objects, if there were any. If there * are messages in both the channel has preference. */ if ((chan == NULL) && (interp == NULL)) { return 0; } if (chan != NULL) { Tcl_GetChannelError (chan, &msgc); } if (interp != NULL) { Tcl_GetChannelErrorInterp (interp, &msgi); } if (msgc != NULL) { msg = msgc; Tcl_IncrRefCount (msg); } else if (msgi != NULL) { msg = msgi; Tcl_IncrRefCount (msg); } if (msgc != NULL) { Tcl_DecrRefCount (msgc); } if (msgi != NULL) { Tcl_DecrRefCount (msgi); } /* No message returned, nothing caught. */ if (msg == NULL) { return 0; } RcErrorReturn (interp, msg); Tcl_DecrRefCount (msg); return 1; } /* * Driver functions. ================================================ */ /* *---------------------------------------------------------------------- * * RcClose -- * * This function is invoked when the channel is closed, to delete * the driver specific instance data. * * Results: * A posix error. * * Side effects: * Releases memory. Arbitrary, as it calls upon a script. * *---------------------------------------------------------------------- */ static int RcClose (clientData, interp) ClientData clientData; Tcl_Interp* interp; { ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; int res; /* Result code for 'close' */ Tcl_Obj* resObj; /* Result data for 'close' */ if (interp == (Tcl_Interp*) NULL) { /* This call comes from TclFinalizeIOSystem. There are no * interpreters, and therefore we cannot call upon the handler * command anymore. Threading is irrelevant as well. We * simply clean up all our C level data structures and leave * the Tcl level to the other finalization functions. */ /* THREADED => Forward this to the origin thread */ /* Note: Have a thread delete handler for the origin * thread. Use this to clean up the structure! */ #ifdef TCL_THREADS /* Are we in the correct thread ? */ if (rcPtr->thread != Tcl_GetCurrentThread ()) { RcForwardParamClose p; RcForwardOp (rcPtr, RcOpClose, rcPtr->thread, &p); res = p.b.code; /* RcFree is done in the forwarded operation!, * in the other thread. rcPtr here is gone! */ if (res != TCL_OK) { RcFreeReceivedError (p.b); } } else { #endif RcFree (rcPtr); #ifdef TCL_THREADS } #endif return EOK; } /* -------- */ /* -- No -- ASSERT rcPtr->methods & FLAG (METH_FINAL) */ /* A cleaned method mask here implies that the channel creation * was aborted, and "finalize" must not be called. */ if (rcPtr->methods == 0) { RcFree (rcPtr); return EOK; } else { #ifdef TCL_THREADS /* Are we in the correct thread ? */ if (rcPtr->thread != Tcl_GetCurrentThread ()) { RcForwardParamClose p; RcForwardOp (rcPtr, RcOpClose, rcPtr->thread, &p); res = p.b.code; /* RcFree is done in the forwarded operation!, * in the other thread. rcPtr here is gone! */ if (res != TCL_OK) { RcPassReceivedErrorInterp (interp, p.b); } } else { #endif RcInvokeTclMethod (rcPtr, "finalize", NULL, NULL, &res, &resObj, DO_CAPTURE); if ((res != TCL_OK) && (interp != NULL)) { Tcl_SetChannelErrorInterp (interp, resObj); } Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ #ifdef TCL_THREADS RcFree (rcPtr); } #endif return (res == TCL_OK) ? EOK : EINVAL; } } /* *---------------------------------------------------------------------- * * RcInput -- * * This function is invoked when more data is requested from the * channel. * * Results: * The number of bytes read. * * Side effects: * Allocates memory. Arbitrary, as it calls upon a script. * *---------------------------------------------------------------------- */ static int RcInput (clientData, buf, toRead, errorCodePtr) ClientData clientData; char* buf; int toRead; int* errorCodePtr; { ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; Tcl_Obj* toReadObj; int bytec; /* Number of returned bytes */ unsigned char* bytev; /* Array of returned bytes */ int res; /* Result code for 'read' */ Tcl_Obj* resObj; /* Result data for 'read' */ /* The following check can be done before thread redirection, * because we are reading from an item which is readonly, i.e. * will never change during the lifetime of the channel. */ if (!(rcPtr->methods & FLAG (METH_READ))) { RcSetChannelErrorStr (rcPtr->chan, msg_read_unsup); *errorCodePtr = EINVAL; return -1; } #ifdef TCL_THREADS /* Are we in the correct thread ? */ if (rcPtr->thread != Tcl_GetCurrentThread ()) { RcForwardParamInput p; p.buf = buf; p.toRead = toRead; RcForwardOp (rcPtr, RcOpInput, rcPtr->thread, &p); if (p.b.code != TCL_OK) { RcPassReceivedError (rcPtr->chan, p.b); *errorCodePtr = EINVAL; } else { *errorCodePtr = EOK; } return p.toRead; } #endif /* -------- */ /* ASSERT: rcPtr->method & FLAG (METH_READ) */ /* ASSERT: rcPtr->mode & TCL_READABLE */ toReadObj = Tcl_NewIntObj(toRead); if (toReadObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcInput"); } RcInvokeTclMethod (rcPtr, "read", toReadObj, NULL, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { Tcl_SetChannelError (rcPtr->chan, resObj); Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ *errorCodePtr = EINVAL; return -1; } bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); if (toRead < bytec) { Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ RcSetChannelErrorStr (rcPtr->chan, msg_read_toomuch); *errorCodePtr = EINVAL; return -1; } *errorCodePtr = EOK; if (bytec > 0) { memcpy (buf, bytev, bytec); } Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ return bytec; } /* *---------------------------------------------------------------------- * * RcOutput -- * * This function is invoked when data is writen to the * channel. * * Results: * The number of bytes actually written. * * Side effects: * Allocates memory. Arbitrary, as it calls upon a script. * *---------------------------------------------------------------------- */ static int RcOutput (clientData, buf, toWrite, errorCodePtr) ClientData clientData; CONST char* buf; int toWrite; int* errorCodePtr; { ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; Tcl_Obj* bufObj; int res; /* Result code for 'write' */ Tcl_Obj* resObj; /* Result data for 'write' */ int written; /* The following check can be done before thread redirection, * because we are reading from an item which is readonly, i.e. * will never change during the lifetime of the channel. */ if (!(rcPtr->methods & FLAG (METH_WRITE))) { RcSetChannelErrorStr (rcPtr->chan, msg_write_unsup); *errorCodePtr = EINVAL; return -1; } #ifdef TCL_THREADS /* Are we in the correct thread ? */ if (rcPtr->thread != Tcl_GetCurrentThread ()) { RcForwardParamOutput p; p.buf = buf; p.toWrite = toWrite; RcForwardOp (rcPtr, RcOpOutput, rcPtr->thread, &p); if (p.b.code != TCL_OK) { RcPassReceivedError (rcPtr->chan, p.b); *errorCodePtr = EINVAL; } else { *errorCodePtr = EOK; } return p.toWrite; } #endif /* -------- */ /* ASSERT: rcPtr->method & FLAG (METH_WRITE) */ /* ASSERT: rcPtr->mode & TCL_WRITABLE */ bufObj = Tcl_NewByteArrayObj((unsigned char*) buf, toWrite); if (bufObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcOutput"); } RcInvokeTclMethod (rcPtr, "write", bufObj, NULL, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { Tcl_SetChannelError (rcPtr->chan, resObj); Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ *errorCodePtr = EINVAL; return -1; } res = Tcl_GetIntFromObj (rcPtr->interp, resObj, &written); if (res != TCL_OK) { Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ Tcl_SetChannelError (rcPtr->chan, RcErrorMarshall (rcPtr->interp)); *errorCodePtr = EINVAL; return -1; } Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ if ((written == 0) || (toWrite < written)) { /* The handler claims to have written more than it was given. * That is bad. Note that the I/O core would crash if we were * to return this information, trying to write -nnn bytes in * the next iteration. */ RcSetChannelErrorStr (rcPtr->chan, msg_write_toomuch); *errorCodePtr = EINVAL; return -1; } *errorCodePtr = EOK; return written; } /* *---------------------------------------------------------------------- * * RcSeekWide / RcSeek -- * * This function is invoked when the user wishes to seek on * the channel. * * Results: * The new location of the access point. * * Side effects: * Allocates memory. Arbitrary, as it calls upon a script. * *---------------------------------------------------------------------- */ static Tcl_WideInt RcSeekWide (clientData, offset, seekMode, errorCodePtr) ClientData clientData; Tcl_WideInt offset; int seekMode; int* errorCodePtr; { ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; Tcl_Obj* offObj; Tcl_Obj* baseObj; int res; /* Result code for 'seek' */ Tcl_Obj* resObj; /* Result data for 'seek' */ Tcl_WideInt newLoc; #ifdef TCL_THREADS /* Are we in the correct thread ? */ if (rcPtr->thread != Tcl_GetCurrentThread ()) { RcForwardParamSeek p; p.seekMode = seekMode; p.offset = offset; RcForwardOp (rcPtr, RcOpSeek, rcPtr->thread, &p); if (p.b.code != TCL_OK) { RcPassReceivedError (rcPtr->chan, p.b); *errorCodePtr = EINVAL; } else { *errorCodePtr = EOK; } return p.offset; } #endif /* -------- */ /* ASSERT: rcPtr->method & FLAG (METH_SEEK) */ offObj = Tcl_NewWideIntObj(offset); if (offObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcSeekWide"); } baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ? "start" : ((seekMode == SEEK_CUR) ? "current" : "end"), -1); if (baseObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcSeekWide"); } RcInvokeTclMethod (rcPtr, "seek", offObj, baseObj, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { Tcl_SetChannelError (rcPtr->chan, resObj); Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ *errorCodePtr = EINVAL; return -1; } res = Tcl_GetWideIntFromObj (rcPtr->interp, resObj, &newLoc); if (res != TCL_OK) { Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ Tcl_SetChannelError (rcPtr->chan, RcErrorMarshall (rcPtr->interp)); *errorCodePtr = EINVAL; return -1; } Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ if (newLoc < Tcl_LongAsWide (0)) { RcSetChannelErrorStr (rcPtr->chan, msg_seek_beforestart); *errorCodePtr = EINVAL; return -1; } *errorCodePtr = EOK; return newLoc; } static int RcSeek (clientData, offset, seekMode, errorCodePtr) ClientData clientData; long offset; int seekMode; int* errorCodePtr; { /* This function can be invoked from a transformation which is based * on standard seeking, i.e. non-wide. Because o this we have to * implement it, a dummy is not enough. We simply delegate the call * to the wide routine. */ return (int) RcSeekWide (clientData, Tcl_LongAsWide (offset), seekMode, errorCodePtr); } /* *---------------------------------------------------------------------- * * RcWatch -- * * This function is invoked to tell the channel what events * the I/O system is interested in. * * Results: * None. * * Side effects: * Allocates memory. Arbitrary, as it calls upon a script. * *---------------------------------------------------------------------- */ static void RcWatch (clientData, mask) ClientData clientData; int mask; { ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; Tcl_Obj* maskObj; /* ASSERT rcPtr->methods & FLAG (METH_WATCH) */ /* We restrict the interest to what the channel can support * IOW there will never be write events for a channel which is * not writable. Analoguous for read events. */ mask = mask & rcPtr->mode; if (mask == rcPtr->interest) { /* Same old, same old, why should we do something ? */ return; } rcPtr->interest = mask; #ifdef TCL_THREADS /* Are we in the correct thread ? */ if (rcPtr->thread != Tcl_GetCurrentThread ()) { RcForwardParamWatch p; p.mask = mask; RcForwardOp (rcPtr, RcOpWatch, rcPtr->thread, &p); /* Any failure from the forward is ignored. We have no place to * put this. */ return; } #endif /* -------- */ maskObj = RcDecodeEventMask (mask); RcInvokeTclMethod (rcPtr, "watch", maskObj, NULL, NULL, NULL, NO_CAPTURE); Tcl_DecrRefCount (maskObj); } /* *---------------------------------------------------------------------- * * RcBlock -- * * This function is invoked to tell the channel which blocking * behaviour is required of it. * * Results: * A posix error number. * * Side effects: * Allocates memory. Arbitrary, as it calls upon a script. * *---------------------------------------------------------------------- */ static int RcBlock (clientData, nonblocking) ClientData clientData; int nonblocking; { ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; Tcl_Obj* blockObj; int res; /* Result code for 'blocking' */ Tcl_Obj* resObj; /* Result data for 'blocking' */ #ifdef TCL_THREADS /* Are we in the correct thread ? */ if (rcPtr->thread != Tcl_GetCurrentThread ()) { RcForwardParamBlock p; p.nonblocking = nonblocking; RcForwardOp (rcPtr, RcOpBlock, rcPtr->thread, &p); if (p.b.code != TCL_OK) { RcPassReceivedError (rcPtr->chan, p.b); return EINVAL; } else { return EOK; } } #endif /* -------- */ blockObj = Tcl_NewBooleanObj(!nonblocking); if (blockObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcBlock"); } RcInvokeTclMethod (rcPtr, "blocking", blockObj, NULL, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { Tcl_SetChannelError (rcPtr->chan, resObj); res = EINVAL; } else { res = EOK; } Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ return res; } /* *---------------------------------------------------------------------- * * RcSetOption -- * * This function is invoked to configure a channel option. * * Results: * A standard Tcl result code. * * Side effects: * Arbitrary, as it calls upon a Tcl script. * *---------------------------------------------------------------------- */ static int RcSetOption (clientData, interp, optionName, newValue) ClientData clientData; /* Channel to query */ Tcl_Interp *interp; /* Interpreter to leave error messages in */ CONST char *optionName; /* Name of requested option */ CONST char *newValue; /* The new value */ { ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; Tcl_Obj* optionObj; Tcl_Obj* valueObj; int res; /* Result code for 'configure' */ Tcl_Obj* resObj; /* Result data for 'configure' */ #ifdef TCL_THREADS /* Are we in the correct thread ? */ if (rcPtr->thread != Tcl_GetCurrentThread ()) { RcForwardParamSetOpt p; p.name = optionName; p.value = newValue; RcForwardOp (rcPtr, RcOpSetOpt, rcPtr->thread, &p); if (p.b.code != TCL_OK) { Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1); RcErrorReturn (interp, err); Tcl_DecrRefCount (err); if (p.b.vol) {ckfree (p.b.msg);} } return p.b.code; } #endif /* -------- */ optionObj = Tcl_NewStringObj(optionName,-1); if (optionObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcSetOption"); } valueObj = Tcl_NewStringObj(newValue,-1); if (valueObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcSetOption"); } RcInvokeTclMethod (rcPtr, "configure", optionObj, valueObj, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { RcErrorReturn (interp, resObj); } Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ return res; } /* *---------------------------------------------------------------------- * * RcGetOption -- * * This function is invoked to retrieve all or a channel option. * * Results: * A standard Tcl result code. * * Side effects: * Arbitrary, as it calls upon a Tcl script. * *---------------------------------------------------------------------- */ static int RcGetOption (clientData, interp, optionName, dsPtr) ClientData clientData; /* Channel to query */ Tcl_Interp* interp; /* Interpreter to leave error messages in */ CONST char* optionName; /* Name of reuqested option */ Tcl_DString* dsPtr; /* String to place the result into */ { /* This code is special. It has regular passing of Tcl result, and * errors. The bypass functions are not required. */ ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; Tcl_Obj* optionObj; int res; /* Result code for 'configure' */ Tcl_Obj* resObj; /* Result data for 'configure' */ int listc; Tcl_Obj** listv; const char* method; #ifdef TCL_THREADS /* Are we in the correct thread ? */ if (rcPtr->thread != Tcl_GetCurrentThread ()) { int opcode; RcForwardParamGetOpt p; p.name = optionName; p.value = dsPtr; if (optionName == (char*) NULL) { opcode = RcOpGetOptAll; } else { opcode = RcOpGetOpt; } RcForwardOp (rcPtr, opcode, rcPtr->thread, &p); if (p.b.code != TCL_OK) { Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1); RcErrorReturn (interp, err); Tcl_DecrRefCount (err); if (p.b.vol) {ckfree (p.b.msg);} } return p.b.code; } #endif /* -------- */ if (optionName == (char*) NULL) { /* Retrieve all options. */ method = "cgetall"; optionObj = NULL; } else { /* Retrieve the value of one option */ method = "cget"; optionObj = Tcl_NewStringObj(optionName,-1); if (optionObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcGetOption"); } } RcInvokeTclMethod (rcPtr, method, optionObj, NULL, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { RcErrorReturn (interp, resObj); Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ return res; } /* The result has to go into the 'dsPtr' for propagation to the * caller of the driver. */ if (optionObj != NULL) { Tcl_DStringAppend (dsPtr, Tcl_GetString (resObj), -1); Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ return res; } /* Extract the list and append each item as element. */ /* NOTE (4): If we extract the string rep we can assume a * NOTE (4): properly quoted string. Together with a separating * NOTE (4): space this way of simply appending the whole string * NOTE (4): rep might be faster. It also doesn't check if the * NOTE (4): result is a valid list. Nor that the list has an * NOTE (4): even number elements. * NOTE (4): --- */ res = Tcl_ListObjGetElements (interp, resObj, &listc, &listv); if (res != TCL_OK) { Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ return res; } if ((listc % 2) == 1) { /* Odd number of elements is wrong. */ Tcl_Obj *objPtr = Tcl_NewObj(); Tcl_ResetResult(interp); TclObjPrintf(NULL, objPtr, "Expected list with even number of " "elements, got %d element%s instead", listc, (listc == 1 ? "" : "s")); Tcl_SetObjResult(interp, objPtr); Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ return TCL_ERROR; } { int len; char* str = Tcl_GetStringFromObj (resObj, &len); if (len) { Tcl_DStringAppend (dsPtr, " ", 1); Tcl_DStringAppend (dsPtr, str, len); } } Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ return res; } /* * Helpers. ========================================================= */ /* *---------------------------------------------------------------------- * * RcEncodeEventMask -- * * This function takes a list of event items and constructs the * equivalent internal bitmask. The list has to contain at * least one element. Elements are "read", "write", or any unique * abbreviation thereof. Note that the bitmask is not changed if * problems are encountered. * * Results: * A standard Tcl error code. A bitmask where TCL_READABLE * and/or TCL_WRITABLE can be set. * * Side effects: * May shimmer 'obj' to a list representation. May place an * error message into the interp result. * *---------------------------------------------------------------------- */ static int RcEncodeEventMask (interp, objName, obj, mask) Tcl_Interp* interp; CONST char* objName; Tcl_Obj* obj; int* mask; { int events; /* Mask of events to post */ int listc; /* #elements in eventspec list */ Tcl_Obj** listv; /* Elements of eventspec list */ int evIndex; /* Id of event for an element of the * eventspec list */ if (Tcl_ListObjGetElements (interp, obj, &listc, &listv) != TCL_OK) { return TCL_ERROR; } if (listc < 1) { Tcl_AppendResult(interp, "bad ", objName, " list: is empty", (char *) NULL); return TCL_ERROR; } events = 0; while (listc > 0) { if (Tcl_GetIndexFromObj (interp, listv [listc-1], eventOptions, objName, 0, &evIndex) != TCL_OK) { return TCL_ERROR; } switch (evIndex) { case EVENT_READ: events |= TCL_READABLE; break; case EVENT_WRITE: events |= TCL_WRITABLE; break; } listc --; } *mask = events; return TCL_OK; } /* *---------------------------------------------------------------------- * * RcDecodeEventMask -- * * This function takes an internal bitmask of events and * constructs the equivalent list of event items. * * Results: * A Tcl_Obj reference. The object will have a refCount of * one. The user has to decrement it to release the object. * * Side effects: * None. * *---------------------------------------------------------------------- */ static Tcl_Obj* RcDecodeEventMask (mask) int mask; { Tcl_Obj* evObj = Tcl_NewStringObj (((mask & RANDW) == RANDW) ? "read write" : ((mask & TCL_READABLE) ? "read" : ((mask & TCL_WRITABLE) ? "write" : "")), -1); if (evObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcDecodeEventMask"); } Tcl_IncrRefCount (evObj); return evObj; } /* *---------------------------------------------------------------------- * * RcNew -- * * This function is invoked to allocate and initialize the * instance data of a new reflected channel. * * Results: * A heap-allocated channel instance. * * Side effects: * Allocates memory. * *---------------------------------------------------------------------- */ static ReflectingChannel* RcNew (interp, cmdpfxObj, mode, id) Tcl_Interp* interp; Tcl_Obj* cmdpfxObj; int mode; Tcl_Obj* id; { ReflectingChannel* rcPtr; int listc; Tcl_Obj** listv; Tcl_Obj* word; int i; rcPtr = (ReflectingChannel*) ckalloc (sizeof(ReflectingChannel)); /* rcPtr->chan : Assigned by caller. Dummy data here. */ /* rcPtr->methods : Assigned by caller. Dummy data here. */ rcPtr->chan = (Tcl_Channel) NULL; rcPtr->methods = 0; rcPtr->interp = interp; #ifdef TCL_THREADS rcPtr->thread = Tcl_GetCurrentThread (); #endif rcPtr->mode = mode; rcPtr->interest = 0; /* Initially no interest registered */ /* Method placeholder */ /* ASSERT: cmdpfxObj is a Tcl List */ Tcl_ListObjGetElements (interp, cmdpfxObj, &listc, &listv); /* See [==] as well. * Storage for the command prefix and the additional words required * for the invocation of methods in the command handler. * * listv [0] [listc-1] | [listc] [listc+1] | * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] * cmd ... pfx | method chan | detail1 detail2 */ rcPtr->argc = listc + 2; rcPtr->argv = (Tcl_Obj**) ckalloc (sizeof (Tcl_Obj*) * (listc+4)); for (i = 0; i < listc ; i++) { word = rcPtr->argv [i] = listv [i]; Tcl_IncrRefCount (word); } i++; /* Skip placeholder for method */ rcPtr->argv [i] = id ; Tcl_IncrRefCount (id); /* The next two objects are kept empty, varying arguments */ /* Initialization complete */ return rcPtr; } /* *---------------------------------------------------------------------- * * RcNewHandle -- * * This function is invoked to generate a channel handle for * a new reflected channel. * * Results: * A Tcl_Obj containing the string of the new channel handle. * The refcount of the returned object is -- zero --. * * Side effects: * May allocate memory. Mutex protected critical section * locks out other threads for a short time. * *---------------------------------------------------------------------- */ static Tcl_Obj* RcNewHandle () { /* Count number of generated reflected channels. Used for id * generation. Ids are never reclaimed and there is no dealing * with wrap around. On the other hand, "unsigned long" should be * big enough except for absolute longrunners (generate a 100 ids * per second => overflow will occur in 1 1/3 years). */ #ifdef TCL_THREADS TCL_DECLARE_MUTEX (rcCounterMutex) #endif static unsigned long rcCounter = 0; Tcl_Obj* res = Tcl_NewObj (); #ifdef TCL_THREADS Tcl_MutexLock (&rcCounterMutex); #endif TclObjPrintf(NULL, res, "rc%lu", rcCounter); rcCounter ++; #ifdef TCL_THREADS Tcl_MutexUnlock (&rcCounterMutex); #endif return res; } static void RcFree (rcPtr) ReflectingChannel* rcPtr; { Channel* chanPtr = (Channel*) rcPtr->chan; int i, n; if (chanPtr->typePtr != &tclRChannelType) { /* Delete a cloned ChannelType structure. */ ckfree ((char*) chanPtr->typePtr); } n = rcPtr->argc - 2; for (i = 0; i < n; i++) { Tcl_DecrRefCount (rcPtr->argv[i]); } ckfree ((char*) rcPtr->argv); ckfree ((char*) rcPtr); return; } /* *---------------------------------------------------------------------- * * RcInvokeTclMethod -- * * This function is used to invoke the Tcl level of a reflected * channel. It handles all the command assembly, invokation, and * generic state and result mgmt. * * Results: * Result code and data as returned by the method. * * Side effects: * Arbitrary, as it calls upo na Tcl script. * *---------------------------------------------------------------------- */ static void RcInvokeTclMethod (rcPtr, method, argone, argtwo, result, resultObj, capture) ReflectingChannel* rcPtr; CONST char* method; Tcl_Obj* argone; /* NULL'able */ Tcl_Obj* argtwo; /* NULL'able */ int* result; /* NULL'able */ Tcl_Obj** resultObj; /* NULL'able */ int capture; { /* Thread redirection was done by higher layers */ /* ASSERT: Tcl_GetCurrentThread () == rcPtr->thread */ int cmdc; /* #words in constructed command */ Tcl_Obj* methObj = NULL; /* Method name in object form */ Tcl_InterpState sr; /* State of handler interp */ int res; /* Result code of method invokation */ Tcl_Obj* resObj = NULL; /* Result of method invokation. */ /* NOTE (5): Decide impl. issue: Cache objects with method names ? * NOTE (5): Requires TSD data as reflections can be created in * NOTE (5): many different threads. * NOTE (5): --- */ /* Insert method into the pre-allocated area, after the command * prefix, before the channel id. */ methObj = Tcl_NewStringObj (method, -1); if (methObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcInvokeTclMethod"); } Tcl_IncrRefCount (methObj); rcPtr->argv [rcPtr->argc - 2] = methObj; /* Append the additional argument containing method specific * details behind the channel id. If specified. */ cmdc = rcPtr->argc ; if (argone) { Tcl_IncrRefCount (argone); rcPtr->argv [cmdc] = argone; cmdc++; } if (argtwo) { Tcl_IncrRefCount (argtwo); rcPtr->argv [cmdc] = argtwo; cmdc++; } /* And run the handler ... This is done in auch a manner which * leaves any existing state intact. */ sr = Tcl_SaveInterpState (rcPtr->interp, 0 /* Dummy */); res = Tcl_EvalObjv (rcPtr->interp, cmdc, rcPtr->argv, TCL_EVAL_GLOBAL); /* We do not try to extract the result information if the caller has no * interest in it. I.e. there is no need to put effort into creating * something which is discarded immediately after. */ if (resultObj) { if ((res == TCL_OK) || !capture) { /* Ok result taken as is, also if the caller requests that there * is no capture. */ resObj = Tcl_GetObjResult (rcPtr->interp); } else { /* Non-ok ressult is always treated as an error. * We have to capture the full state of the result, * including additional options. */ res = TCL_ERROR; resObj = RcErrorMarshall (rcPtr->interp); } Tcl_IncrRefCount(resObj); } Tcl_RestoreInterpState (rcPtr->interp, sr); /* ... */ /* Cleanup of the dynamic parts of the command */ Tcl_DecrRefCount (methObj); if (argone) {Tcl_DecrRefCount (argone);} if (argtwo) {Tcl_DecrRefCount (argtwo);} /* The resObj has a ref count of 1 at this location. This means * that the caller of RcInvoke has to dispose of it (but only if * it was returned to it). */ if (result) { *result = res; } if (resultObj) { *resultObj = resObj; } /* There no need to handle the case where nothing is returned, because for * that case resObj was not set anyway. */ } #ifdef TCL_THREADS static void RcForwardOp (rcPtr, op, dst, param) ReflectingChannel* rcPtr; /* Channel instance */ RcOperation op; /* Forwarded driver operation */ Tcl_ThreadId dst; /* Destination thread */ CONST VOID* param; /* Arguments */ { RcForwardingEvent* evPtr; RcForwardingResult* resultPtr; int result; /* Create and initialize the event and data structures */ evPtr = (RcForwardingEvent*) ckalloc (sizeof (RcForwardingEvent)); resultPtr = (RcForwardingResult*) ckalloc (sizeof (RcForwardingResult)); evPtr->event.proc = RcForwardProc; evPtr->resultPtr = resultPtr; evPtr->op = op; evPtr->rcPtr = rcPtr; evPtr->param = param; resultPtr->src = Tcl_GetCurrentThread (); resultPtr->dst = dst; resultPtr->done = (Tcl_Condition) NULL; resultPtr->result = -1; resultPtr->evPtr = evPtr; /* Now execute the forward */ Tcl_MutexLock(&rcForwardMutex); TclSpliceIn(resultPtr, forwardList); /* * Ensure cleanup of the event if any of the two involved threads * exits while this event is pending or in progress. */ Tcl_CreateThreadExitHandler(RcSrcExitProc, (ClientData) evPtr); Tcl_CreateThreadExitHandler(RcDstExitProc, (ClientData) evPtr); /* * Queue the event and poke the other thread's notifier. */ Tcl_ThreadQueueEvent(dst, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL); Tcl_ThreadAlert(dst); /* * (*) Block until the other thread has either processed the transfer * or rejected it. */ while (resultPtr->result < 0) { /* NOTE (1): Is it possible that the current thread goes away while waiting here ? * NOTE (1): IOW Is it possible that "RcSrcExitProc" is called while we are here ? * NOTE (1): See complementary note (2) in "RcSrcExitProc" * NOTE (1): --- */ Tcl_ConditionWait(&resultPtr->done, &rcForwardMutex, NULL); } /* * Unlink result from the forwarder list. */ TclSpliceOut(resultPtr, forwardList); resultPtr->nextPtr = NULL; resultPtr->prevPtr = NULL; Tcl_MutexUnlock(&rcForwardMutex); Tcl_ConditionFinalize(&resultPtr->done); /* * Kill the cleanup handlers now, and the result structure as well, * before returning the success code. * * Note: The event structure has already been deleted. */ Tcl_DeleteThreadExitHandler(RcSrcExitProc, (ClientData) evPtr); Tcl_DeleteThreadExitHandler(RcDstExitProc, (ClientData) evPtr); result = resultPtr->result; ckfree ((char*) resultPtr); } static int RcForwardProc (evGPtr, mask) Tcl_Event *evGPtr; int mask; { /* Notes regarding access to the referenced data. * * In principle the data belongs to the originating thread (see * evPtr->src), however this thread is currently blocked at (*), * i.e. quiescent. Because of this we can treat the data as * belonging to us, without fear of race conditions. I.e. we can * read and write as we like. * * The only thing we cannot be sure of is the resultPtr. This can be * be NULLed if the originating thread went away while the event * is handled here now. */ RcForwardingEvent* evPtr = (RcForwardingEvent*) evGPtr; RcForwardingResult* resultPtr = evPtr->resultPtr; ReflectingChannel* rcPtr = evPtr->rcPtr; Tcl_Interp* interp = rcPtr->interp; RcForwardParamBase* paramPtr = (RcForwardParamBase*) evPtr->param; int res = TCL_OK; /* Result code of RcInvokeTclMethod */ Tcl_Obj* resObj = NULL; /* Interp result of RcInvokeTclMethod */ /* Ignore the event if no one is waiting for its result anymore. */ if (!resultPtr) { return 1; } paramPtr->code = TCL_OK; paramPtr->msg = NULL; paramPtr->vol = 0; switch (evPtr->op) { /* The destination thread for the following operations is * rcPtr->thread, which contains rcPtr->interp, the interp * we have to call upon for the driver. */ case RcOpClose: { /* No parameters/results */ RcInvokeTclMethod (rcPtr, "finalize", NULL, NULL, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { RcForwardSetObjError (paramPtr, resObj); } /* Freeing is done here, in the origin thread, because the * argv[] objects belong to this thread. Deallocating them * in a different thread is not allowed */ RcFree (rcPtr); } break; case RcOpInput: { RcForwardParamInput* p = (RcForwardParamInput*) paramPtr; Tcl_Obj* toReadObj = Tcl_NewIntObj (p->toRead); if (toReadObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcInput"); } RcInvokeTclMethod (rcPtr, "read", toReadObj, NULL, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { RcForwardSetObjError (paramPtr, resObj); p->toRead = -1; } else { /* Process a regular result. */ int bytec; /* Number of returned bytes */ unsigned char* bytev; /* Array of returned bytes */ bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); if (p->toRead < bytec) { RcForwardSetStaticError (paramPtr, msg_read_toomuch); p->toRead = -1; } else { if (bytec > 0) { memcpy (p->buf, bytev, bytec); } p->toRead = bytec; } } } break; case RcOpOutput: { RcForwardParamOutput* p = (RcForwardParamOutput*) paramPtr; Tcl_Obj* bufObj = Tcl_NewByteArrayObj((unsigned char*) p->buf, p->toWrite); if (bufObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcOutput"); } RcInvokeTclMethod (rcPtr, "write", bufObj, NULL, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { RcForwardSetObjError (paramPtr, resObj); p->toWrite = -1; } else { /* Process a regular result. */ int written; res = Tcl_GetIntFromObj (interp, resObj, &written); if (res != TCL_OK) { RcForwardSetObjError (paramPtr, RcErrorMarshall (interp)); p->toWrite = -1; } else if ((written == 0) || (p->toWrite < written)) { RcForwardSetStaticError (paramPtr, msg_write_toomuch); p->toWrite = -1; } else { p->toWrite = written; } } } break; case RcOpSeek: { RcForwardParamSeek* p = (RcForwardParamSeek*) paramPtr; Tcl_Obj* offObj; Tcl_Obj* baseObj; offObj = Tcl_NewWideIntObj(p->offset); if (offObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcSeekWide"); } baseObj = Tcl_NewStringObj((p->seekMode == SEEK_SET) ? "start" : ((p->seekMode == SEEK_CUR) ? "current" : "end"), -1); if (baseObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcSeekWide"); } RcInvokeTclMethod (rcPtr, "seek", offObj, baseObj, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { RcForwardSetObjError (paramPtr, resObj); p->offset = -1; } else { /* Process a regular result. If the type is wrong this * may change into an error. */ Tcl_WideInt newLoc; res = Tcl_GetWideIntFromObj (interp, resObj, &newLoc); if (res == TCL_OK) { if (newLoc < Tcl_LongAsWide (0)) { RcForwardSetStaticError (paramPtr, msg_seek_beforestart); p->offset = -1; } else { p->offset = newLoc; } } else { RcForwardSetObjError (paramPtr, RcErrorMarshall (interp)); p->offset = -1; } } } break; case RcOpWatch: { RcForwardParamWatch* p = (RcForwardParamWatch*) paramPtr; Tcl_Obj* maskObj = RcDecodeEventMask (p->mask); RcInvokeTclMethod (rcPtr, "watch", maskObj, NULL, NULL, NULL, NO_CAPTURE); Tcl_DecrRefCount (maskObj); } break; case RcOpBlock: { RcForwardParamBlock* p = (RcForwardParamBlock*) evPtr->param; Tcl_Obj* blockObj = Tcl_NewBooleanObj(!p->nonblocking); if (blockObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcBlock"); } RcInvokeTclMethod (rcPtr, "blocking", blockObj, NULL, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { RcForwardSetObjError (paramPtr, resObj); } } break; case RcOpSetOpt: { RcForwardParamSetOpt* p = (RcForwardParamSetOpt*) paramPtr; Tcl_Obj* optionObj; Tcl_Obj* valueObj; optionObj = Tcl_NewStringObj(p->name,-1); if (optionObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcSetOption"); } valueObj = Tcl_NewStringObj(p->value,-1); if (valueObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcSetOption"); } RcInvokeTclMethod (rcPtr, "configure", optionObj, valueObj, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { RcForwardSetObjError (paramPtr, resObj); } } break; case RcOpGetOpt: { /* Retrieve the value of one option */ RcForwardParamGetOpt* p = (RcForwardParamGetOpt*) paramPtr; Tcl_Obj* optionObj; optionObj = Tcl_NewStringObj(p->name,-1); if (optionObj == (Tcl_Obj*) NULL) { Tcl_Panic ("Out of memory in RcGetOption"); } RcInvokeTclMethod (rcPtr, "cget", optionObj, NULL, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { RcForwardSetObjError (paramPtr, resObj); } else { Tcl_DStringAppend (p->value, Tcl_GetString (resObj), -1); } } break; case RcOpGetOptAll: { /* Retrieve all options. */ RcForwardParamGetOpt* p = (RcForwardParamGetOpt*) paramPtr; RcInvokeTclMethod (rcPtr, "cgetall", NULL, NULL, &res, &resObj, DO_CAPTURE); if (res != TCL_OK) { RcForwardSetObjError (paramPtr, resObj); } else { /* Extract list, validate that it is a list, and * #elements. See NOTE (4) as well. */ int listc; Tcl_Obj** listv; res = Tcl_ListObjGetElements (interp, resObj, &listc, &listv); if (res != TCL_OK) { RcForwardSetObjError (paramPtr, RcErrorMarshall (interp)); } else if ((listc % 2) == 1) { /* Odd number of elements is wrong. * [x]. */ char* buf = ckalloc (200); sprintf (buf, "{Expected list with even number of elements, got %d %s instead}", listc, (listc == 1 ? "element" : "elements")); RcForwardSetDynError (paramPtr, buf); } else { int len; char* str = Tcl_GetStringFromObj (resObj, &len); if (len) { Tcl_DStringAppend (p->value, " ", 1); Tcl_DStringAppend (p->value, str, len); } } } } break; default: /* Bad operation code */ Tcl_Panic ("Bad operation code in RcForwardProc"); break; } /* Remove the reference we held on the result of the invoke, if we had * such */ if (resObj != NULL) { Tcl_DecrRefCount (resObj); } if (resultPtr) { /* * Report the forwarding result synchronously to the waiting * caller. This unblocks (*) as well. This is wrapped into a * conditional because the caller may have exited in the mean * time. */ Tcl_MutexLock(&rcForwardMutex); resultPtr->result = TCL_OK; Tcl_ConditionNotify(&resultPtr->done); Tcl_MutexUnlock(&rcForwardMutex); } return 1; } static void RcSrcExitProc (clientData) ClientData clientData; { RcForwardingEvent* evPtr = (RcForwardingEvent*) clientData; RcForwardingResult* resultPtr; RcForwardParamBase* paramPtr; /* NOTE (2): Can this handler be called with the originator blocked ? * NOTE (2): --- */ /* The originator for the event exited. It is not sure if this * can happen, as the originator should be blocked at (*) while * the event is in transit/pending. */ /* * We make sure that the event cannot refer to the result anymore, * remove it from the list of pending results and free the * structure. Locking the access ensures that we cannot get in * conflict with "RcForwardProc", should it already execute the * event. */ Tcl_MutexLock(&rcForwardMutex); resultPtr = evPtr->resultPtr; paramPtr = (RcForwardParamBase*) evPtr->param; evPtr->resultPtr = NULL; resultPtr->evPtr = NULL; resultPtr->result = TCL_ERROR; RcForwardSetStaticError (paramPtr, msg_send_originlost); /* See below: TclSpliceOut(resultPtr, forwardList); */ Tcl_MutexUnlock(&rcForwardMutex); /* * This unlocks (*). The structure will be spliced out and freed by * "RcForwardProc". Maybe. */ Tcl_ConditionNotify(&resultPtr->done); } static void RcDstExitProc (clientData) ClientData clientData; { RcForwardingEvent* evPtr = (RcForwardingEvent*) clientData; RcForwardingResult* resultPtr = evPtr->resultPtr; RcForwardParamBase* paramPtr = (RcForwardParamBase*) evPtr->param; /* NOTE (3): It is not clear if the event still exists when this handler is called.. * NOTE (3): We might have to use 'resultPtr' as our clientData instead. * NOTE (3): --- */ /* The receiver for the event exited, before processing the * event. We detach the result now, wake the originator up * and signal failure. */ evPtr->resultPtr = NULL; resultPtr->evPtr = NULL; resultPtr->result = TCL_ERROR; RcForwardSetStaticError (paramPtr, msg_send_dstlost); Tcl_ConditionNotify(&resultPtr->done); } static void RcForwardSetObjError (p,obj) RcForwardParamBase* p; Tcl_Obj* obj; { int len; char* msg; msg = Tcl_GetStringFromObj (obj, &len); p->code = TCL_ERROR; p->vol = 1; p->msg = strcpy(ckalloc (1+len), msg); } #endif /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclIOSock.c.
|
| | | | | | | | | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | /* * 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.8.2.1 2005/08/02 18:15:32 dgp Exp $ */ #include "tclInt.h" /* *--------------------------------------------------------------------------- * * TclSockGetPort -- * * Maps from a string, which could be a service name, to a port. Used by * socket creation code to get port numbers and resolve registered * service names to port numbers. * * Results: * A standard Tcl result. On success, the port number is returned in * portPtr. On failure, an error message is left in the interp's result. * * Side effects: * None. * *--------------------------------------------------------------------------- */ |
︙ | ︙ | |||
44 45 46 47 48 49 50 | Tcl_DString ds; CONST char *native; if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) { /* * Don't bother translating 'proto' to native. */ | | | | | 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 | Tcl_DString ds; CONST char *native; if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) { /* * Don't bother translating 'proto' to native. */ native = Tcl_UtfToExternalDString(NULL, string, -1, &ds); sp = getservbyname(native, proto); /* INTL: Native. */ Tcl_DStringFree(&ds); if (sp != NULL) { *portPtr = ntohs((unsigned short) sp->s_port); return TCL_OK; } } if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) { return TCL_ERROR; } if (*portPtr > 0xFFFF) { Tcl_AppendResult(interp, "couldn't open socket: port number too high", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
102 103 104 105 106 107 108 | getsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); if (current < size) { len = sizeof(int); setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len); } return TCL_OK; } | > > > > > > > > | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 | getsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); if (current < size) { len = sizeof(int); setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len); } return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclIOUtil.c.
|
| | | | | | < | | | > | | | | | | | | | | | | < > | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | /* * tclIOUtil.c -- * * This file contains the implementation of Tcl's generic filesystem * code, which supports a pluggable filesystem architecture allowing both * platform specific filesystems and 'virtual filesystems'. All * filesystem access should go through the functions defined in this * file. Most of this code was contributed by Vince Darley. * * Parts of this file are based on code contributed by Karl Lehenbauer, * Mark Diekhans and Peter da Silva. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 2001-2004 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: tclIOUtil.c,v 1.113.2.7 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" #ifdef __WIN32__ # include "tclWinInt.h" #endif #include "tclFileSystem.h" /* * Prototypes for procedures defined later in this file. */ static FilesystemRecord * FsGetFirstFilesystem _ANSI_ARGS_((void)); static void FsThrExitProc _ANSI_ARGS_((ClientData cd)); static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr, CONST char *pattern)); static void FsAddMountsToGlobResult _ANSI_ARGS_(( Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)); static void FsUpdateCwd _ANSI_ARGS_((Tcl_Obj *cwdObj, ClientData clientData)); #ifdef TCL_THREADS static void FsRecacheFilesystemList(void); #endif /* * These form part of the native filesystem support. They are needed here * because we have a few native filesystem functions (which are the same for * win/unix) in this file. There is no need to place them in tclInt.h, * because they are not (and should not be) used anywhere else. */ extern CONST char * tclpFileAttrStrings[]; extern CONST TclFileAttrProcs tclpFileAttrProcs[]; /* * The following functions are obsolete string based APIs, and should be * removed in a future release (Tcl 9 would be a good time). */ /* Obsolete */ int Tcl_Stat(path, oldStyleBuf) CONST char *path; /* Path of file to stat (in current CP). */ struct stat *oldStyleBuf; /* Filled with results of stat call. */ |
︙ | ︙ | |||
83 84 85 86 87 88 89 | /* * Perform the result-buffer overflow check manually. * * Note that ino_t/ino64_t is unsigned... */ | | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 | /* * Perform the result-buffer overflow check manually. * * Note that ino_t/ino64_t is unsigned... */ if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size) #ifdef HAVE_ST_BLOCKS || OUT_OF_RANGE(buf.st_blocks) #endif ) { #ifdef EFBIG errno = EFBIG; #else |
︙ | ︙ | |||
105 106 107 108 109 110 111 | } # undef OUT_OF_RANGE # undef OUT_OF_URANGE #endif /* !TCL_WIDE_INT_IS_LONG */ /* | | | | | | | | | | | | | | | | | | | | > > | | | | | | | < > < > | 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 | } # undef OUT_OF_RANGE # undef OUT_OF_URANGE #endif /* !TCL_WIDE_INT_IS_LONG */ /* * Copy across all supported fields, with possible type coercions on * those fields that change between the normal and lf64 versions of * the stat structure (on Solaris at least.) This is slow when the * structure sizes coincide, but that's what you get for using an * obsolete interface. */ oldStyleBuf->st_mode = buf.st_mode; oldStyleBuf->st_ino = (ino_t) buf.st_ino; oldStyleBuf->st_dev = buf.st_dev; oldStyleBuf->st_rdev = buf.st_rdev; oldStyleBuf->st_nlink = buf.st_nlink; oldStyleBuf->st_uid = buf.st_uid; oldStyleBuf->st_gid = buf.st_gid; oldStyleBuf->st_size = (off_t) buf.st_size; oldStyleBuf->st_atime = buf.st_atime; oldStyleBuf->st_mtime = buf.st_mtime; oldStyleBuf->st_ctime = buf.st_ctime; #ifdef HAVE_ST_BLOCKS oldStyleBuf->st_blksize = buf.st_blksize; oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks; #endif } return ret; } /* Obsolete */ int Tcl_Access(path, mode) CONST char *path; /* Path of file to access (in current CP). */ int mode; /* Permission setting. */ { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); Tcl_IncrRefCount(pathPtr); ret = Tcl_FSAccess(pathPtr,mode); Tcl_DecrRefCount(pathPtr); return ret; } /* Obsolete */ Tcl_Channel Tcl_OpenFileChannel(interp, path, modeString, permissions) Tcl_Interp *interp; /* Interpreter for error reporting; can be * NULL. */ CONST char *path; /* Name of file to open. */ 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; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); Tcl_IncrRefCount(pathPtr); ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions); Tcl_DecrRefCount(pathPtr); return ret; } /* Obsolete */ int Tcl_Chdir(dirName) CONST char *dirName; { |
︙ | ︙ | |||
212 213 214 215 216 217 218 | Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); Tcl_IncrRefCount(pathPtr); ret = Tcl_FSEvalFile(interp, pathPtr); Tcl_DecrRefCount(pathPtr); return ret; } | < | | | | | | | | | | > | < > | | | | | | | | | | | < | | | | < | | | | | | | | | | | | > | | | | < | | | < > | | | | | | | | | | | | | | | | | | | < > | 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 | Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); Tcl_IncrRefCount(pathPtr); ret = Tcl_FSEvalFile(interp, pathPtr); Tcl_DecrRefCount(pathPtr); return ret; } /* * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The * complete, general hooked filesystem APIs should be used instead. This * define decides whether to include the obsolete hooks and related code. If * these are removed, we'll also want to remove them from stubs/tclInt. The * only known users of these APIs are prowrap and mktclapp. New * code/extensions should not use them, since they do not provide as full * support as the full filesystem API. * * As soon as prowrap and mktclapp are updated to use the full filesystem * support, I suggest all these hooks are removed. */ #define USE_OBSOLETE_FS_HOOKS #ifdef USE_OBSOLETE_FS_HOOKS /* * The following typedef declarations allow for hooking into the chain of * functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function a linked * list is defined. */ typedef struct StatProc { TclStatProc_ *proc; /* Function to process a 'stat()' call */ struct StatProc *nextPtr; /* The next 'stat()' function to call */ } StatProc; typedef struct AccessProc { TclAccessProc_ *proc; /* Function to process a 'access()' call */ struct AccessProc *nextPtr; /* The next 'access()' function to call */ } AccessProc; typedef struct OpenFileChannelProc { TclOpenFileChannelProc_ *proc; /* Function to process a * 'Tcl_OpenFileChannel()' call */ struct OpenFileChannelProc *nextPtr; /* The next 'Tcl_OpenFileChannel()' * function to call */ } OpenFileChannelProc; /* * For each type of (obsolete) hookable function, a static node is declared to * hold the function pointer for the "built-in" routine (e.g. 'TclpStat(...)') * and the respective list is initialized as a pointer to that node. * * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that these * statically declared list entry cannot be inadvertently removed. * * This method avoids the need to call any sort of "initialization" function. * * All three lists are protected by a global obsoleteFsHookMutex. */ static StatProc *statProcList = NULL; static AccessProc *accessProcList = NULL; static OpenFileChannelProc *openFileChannelProcList = NULL; TCL_DECLARE_MUTEX(obsoleteFsHookMutex) #endif /* USE_OBSOLETE_FS_HOOKS */ /* * Declare the native filesystem support. These functions should be * considered private to Tcl, and should really not be called directly by any * code other than this file (i.e. neither by Tcl's core nor by extensions). * Similarly, the old string-based Tclp... native filesystem functions should * not be called. * * The correct API to use now is the Tcl_FS... set of functions, which ensure * correct and complete virtual filesystem support. * * We cannot make all of these static, since some of them are implemented in * the platform-specific directories. */ static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; /* * The only reason these functions are not static is that they are either * called by code in the native (win/unix) directories or they are actually * implemented in those directories. They should simply not be called by code * outside Tcl's native filesystem core i.e. they should be considered * 'static' to Tcl's filesystem code (if we ever built the native filesystem * support into a separate code library, this could actually be enforced). */ Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType; Tcl_FSInternalToNormalizedProc TclpNativeToNormalized; Tcl_FSStatProc TclpObjStat; Tcl_FSAccessProc TclpObjAccess; Tcl_FSMatchInDirectoryProc TclpMatchInDirectory; Tcl_FSChdirProc TclpObjChdir; Tcl_FSLstatProc TclpObjLstat; Tcl_FSCopyFileProc TclpObjCopyFile; Tcl_FSDeleteFileProc TclpObjDeleteFile; Tcl_FSRenameFileProc TclpObjRenameFile; 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! */ Tcl_Filesystem tclNativeFilesystem = { "native", sizeof(Tcl_Filesystem), TCL_FILESYSTEM_VERSION_2, &TclNativePathInFilesystem, &TclNativeDupInternalRep, &NativeFreeInternalRep, |
︙ | ︙ | |||
358 359 360 361 362 363 364 | &TclpObjLink, #endif /* S_IFLNK */ &TclpObjListVolumes, &NativeFileAttrStrings, &NativeFileAttrsGet, &NativeFileAttrsSet, &TclpObjCreateDirectory, | | | | | | | | | | | > | | | < | > | | | > | > | | < > | | | | | | > | | > | > | > | > > > > | > > | | | | | | | | | | | | | | | | | | | | > | | | > > | > > | | < | > > < > | > > | > | > > | | 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 | &TclpObjLink, #endif /* S_IFLNK */ &TclpObjListVolumes, &NativeFileAttrStrings, &NativeFileAttrsGet, &NativeFileAttrsSet, &TclpObjCreateDirectory, &TclpObjRemoveDirectory, &TclpObjDeleteFile, &TclpObjCopyFile, &TclpObjRenameFile, &TclpObjCopyDirectory, &TclpObjLstat, &TclpDlopen, /* Needs a cast since we're using version_2 */ (Tcl_FSGetCwdProc*)&TclpGetNativeCwd, &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 }; /* * This is incremented each time we modify the linked list of filesystems. * Any time it changes, all cached filesystem representations are suspect and * must be freed. For multithreading builds, change of the filesystem epoch * will trigger cache cleanup in all threads. */ static int theFilesystemEpoch = 0; /* * Stores the linked list of filesystems. A 1:1 copy of this list is also * maintained in the TSD for each thread. This is to avoid synchronization * issues. */ static FilesystemRecord *filesystemList = &nativeFilesystemRecord; TCL_DECLARE_MUTEX(filesystemMutex) /* * Used to implement Tcl_FSGetCwd in a file-system independent way. */ static Tcl_Obj* cwdPathPtr = NULL; static int cwdPathEpoch = 0; static ClientData cwdClientData = NULL; TCL_DECLARE_MUTEX(cwdMutex) Tcl_ThreadDataKey tclFsDataKey; /* * Declare fallback support function and information for Tcl_FSLoadFile */ static Tcl_FSUnloadFileProc FSUnloadTempFile; /* * One of these structures is used each time we successfully load a 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 */ static void FsThrExitProc(cd) ClientData cd; { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) cd; FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL; /* * Trash the cwd copy. */ if (tsdPtr->cwdPathPtr != NULL) { Tcl_DecrRefCount(tsdPtr->cwdPathPtr); } if (tsdPtr->cwdClientData != NULL) { NativeFreeInternalRep(tsdPtr->cwdClientData); } /* * Trash the filesystems cache. */ fsRecPtr = tsdPtr->filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr->nextPtr; if (--fsRecPtr->fileRefCount <= 0) { ckfree((char *)fsRecPtr); } fsRecPtr = tmpFsRecPtr; } } int TclFSCwdIsNative() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (tsdPtr->cwdClientData != NULL) { return 1; } else { return 0; } } /* *---------------------------------------------------------------------- * * TclFSCwdPointerEquals -- * * Check whether the current working directory is equal to the path * given. * * Results: * 1 (equal) or 0 (un-equal) as appropriate. * * Side effects: * If the paths are equal, but are not the same object, this method will * modify the given pathPtrPtr to refer to the same object. In this case * the object pointed to by pathPtrPtr will have its refCount * decremented, and it will be adjusted to point to the cwd (with a new * refCount). * *---------------------------------------------------------------------- */ int TclFSCwdPointerEquals(pathPtrPtr) Tcl_Obj** pathPtrPtr; { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); Tcl_MutexLock(&cwdMutex); if (tsdPtr->cwdPathPtr == NULL || tsdPtr->cwdPathEpoch != cwdPathEpoch) { if (tsdPtr->cwdPathPtr != NULL) { Tcl_DecrRefCount(tsdPtr->cwdPathPtr); } if (tsdPtr->cwdClientData != NULL) { NativeFreeInternalRep(tsdPtr->cwdClientData); } if (cwdPathPtr == NULL) { tsdPtr->cwdPathPtr = NULL; } else { tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr); Tcl_IncrRefCount(tsdPtr->cwdPathPtr); } if (cwdClientData == NULL) { tsdPtr->cwdClientData = NULL; } else { tsdPtr->cwdClientData = TclNativeDupInternalRep(cwdClientData); } tsdPtr->cwdPathEpoch = cwdPathEpoch; } Tcl_MutexUnlock(&cwdMutex); if (tsdPtr->initialized == 0) { Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); tsdPtr->initialized = 1; } if (pathPtrPtr == NULL) { return (tsdPtr->cwdPathPtr == NULL); } if (tsdPtr->cwdPathPtr == *pathPtrPtr) { return 1; } else { int len1, len2; CONST char *str1, *str2; str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); if (len1 == len2 && !strcmp(str1,str2)) { /* * They are equal, but different objects. Update so they will be * the same object in the future. */ Tcl_DecrRefCount(*pathPtrPtr); *pathPtrPtr = tsdPtr->cwdPathPtr; Tcl_IncrRefCount(*pathPtrPtr); return 1; } else { return 0; } } } #ifdef TCL_THREADS static void FsRecacheFilesystemList(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL; /* * Trash the current cache. */ fsRecPtr = tsdPtr->filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr->nextPtr; if (--fsRecPtr->fileRefCount <= 0) { ckfree((char *)fsRecPtr); } fsRecPtr = tmpFsRecPtr; } tsdPtr->filesystemList = NULL; /* * Code below operates on shared data. We are already called under mutex * lock so we can safely proceede. * * Locate tail of the global filesystem list. */ fsRecPtr = filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr; fsRecPtr = fsRecPtr->nextPtr; } /* * Refill the cache honouring the order. */ fsRecPtr = tmpFsRecPtr; while (fsRecPtr != NULL) { tmpFsRecPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); *tmpFsRecPtr = *fsRecPtr; tmpFsRecPtr->nextPtr = tsdPtr->filesystemList; tmpFsRecPtr->prevPtr = NULL; if (tsdPtr->filesystemList) { tsdPtr->filesystemList->prevPtr = tmpFsRecPtr; } tsdPtr->filesystemList = tmpFsRecPtr; fsRecPtr = fsRecPtr->prevPtr; } /* * Make sure the above gets released on thread exit. */ if (tsdPtr->initialized == 0) { Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); tsdPtr->initialized = 1; } } #endif /* TCL_THREADS */ static FilesystemRecord * FsGetFirstFilesystem(void) { |
︙ | ︙ | |||
630 631 632 633 634 635 636 | Tcl_MutexUnlock(&filesystemMutex); fsRecPtr = tsdPtr->filesystemList; #endif return fsRecPtr; } /* | | | > | | | > | > > | > > | > | > | | | | | | | | | | | | | | > | > > | | | | | | | | > | | | < | | | | < > | | | < | | | | | | | | | | | | | | | | > | | | > | | | | < | | | | | | > | | | | > | | < | | | | | | | | | | | | | > | | | | | < | > | | | | | | | | | | | | | | | | | | | | | | | | | < | < | | | | | | > | | | | | | > | | | | | | | | | | | < | | | | | > > | > > | | | | | | | | | 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 | Tcl_MutexUnlock(&filesystemMutex); fsRecPtr = tsdPtr->filesystemList; #endif return fsRecPtr; } /* * The epoch can be changed both by filesystems being added or removed and by * env(HOME) changing. */ int TclFSEpochOk(filesystemEpoch) int filesystemEpoch; { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); (void) FsGetFirstFilesystem(); return (filesystemEpoch == tsdPtr->filesystemEpoch); } /* * If non-NULL, clientData is owned by us and must be freed later. */ static void FsUpdateCwd(cwdObj, clientData) Tcl_Obj *cwdObj; ClientData clientData; { int len; char *str = NULL; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (cwdObj != NULL) { str = Tcl_GetStringFromObj(cwdObj, &len); } Tcl_MutexLock(&cwdMutex); if (cwdPathPtr != NULL) { Tcl_DecrRefCount(cwdPathPtr); } if (cwdClientData != NULL) { NativeFreeInternalRep(cwdClientData); } if (cwdObj == NULL) { cwdPathPtr = NULL; cwdClientData = NULL; } else { /* * This must be stored as string obj! */ cwdPathPtr = Tcl_NewStringObj(str, len); Tcl_IncrRefCount(cwdPathPtr); cwdClientData = TclNativeDupInternalRep(clientData); } cwdPathEpoch++; tsdPtr->cwdPathEpoch = cwdPathEpoch; Tcl_MutexUnlock(&cwdMutex); if (tsdPtr->cwdPathPtr) { Tcl_DecrRefCount(tsdPtr->cwdPathPtr); } if (tsdPtr->cwdClientData) { NativeFreeInternalRep(tsdPtr->cwdClientData); } if (cwdObj == NULL) { tsdPtr->cwdPathPtr = NULL; tsdPtr->cwdClientData = NULL; } else { tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len); tsdPtr->cwdClientData = clientData; Tcl_IncrRefCount(tsdPtr->cwdPathPtr); } } /* *---------------------------------------------------------------------- * * TclFinalizeFilesystem -- * * Clean up the filesystem. After this, calls to all Tcl_FS... * functions will fail. * * We will later call TclResetFilesystem to restore the FS to a pristine * state. * * Results: * None. * * Side effects: * Frees any memory allocated by the filesystem. * *---------------------------------------------------------------------- */ void TclFinalizeFilesystem() { FilesystemRecord *fsRecPtr; /* * Assumption that only one thread is active now. Otherwise we would need * to put various mutexes around this code. */ if (cwdPathPtr != NULL) { Tcl_DecrRefCount(cwdPathPtr); cwdPathPtr = NULL; cwdPathEpoch = 0; } if (cwdClientData != NULL) { NativeFreeInternalRep(cwdClientData); cwdClientData = NULL; } /* * Remove all filesystems, freeing any allocated memory that is no longer * needed */ fsRecPtr = filesystemList; while (fsRecPtr != NULL) { FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; if (fsRecPtr->fileRefCount <= 0) { /* * The native filesystem is static, so we don't free it. */ if (fsRecPtr != &nativeFilesystemRecord) { ckfree((char *)fsRecPtr); } } fsRecPtr = tmpFsRecPtr; } filesystemList = NULL; /* * Now filesystemList is NULL. This means that any attempt to use the * filesystem is likely to fail. */ statProcList = NULL; accessProcList = NULL; openFileChannelProcList = NULL; #ifdef __WIN32__ TclWinEncodingsCleanup(); #endif } /* *---------------------------------------------------------------------- * * TclResetFilesystem -- * * Restore the filesystem to a pristine state. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TclResetFilesystem() { filesystemList = &nativeFilesystemRecord; /* * Note, at this point, I believe nativeFilesystemRecord -> fileRefCount * should equal 1 and if not, we should try to track down the cause. */ #ifdef __WIN32__ /* * Cleans up the win32 API filesystem proc lookup table. This must happen * very late in finalization so that deleting of copied dlls can occur. */ TclWinResetInterfaces(); #endif } /* *---------------------------------------------------------------------- * * Tcl_FSRegister -- * * Insert the filesystem function table at the head of the list of * functions which are used during calls to all file-system operations. * The filesystem will be added even if it is already in the list. (You * can use Tcl_FSData to check if it is in the list, provided the * ClientData used was not NULL). * * Note that the filesystem handling is head-to-tail of the list. Each * filesystem is asked in turn whether it can handle a particular * request, until one of them says 'yes'. At that point no further * filesystems are asked. * * In particular this means if you want to add a diagnostic filesystem * (which simply reports all fs activity), it must be at the head of the * list: i.e. it must be the last registered. * * Results: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could * not be allocated. * * Side effects: * Memory allocated and modifies the link list for filesystems. * *---------------------------------------------------------------------- */ int Tcl_FSRegister(clientData, fsPtr) ClientData clientData; /* Client specific data for this fs */ Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */ { FilesystemRecord *newFilesystemPtr; if (fsPtr == NULL) { return TCL_ERROR; } newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); newFilesystemPtr->clientData = clientData; newFilesystemPtr->fsPtr = fsPtr; /* * We start with a refCount of 1. If this drops to zero, then anyone is * welcome to ckfree us. */ newFilesystemPtr->fileRefCount = 1; /* * Is this lock and wait strictly speaking necessary? Since any iterators * out there will have grabbed a copy of the head of the list and be * iterating away from that, if we add a new element to the head of the * list, it can't possibly have any effect on any of their loops. In fact * it could be better not to wait, since we are adjusting the filesystem * epoch, any cached representations calculated by existing iterators are * going to have to be thrown away anyway. * * However, since registering and unregistering filesystems is a very rare * action, this is not a very important point. */ Tcl_MutexLock(&filesystemMutex); newFilesystemPtr->nextPtr = filesystemList; newFilesystemPtr->prevPtr = NULL; if (filesystemList) { filesystemList->prevPtr = newFilesystemPtr; } filesystemList = newFilesystemPtr; /* * Increment the filesystem epoch counter, since existing paths might * conceivably now belong to different filesystems. */ theFilesystemEpoch++; Tcl_MutexUnlock(&filesystemMutex); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_FSUnregister -- * * Remove the passed filesystem from the list of filesystem function * tables. It also ensures that the built-in (native) filesystem is not * removable, although we may wish to change that decision in the future * to allow a smaller Tcl core, in which the native filesystem is not * used at all (we could, say, initialise Tcl completely over a network * connection). * * Results: * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR * otherwise. * * Side effects: * Memory may be deallocated (or will be later, once no "path" objects * refer to this filesystem), but the list of registered filesystems is * updated immediately. * *---------------------------------------------------------------------- */ int Tcl_FSUnregister(fsPtr) Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */ { int retVal = TCL_ERROR; FilesystemRecord *fsRecPtr; Tcl_MutexLock(&filesystemMutex); /* * Traverse the 'filesystemList' looking for the particular node whose * 'fsPtr' member matches 'fsPtr' and remove that one from the list. * Ensure that the "default" node cannot be removed. */ fsRecPtr = filesystemList; while ((retVal == TCL_ERROR) && (fsRecPtr != &nativeFilesystemRecord)) { if (fsRecPtr->fsPtr == fsPtr) { if (fsRecPtr->prevPtr) { fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr; } else { filesystemList = fsRecPtr->nextPtr; } if (fsRecPtr->nextPtr) { fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr; } /* * Increment the filesystem epoch counter, since existing paths * might conceivably now belong to different filesystems. This * should also ensure that paths which have cached the filesystem * which is about to be deleted do not reference that filesystem * (which would of course lead to memory exceptions). */ theFilesystemEpoch++; fsRecPtr->fileRefCount--; if (fsRecPtr->fileRefCount <= 0) { ckfree((char *)fsRecPtr); } retVal = TCL_OK; } else { fsRecPtr = fsRecPtr->nextPtr; } } Tcl_MutexUnlock(&filesystemMutex); return retVal; } /* *---------------------------------------------------------------------- * * Tcl_FSMatchInDirectory -- * * This routine is used by the globbing code to search a directory for * all files which match a given pattern. The appropriate function for * the filesystem to which pathPtr belongs will be called. If pathPtr * does not belong to any filesystem and if it is NULL or the empty * string, then we assume the pattern is to be matched in the current * working directory. To avoid have the Tcl_FSMatchInDirectoryProc for * each filesystem from having to deal with this issue, we create a * pathPtr on the fly (equal to the cwd), and then remove it from the * results returned. This makes filesystems easy to write, since they * can assume the pathPtr passed to them is an ordinary path. In fact * this means we could remove such special case handling from Tcl's * native filesystems. * * If 'pattern' is NULL, then pathPtr is assumed to be a fully specified * path of a single file/directory which must be checked for existence * and correct type. * * Results: * * The return value is a standard Tcl result indicating whether an error * occurred in globbing. Error messages are placed in interp, but good * results are placed in the resultPtr given. * * Recursive searches, e.g. * glob -dir $dir -join * pkgIndex.tcl * which must recurse through each directory matching '*' are handled * internally by Tcl, by passing specific flags in a modified 'types' * parameter. This means the actual filesystem only ever sees patterns * which match in a single directory. * * Side effects: * The interpreter may have an error message inserted into it. * *---------------------------------------------------------------------- */ int Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) Tcl_Interp *interp; /* Interpreter to receive error * messages, but may be NULL. */ Tcl_Obj *resultPtr; /* List object to receive results. */ Tcl_Obj *pathPtr; /* Contains path to directory to search. */ CONST char *pattern; /* Pattern to match against. */ Tcl_GlobTypeData *types; /* Object containing list of acceptable types. * May be NULL. In particular the directory * flag is very important. */ { Tcl_Filesystem *fsPtr; Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr; int resLength, i, ret = -1; if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) { /* * We don't currently allow querying of mounts by external code (a * valuable future step), so since we're the only function that * actually knows about mounts, this means we're being called * recursively by ourself. Return no matches. */ return TCL_OK; } if (pathPtr != NULL) { fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); } else { fsPtr = NULL; } /* * Check if we've successfully mapped the path to a filesystem within * which to search. */ if (fsPtr != NULL) { if (fsPtr->matchInDirectoryProc == NULL) { Tcl_SetErrno(ENOENT); return -1; } ret = (*fsPtr->matchInDirectoryProc)(interp, resultPtr, pathPtr, pattern, types); if (ret == TCL_OK && pattern != NULL) { FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types); } return ret; } /* * If the path isn't empty, we have no idea how to match files in a * directory which belongs to no known filesystem */ if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') { Tcl_SetErrno(ENOENT); return -1; } /* * We have an empty or NULL path. This is defined to mean we must search * for files within the current 'cwd'. We therefore use that, but then * since the proc we call will return results which include the cwd we * must then trim it off the front of each path in the result. We choose * to deal with this here (in the generic code), since if we don't, every * single filesystem's implementation of Tcl_FSMatchInDirectory will have * to deal with it for us. */ cwd = Tcl_FSGetCwd(NULL); if (cwd == NULL) { if (interp != NULL) { Tcl_SetResult(interp, "glob couldn't determine " "the current working directory", TCL_STATIC); } return TCL_ERROR; } fsPtr = Tcl_FSGetFileSystemForPath(cwd); if (fsPtr != NULL && fsPtr->matchInDirectoryProc != NULL) { TclNewObj(tmpResultPtr); Tcl_IncrRefCount(tmpResultPtr); ret = (*fsPtr->matchInDirectoryProc)(interp, tmpResultPtr, cwd, pattern, types); if (ret == TCL_OK) { FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types); /* * Note that we know resultPtr and tmpResultPtr are distinct. */ ret = Tcl_ListObjGetElements(interp, tmpResultPtr, &resLength, &elemsPtr); for (i=0 ; ret==TCL_OK && i<resLength ; i++) { ret = Tcl_ListObjAppendElement(interp, resultPtr, TclFSMakePathRelative(interp, elemsPtr[i], cwd)); } } TclDecrRefCount(tmpResultPtr); } Tcl_DecrRefCount(cwd); return ret; } /* *---------------------------------------------------------------------- * * FsAddMountsToGlobResult -- * * This routine is used by the globbing code to take the results of a * directory listing and add any mounted paths to that listing. This is * required so that simple things like 'glob *' merge mounts and listings * correctly. * * Results: * None. * * Side effects: * Modifies the resultPtr. * *---------------------------------------------------------------------- */ static void FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types) Tcl_Obj *resultPtr; /* The current list of matching paths; must * not be shared! */ Tcl_Obj *pathPtr; /* The directory in question */ |
︙ | ︙ | |||
1147 1148 1149 1150 1151 1152 1153 | if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) { goto endOfMounts; } if (Tcl_ListObjLength(NULL, resultPtr, &gLength) != TCL_OK) { goto endOfMounts; } | | | | > | > > | < | | | | | | | < | > | | | | > | > > | | | | > | | < | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | < | | | | < | | | | > > | | | > | | | | | | | | | < | | < | | | | | < | | | < | | | < > > | | | | < | | | | | | | | | | | | > | > > > | < | < > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > | | > | | > > | | | | | | | | > > > | | | > | | | | | | | | | | | | | | | > > | | < | | | > > > > > > | | | > > | > > > | | | | | | | | | | | | | | | | > | | | | > > | | | | | > > > > | | | | > | > > | | | | > | > > | | | | | | | < | | | | | | > | | < > > | < | > > | | > | > | | | > < < < < | > | > | < < | < < < | | | | | | 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 | if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) { goto endOfMounts; } if (Tcl_ListObjLength(NULL, resultPtr, &gLength) != TCL_OK) { goto endOfMounts; } for (i=0 ; i<mLength ; i++) { Tcl_Obj *mElt; int j; int found = 0; Tcl_ListObjIndex(NULL, mounts, i, &mElt); for (j=0 ; j<gLength ; j++) { Tcl_Obj *gElt; Tcl_ListObjIndex(NULL, resultPtr, j, &gElt); if (Tcl_FSEqualPaths(mElt, gElt)) { found = 1; if (!dir) { /* * We don't want to list this. */ Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL); gLength--; } break; /* Break out of for loop */ } } if (!found && dir) { int len, mlen; CONST char *path; CONST char *mount; /* * We know mElt is absolute normalized and lies inside pathPtr, so * now we must add to the result the right representation of mElt, * i.e. the representation which is relative to pathPtr. */ mount = Tcl_GetStringFromObj(mElt, &mlen); path = Tcl_GetStringFromObj(Tcl_FSGetNormalizedPath(NULL, pathPtr), &len); if (path[len-1] == '/') { /* * Deal with the root of the volume. */ len--; } mElt = TclNewFSPathObj(pathPtr, mount + len + 1, mlen - len); Tcl_ListObjAppendElement(NULL, resultPtr, mElt); /* * No need to increment gLength, since we don't want to compare * mounts against mounts. */ } } endOfMounts: Tcl_DecrRefCount(mounts); } /* *---------------------------------------------------------------------- * * Tcl_FSMountsChanged -- * * Notify the filesystem that the available mounted filesystems (or * within any one filesystem type, the number or location of mount * points) have changed. * * Results: * None. * * Side effects: * The global filesystem variable 'theFilesystemEpoch' is incremented. * The effect of this is to make all cached path representations invalid. * Clearly it should only therefore be called when it is really required! * There are a few circumstances when it should be called: * * (1) when a new filesystem is registered or unregistered. Strictly * speaking this is only necessary if the new filesystem accepts file * paths as is (normally the filesystem itself is really a shell which * hasn't yet had any mount points established and so its * 'pathInFilesystem' proc will always fail). However, for safety, Tcl * always calls this for you in these circumstances. * * (2) when additional mount points are established inside any existing * filesystem (except the native fs) * * (3) when any filesystem (except the native fs) changes the list of * available volumes. * * (4) when the mapping from a string representation of a file to a full, * normalized path changes. For example, if 'env(HOME)' is modified, then * any path containing '~' will map to a different filesystem location. * Therefore all such paths need to have their internal representation * invalidated. * * Tcl has no control over (2) and (3), so any registered filesystem must * make sure it calls this function when those situations occur. * * (Note: the reason for the exception in 2,3 for the native filesystem * is that the native filesystem by default claims all unknown files even * if it really doesn't understand them or if they don't exist). * *---------------------------------------------------------------------- */ void Tcl_FSMountsChanged(fsPtr) Tcl_Filesystem *fsPtr; { /* * We currently don't do anything with this parameter. We could in the * future only invalidate files for this filesystem or otherwise take more * advanced action. */ (void)fsPtr; /* * Increment the filesystem epoch counter, since existing paths might now * belong to different filesystems. */ Tcl_MutexLock(&filesystemMutex); theFilesystemEpoch++; Tcl_MutexUnlock(&filesystemMutex); } /* *---------------------------------------------------------------------- * * Tcl_FSData -- * * Retrieve the clientData field for the filesystem given, or NULL if * that filesystem is not registered. * * Results: * A clientData value, or NULL. Note that if the filesystem was * registered with a NULL clientData field, this function will return * that NULL value. * * Side effects: * None. * *---------------------------------------------------------------------- */ ClientData Tcl_FSData(fsPtr) Tcl_Filesystem *fsPtr; /* The filesystem record to query. */ { ClientData retVal = NULL; FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); /* * Traverse the list of filesystems look for a particular one. If found, * return that filesystem's clientData (originally provided when calling * Tcl_FSRegister). */ while ((retVal == NULL) && (fsRecPtr != NULL)) { if (fsRecPtr->fsPtr == fsPtr) { retVal = fsRecPtr->clientData; } fsRecPtr = fsRecPtr->nextPtr; } return retVal; } /* *--------------------------------------------------------------------------- * * TclFSNormalizeToUniquePath -- * * Takes a path specification containing no ../, ./ sequences, and * converts it into a unique path for the given platform. On Unix, this * means the path must be free of symbolic links/aliases, and on Windows * it means we want the long form, with that long form's case-dependence * (which gives us a unique, case-dependent path). * * Results: * The pathPtr is modified in place. The return value is the last byte * offset which was recognised in the path string. * * Side effects: * None (beyond the memory allocation for the result). * * Special notes: * If the filesystem-specific normalizePathProcs can re-introduce ../, ./ * sequences into the path, then this function will not return the * correct result. This may be possible with symbolic links on unix. * * Important assumption: if startAt is non-zero, it must point to a * directory separator that we know exists and is already normalized (so * it is important not to point to the char just after the separator). * *--------------------------------------------------------------------------- */ int TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) Tcl_Interp *interp; /* Used for error messages. */ Tcl_Obj *pathPtr; /* The path to normalize in place */ int startAt; /* Start at this char-offset */ ClientData *clientDataPtr; /* If we generated a complete normalized path * for a given filesystem, we can optionally * return an fs-specific clientdata here. */ { FilesystemRecord *fsRecPtr, *firstFsRecPtr; /* Ignore this variable */ (void) clientDataPtr; /* * Call each of the "normalise path" functions in succession. This is a * special case, in which if we have a native filesystem handler, we call * it first. This is because the root of Tcl's filesystem is always a * native filesystem (i.e. '/' on unix is native). */ firstFsRecPtr = FsGetFirstFilesystem(); fsRecPtr = firstFsRecPtr; while (fsRecPtr != NULL) { if (fsRecPtr == &nativeFilesystemRecord) { Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; if (proc != NULL) { startAt = (*proc)(interp, pathPtr, startAt); } break; } fsRecPtr = fsRecPtr->nextPtr; } fsRecPtr = firstFsRecPtr; while (fsRecPtr != NULL) { /* * Skip the native system next time through. */ if (fsRecPtr != &nativeFilesystemRecord) { Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; if (proc != NULL) { startAt = (*proc)(interp, pathPtr, startAt); } /* * We could add an efficiency check like this: * if (retVal == length-of(pathPtr)) {break;} * but there's not much benefit. */ } fsRecPtr = fsRecPtr->nextPtr; } return startAt; } /* *--------------------------------------------------------------------------- * * TclGetOpenMode -- * * This routine is an obsolete, limited version of TclGetOpenModeEx() * below. It exists only to satisfy any extensions imprudently using it * via Tcl's internal stubs table. * * Results: * Same as TclGetOpenModeEx(). * * Side effects: * Same as TclGetOpenModeEx(). * *--------------------------------------------------------------------------- */ int TclGetOpenMode(interp, modeString, seekFlagPtr) Tcl_Interp *interp; /* Interpreter to use for error * reporting - may be NULL. */ CONST char *modeString; /* Mode string, e.g. "r+" or "RDONLY * CREAT". */ int *seekFlagPtr; /* Set this to 1 if the caller should * seek to EOF during the opening of * the file. */ { int binary = 0; return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary); } /* *--------------------------------------------------------------------------- * * TclGetOpenModeEx -- * * Computes a POSIX mode mask for opening a file, from a given string, * and also sets flags to indicate whether the caller should seek to EOF * after opening the file, and whether the caller should configure the * channel for binary data. * * Results: * On success, returns mode to pass to "open". If an error occurs, the * return value is -1 and if interp is not NULL, sets interp's result * object to an error message. * * Side effects: * Sets the integer referenced by seekFlagPtr to 1 to tell the caller to * seek to EOF after opening the file, or to 0 otherwise. Sets the * integer referenced by binaryPtr to 1 to tell the caller to seek to * configure the channel for binary data, or to 0 otherwise. * * Special note: * This code is based on a prototype implementation contributed by Mark * Diekhans. * *--------------------------------------------------------------------------- */ int TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) Tcl_Interp *interp; /* Interpreter to use for error * reporting - may be NULL. */ CONST char *modeString; /* Mode string, e.g. "r+" or "RDONLY * CREAT". */ int *seekFlagPtr; /* Set this to 1 if the caller should * seek to EOF during the opening of * the file. */ int *binaryPtr; /* Set this to 1 if the caller should * configure the opened channel for * binary operations */ { int mode, modeArgc, c, i, gotRW; CONST char **modeArgv, *flag; #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) /* * Check for the simpler fopen-like access modes (e.g. "r"). They are * distinguished from the POSIX access modes by the presence of a * lower-case first letter. */ *seekFlagPtr = 0; *binaryPtr = 0; mode = 0; /* * Guard against international characters before using byte oriented * routines. */ if (!(modeString[0] & 0x80) && islower(UCHAR(modeString[0]))) { /* INTL: ISO only. */ switch (modeString[0]) { case 'r': mode = O_RDONLY; break; case 'w': mode = O_WRONLY|O_CREAT|O_TRUNC; break; case 'a': mode = O_WRONLY|O_CREAT; *seekFlagPtr = 1; break; default: error: *seekFlagPtr = 0; *binaryPtr = 0; if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "illegal access mode \"", modeString, "\"", (char *) NULL); } return -1; } i=1; while (i<3 && modeString[i]) { if (modeString[i] == modeString[i-1]) { goto error; } switch (modeString[i++]) { case '+': mode &= ~(O_RDONLY|O_WRONLY); mode |= O_RDWR; break; case 'b': *binaryPtr = 1; break; default: goto error; } } if (modeString[i] != 0) { goto error; } return mode; } /* * The access modes are specified using a list of POSIX modes such as * O_CREAT. * * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when a NULL * interpreter is passed in. */ if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) { if (interp != (Tcl_Interp *) NULL) { Tcl_AddErrorInfo(interp, "\n while processing open access modes \""); Tcl_AddErrorInfo(interp, modeString); Tcl_AddErrorInfo(interp, "\""); } return -1; } gotRW = 0; for (i = 0; i < modeArgc; i++) { flag = modeArgv[i]; c = flag[0]; if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { mode = (mode & ~RW_MODES) | O_RDONLY; gotRW = 1; } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) { mode = (mode & ~RW_MODES) | O_WRONLY; gotRW = 1; } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) { mode = (mode & ~RW_MODES) | O_RDWR; gotRW = 1; } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { mode |= O_APPEND; *seekFlagPtr = 1; } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { mode |= O_CREAT; } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { mode |= O_EXCL; } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { #ifdef O_NOCTTY mode |= O_NOCTTY; #else if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "access mode \"", flag, "\" not supported by this system", (char *) NULL); } ckfree((char *) modeArgv); return -1; #endif } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { #if defined(O_NDELAY) || defined(O_NONBLOCK) # ifdef O_NONBLOCK mode |= O_NONBLOCK; # else mode |= O_NDELAY; # endif #else if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "access mode \"", flag, "\" not supported by this system", (char *) NULL); } ckfree((char *) modeArgv); return -1; #endif } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { mode |= O_TRUNC; } else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) { *binaryPtr = 1; } else { if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "invalid access mode \"", flag, "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, " "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL); } ckfree((char *) modeArgv); return -1; } } ckfree((char *) modeArgv); if (!gotRW) { if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "access mode must include either", " RDONLY, WRONLY, or RDWR", (char *) NULL); } return -1; } return mode; } /* * Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument. */ int Tcl_FSEvalFile(interp, pathPtr) Tcl_Interp *interp; /* Interpreter in which to process file. */ Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution * will be performed on this name. */ { return Tcl_FSEvalFileEx(interp, pathPtr, NULL); } /* *---------------------------------------------------------------------- * * Tcl_FSEvalFileEx -- * * Read in a file and process the entire file as one gigantic Tcl * command. * * Results: * A standard Tcl result, which is either the result of executing the * file or an error indicating why the file couldn't be read. * * Side effects: * Depends on the commands in the file. During the evaluation of the * contents of the file, iPtr->scriptFile is made to point to pathPtr * (the old value is cached and replaced when this function returns). * *---------------------------------------------------------------------- */ int Tcl_FSEvalFileEx(interp, pathPtr, encodingName) Tcl_Interp *interp; /* Interpreter in which to process file. */ Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution * will be performed on this name. */ CONST char *encodingName; /* If non-NULL, then use this encoding for the * file. */ { int result, length; Tcl_StatBuf statBuf; Tcl_Obj *oldScriptFile; Interp *iPtr; char *string; Tcl_Channel chan; Tcl_Obj *objPtr; if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { return TCL_ERROR; } result = TCL_ERROR; objPtr = Tcl_NewObj(); if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); Tcl_AppendResult(interp, "couldn't read file \"", Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == (Tcl_Channel) NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't read file \"", Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } /* * The eofchar is \32 (^Z). This is the usual on Windows, but we effect * this cross-platform to allow for scripted documents. [Bug: 2040] */ Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); /* * If the encoding is specified, set it for the channel. Else don't touch * it (and use the system encoding) Report error on unknown encoding. */ if (encodingName != NULL) { if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) != TCL_OK) { Tcl_Close(interp,chan); goto end; } } if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { Tcl_Close(interp, chan); Tcl_AppendResult(interp, "couldn't read file \"", Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } if (Tcl_Close(interp, chan) != TCL_OK) { goto end; } iPtr = (Interp *) interp; oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); string = Tcl_GetStringFromObj(objPtr, &length); result = Tcl_EvalEx(interp, string, length, 0); /* * Now we have to be careful; the script may have changed the * iPtr->scriptFile value, so we must reset it without assuming it still * points to 'pathPtr'. */ if (iPtr->scriptFile != NULL) { Tcl_DecrRefCount(iPtr->scriptFile); } iPtr->scriptFile = oldScriptFile; if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { /* * Record information telling where the error occurred. */ CONST char *pathString = Tcl_GetStringFromObj(pathPtr, &length); int limit = 150; int overflow = (length > limit); TclFormatToErrorInfo(interp, "\n (file \"%.*s%s\" line %d)", (overflow ? limit : length), pathString, (overflow ? "..." : ""), interp->errorLine); } end: Tcl_DecrRefCount(objPtr); return result; } /* *---------------------------------------------------------------------- * * Tcl_GetErrno -- * * Gets the current value of the Tcl error code variable. This is * currently the global variable "errno" but could in the future change * to something else. * * Results: * The value of the Tcl error code variable. * * Side effects: * None. Note that the value of the Tcl error code variable is UNDEFINED * if a call to Tcl_SetErrno did not precede this call. * *---------------------------------------------------------------------- */ int Tcl_GetErrno() { |
︙ | ︙ | |||
1771 1772 1773 1774 1775 1776 1777 | } /* *---------------------------------------------------------------------- * * Tcl_PosixError -- * | | | | | | < | | | | | | | | | | | | > | > | | < | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_PosixError -- * * This procedure is typically called after UNIX kernel calls return * errors. It stores machine-readable information about the error in * errorCode field of interp and returns an information string for the * caller's use. * * Results: * The return value is a human-readable string describing the error. * * Side effects: * The errorCode field of the interp is set. * *---------------------------------------------------------------------- */ CONST char * Tcl_PosixError(interp) Tcl_Interp *interp; /* Interpreter whose errorCode field * is to be set. */ { CONST char *id, *msg; msg = Tcl_ErrnoMsg(errno); id = Tcl_ErrnoId(); Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); return msg; } /* *---------------------------------------------------------------------- * * Tcl_FSStat -- * * This procedure replaces the library version of stat and lsat. * * The appropriate function for the filesystem to which pathPtr belongs * will be called. * * Results: * See stat documentation. * * Side effects: * See stat documentation. * *---------------------------------------------------------------------- */ int Tcl_FSStat(pathPtr, buf) Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ Tcl_StatBuf *buf; /* Filled with results of stat call. */ { Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS struct stat oldStyleStatBuffer; int retVal = -1; /* * Call each of the "stat" function in succession. A non-return value of * -1 indicates the particular function has succeeded. */ Tcl_MutexLock(&obsoleteFsHookMutex); if (statProcList != NULL) { StatProc *statProcPtr; char *path; Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); if (transPtr == NULL) { path = NULL; } else { path = Tcl_GetString(transPtr); } statProcPtr = statProcList; while ((retVal == -1) && (statProcPtr != NULL)) { retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer); statProcPtr = statProcPtr->nextPtr; } if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } } Tcl_MutexUnlock(&obsoleteFsHookMutex); if (retVal != -1) { /* * Note that EOVERFLOW is not a problem here, and these assignments * should all be widening (if not identity.) */ buf->st_mode = oldStyleStatBuffer.st_mode; buf->st_ino = oldStyleStatBuffer.st_ino; buf->st_dev = oldStyleStatBuffer.st_dev; buf->st_rdev = oldStyleStatBuffer.st_rdev; buf->st_nlink = oldStyleStatBuffer.st_nlink; buf->st_uid = oldStyleStatBuffer.st_uid; buf->st_gid = oldStyleStatBuffer.st_gid; buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size); buf->st_atime = oldStyleStatBuffer.st_atime; buf->st_mtime = oldStyleStatBuffer.st_mtime; buf->st_ctime = oldStyleStatBuffer.st_ctime; #ifdef HAVE_ST_BLOCKS buf->st_blksize = oldStyleStatBuffer.st_blksize; buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks); #endif return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSStatProc *proc = fsPtr->statProc; if (proc != NULL) { return (*proc)(pathPtr, buf); } } Tcl_SetErrno(ENOENT); return -1; } /* *---------------------------------------------------------------------- * * Tcl_FSLstat -- * * This procedure replaces the library version of lstat. The appropriate * function for the filesystem to which pathPtr belongs will be called. * If no 'lstat' function is listed, but a 'stat' function is, then Tcl * will fall back on the stat function. * * Results: * See lstat documentation. * * Side effects: * See lstat documentation. * *---------------------------------------------------------------------- */ int Tcl_FSLstat(pathPtr, buf) Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ |
︙ | ︙ | |||
1936 1937 1938 1939 1940 1941 1942 | } /* *---------------------------------------------------------------------- * * Tcl_FSAccess -- * | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_FSAccess -- * * This procedure replaces the library version of access. The * appropriate function for the filesystem to which pathPtr belongs will * be called. * * Results: * See access documentation. * * Side effects: * See access documentation. * *---------------------------------------------------------------------- */ int Tcl_FSAccess(pathPtr, mode) Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ int mode; /* Permission setting. */ { Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS int retVal = -1; /* * Call each of the "access" function in succession. A non-return value * of -1 indicates the particular function has succeeded. */ Tcl_MutexLock(&obsoleteFsHookMutex); if (accessProcList != NULL) { AccessProc *accessProcPtr; char *path; |
︙ | ︙ | |||
1984 1985 1986 1987 1988 1989 1990 | retVal = (*accessProcPtr->proc)(path, mode); accessProcPtr = accessProcPtr->nextPtr; } if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } } | | > | | | | | | | | | | | | < | | < | | | | | | | > | | | > | | > | | | | > > > > > > | > > | < | | | < | | | | | | | | | | | | | | | < | | | | | | | < | | | | < | | | | | | < | | | | | | | < | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | < < | | 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 | retVal = (*accessProcPtr->proc)(path, mode); accessProcPtr = accessProcPtr->nextPtr; } if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } } Tcl_MutexUnlock(&obsoleteFsHookMutex); if (retVal != -1) { return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSAccessProc *proc = fsPtr->accessProc; if (proc != NULL) { return (*proc)(pathPtr, mode); } } Tcl_SetErrno(ENOENT); return -1; } /* *---------------------------------------------------------------------- * * Tcl_FSOpenFileChannel -- * * The appropriate function for the filesystem to which pathPtr belongs * will be called. * * Results: * The new channel or NULL, if the named file could not be opened. * * Side effects: * May open the channel and may cause creation of a file on the file * system. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) Tcl_Interp *interp; /* Interpreter for error reporting; can be * NULL. */ Tcl_Obj *pathPtr; /* Name of file to open. */ 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_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS Tcl_Channel retVal = NULL; /* * Call each of the "Tcl_OpenFileChannel" functions in succession. A * non-NULL return value indicates the particular function has succeeded. */ Tcl_MutexLock(&obsoleteFsHookMutex); if (openFileChannelProcList != NULL) { OpenFileChannelProc *openFileChannelProcPtr; char *path; Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (transPtr == NULL) { path = NULL; } else { path = Tcl_GetString(transPtr); } openFileChannelProcPtr = openFileChannelProcList; while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { retVal = (*openFileChannelProcPtr->proc)(interp, path, modeString, permissions); openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; } if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } } Tcl_MutexUnlock(&obsoleteFsHookMutex); if (retVal != NULL) { return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ /* * We need this just to ensure we return the correct error messages under * some circumstances. */ if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { return NULL; } fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc; if (proc != NULL) { int mode, seekFlag, binary; mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); 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; } } if (binary) { Tcl_SetChannelOption(interp, retVal, "-translation", "binary"); } } 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; } /* *---------------------------------------------------------------------- * * Tcl_FSUtime -- * * This procedure replaces the library version of utime. The appropriate * function for the filesystem to which pathPtr belongs will be called. * * Results: * See utime documentation. * * Side effects: * See utime documentation. * *---------------------------------------------------------------------- */ int Tcl_FSUtime(pathPtr, tval) Tcl_Obj *pathPtr; /* File to change access/modification times */ struct utimbuf *tval; /* Structure containing access/modification * times to use. Should not be modified. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSUtimeProc *proc = fsPtr->utimeProc; if (proc != NULL) { return (*proc)(pathPtr, tval); } } return -1; } /* *---------------------------------------------------------------------- * * NativeFileAttrStrings -- * * This procedure implements the platform dependent 'file attributes' * subcommand, for the native filesystem, for listing the set of possible * attribute strings. This function is part of Tcl's native filesystem * support, and is placed here because it is shared by Unix and Windows * code. * * Results: * An array of strings * * Side effects: * None. * *---------------------------------------------------------------------- */ static CONST char** NativeFileAttrStrings(pathPtr, objPtrRef) Tcl_Obj *pathPtr; Tcl_Obj** objPtrRef; { return tclpFileAttrStrings; } /* *---------------------------------------------------------------------- * * NativeFileAttrsGet -- * * This procedure implements the platform dependent 'file attributes' * subcommand, for the native filesystem, for 'get' operations. This * function is part of Tcl's native filesystem support, and is placed * here because it is shared by Unix and Windows code. * * Results: * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK * was returned) is likely to have a refCount of zero. Either way we * must either store it somewhere (e.g. the Tcl result), or Incr/Decr its * refCount to ensure it is properly freed. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) Tcl_Interp *interp; /* The interpreter for error reporting. */ int index; /* index of the attribute command. */ Tcl_Obj *pathPtr; /* path of file we are operating on. */ Tcl_Obj **objPtrRef; /* for output. */ { return (*tclpFileAttrProcs[index].getProc)(interp, index, pathPtr, objPtrRef); } /* *---------------------------------------------------------------------- * * NativeFileAttrsSet -- * * This procedure implements the platform dependent 'file attributes' * subcommand, for the native filesystem, for 'set' operations. This * function is part of Tcl's native filesystem support, and is placed * here because it is shared by Unix and Windows code. * * Results: * Standard Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int NativeFileAttrsSet(interp, index, pathPtr, objPtr) Tcl_Interp *interp; /* The interpreter for error reporting. */ int index; /* index of the attribute command. */ Tcl_Obj *pathPtr; /* path of file we are operating on. */ Tcl_Obj *objPtr; /* set to this value. */ { return (*tclpFileAttrProcs[index].setProc)(interp, index, pathPtr, objPtr); } /* *---------------------------------------------------------------------- * * Tcl_FSFileAttrStrings -- * * This procedure implements part of the hookable 'file attributes' * subcommand. The appropriate function for the filesystem to which * pathPtr belongs will be called. * * Results: * The called procedure may either return an array of strings, or may * instead return NULL and place a Tcl list into the given objPtrRef. * Tcl will take that list and first increment its refCount before using * it. On completion of that use, Tcl will decrement its refCount. Hence * if the list should be disposed of by Tcl when done, it should have a * refCount of zero, and if the list should not be disposed of, the * filesystem should ensure it retains a refCount on the object. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char ** Tcl_FSFileAttrStrings(pathPtr, objPtrRef) Tcl_Obj *pathPtr; Tcl_Obj **objPtrRef; { 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; } /* *---------------------------------------------------------------------- * * TclFSFileAttrIndex -- * * Helper function for converting an attribute name to an index into the * attribute table. * * Results: * Tcl result code, index written to *indexPtr on result==TCL_OK * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclFSFileAttrIndex(pathPtr, attributeName, indexPtr) Tcl_Obj *pathPtr; /* File whose attributes are to be * indexed into. */ CONST char *attributeName; /* The attribute being looked for. */ int *indexPtr; /* Where to write the found index. */ { Tcl_Obj *listObj = NULL; CONST char **attrTable; /* * Get the attribute table for the file. */ attrTable = Tcl_FSFileAttrStrings(pathPtr, &listObj); if (listObj != NULL) { Tcl_IncrRefCount(listObj); } if (attrTable != NULL) { /* * It's a constant attribute table, so use T_GIFO. */ Tcl_Obj *tmpObj = Tcl_NewStringObj(attributeName, -1); int result; result = Tcl_GetIndexFromObj(NULL, tmpObj, attrTable, NULL, TCL_EXACT, indexPtr); TclDecrRefCount(tmpObj); if (listObj != NULL) { TclDecrRefCount(listObj); } return result; } else if (listObj != NULL) { /* * It's a non-constant attribute list, so do a literal search. */ int i, objc; Tcl_Obj **objv; if (Tcl_ListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) { TclDecrRefCount(listObj); return TCL_ERROR; } for (i=0 ; i<objc ; i++) { if (!strcmp(attributeName, TclGetString(objv[i]))) { TclDecrRefCount(listObj); *indexPtr = i; return TCL_OK; } } TclDecrRefCount(listObj); return TCL_ERROR; } else { return TCL_ERROR; } } /* *---------------------------------------------------------------------- * * Tcl_FSFileAttrsGet -- * * This procedure implements read access for the hookable 'file * attributes' subcommand. The appropriate function for the filesystem * to which pathPtr belongs will be called. * * Results: * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK * was returned) is likely to have a refCount of zero. Either way we * must either store it somewhere (e.g. the Tcl result), or Incr/Decr its * refCount to ensure it is properly freed. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef) Tcl_Interp *interp; /* The interpreter for error reporting. */ |
︙ | ︙ | |||
2332 2333 2334 2335 2336 2337 2338 | /* *---------------------------------------------------------------------- * * Tcl_FSFileAttrsSet -- * * This procedure implements write access for the hookable 'file | | | | | | 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 | /* *---------------------------------------------------------------------- * * Tcl_FSFileAttrsSet -- * * This procedure implements write access for the hookable 'file * attributes' subcommand. The appropriate function for the filesystem * to which pathPtr belongs will be called. * * Results: * Standard Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) Tcl_Interp *interp; /* The interpreter for error reporting. */ |
︙ | ︙ | |||
2368 2369 2370 2371 2372 2373 2374 | /* *---------------------------------------------------------------------- * * Tcl_FSGetCwd -- * * This function replaces the library version of getcwd(). | | | | | | | | | | | | | | | | < | | | < | | | | | | | | < | | > | | | | > | | | | | > | | < > | 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 | /* *---------------------------------------------------------------------- * * Tcl_FSGetCwd -- * * This function replaces the library version of getcwd(). * * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains its * own record (in a Tcl_Obj) of the cwd, and an attempt is made to * synchronise this with the cwd's containing filesystem, if that * filesystem provides a cwdProc (e.g. the native filesystem). * * Note that if Tcl's cwd is not in the native filesystem, then of course * Tcl's cwd and the native cwd are different: extensions should * therefore ensure they only access the cwd through this function to * avoid confusion. * * If a global cwdPathPtr already exists, it is cached in the thread's * private data structures and reference to the cached copy is returned, * subject to a synchronisation attempt in that cwdPathPtr's fs. * * Otherwise, the chain of functions that have been "inserted" into the * filesystem will be called in succession until either a value other * than NULL is returned, or the entire list is visited. * * Results: * The result is a pointer to a Tcl_Obj specifying the current directory, * or NULL if the current directory could not be determined. If NULL is * returned, an error message is left in the interp's result. * * The result already has its refCount incremented for the caller. When * it is no longer needed, that refCount should be decremented. * * Side effects: * Various objects may be freed and allocated. * *---------------------------------------------------------------------- */ Tcl_Obj* Tcl_FSGetCwd(interp) Tcl_Interp *interp; { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (TclFSCwdPointerEquals(NULL)) { FilesystemRecord *fsRecPtr; Tcl_Obj *retVal = NULL; /* * We've never been called before, try to find a cwd. Call each of * the "Tcl_GetCwd" function in succession. A non-NULL return value * indicates the particular function has succeeded. */ fsRecPtr = FsGetFirstFilesystem(); while ((retVal == NULL) && (fsRecPtr != NULL)) { Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc; if (proc != NULL) { if (fsRecPtr->fsPtr->version != TCL_FILESYSTEM_VERSION_1) { ClientData retCd; TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc; retCd = (*proc2)(NULL); if (retCd != NULL) { Tcl_Obj *norm; /* Looks like a new current directory */ retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)( retCd); Tcl_IncrRefCount(retVal); norm = TclFSNormalizeAbsolutePath(interp,retVal,NULL); if (norm != NULL) { /* * We found a cwd, which is now in our global * storage. We must make a copy. Norm already has * a refCount of 1. * * Threading issue: note that multiple threads at * system startup could in principle call this * procedure simultaneously. They will therefore * each set the cwdPathPtr independently. That * behaviour is a bit peculiar, but should be * fine. Once we have a cwd, we'll always be in * the 'else' branch below which is simpler. */ FsUpdateCwd(norm, retCd); Tcl_DecrRefCount(norm); } else { (*fsRecPtr->fsPtr->freeInternalRepProc)(retCd); } Tcl_DecrRefCount(retVal); retVal = NULL; |
︙ | ︙ | |||
2469 2470 2471 2472 2473 2474 2475 | } } else { retVal = (*proc)(interp); } } fsRecPtr = fsRecPtr->nextPtr; } | > | | | | | | | > | | | | | | | < > | | | < | | > > | | | | | | | < > | | | > | > > | | > | | | | > | | < | | | | > > | | | | | > | | | | | | | | | < | < > | | | | | | > > | > > > | | | | | > | < | > | > > | | | | | < | | | | | < | | | | | | | | < | | | | < | | | | < | | > > | > | | | | < | | | < | | | | < | < | < > > | > > | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | < | > | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | > > > | | > | | | > > | < | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > | | | | | < | > > > | | | < | | < | | < | | > > > | > | | | | < > | | < < | > | | | | > > | | < | | | < > > > | | < | > | | | | | > | | | | | > | | | | | | < > | > > > | > > | | | | > | | | | | | | | | | | | | | | | < | | | | | | < > | | | > | | | | | | < > | | | | | > > | | | > | | | | | | | | | | | | < | | | | | > | | | | | | | < | | | | | < | | | | | | | | | < | > | | | | | > | | | | | | | | < | | | | | | | | | | | | < | | | | | | < | | | | | | | | | | | | | | | > | > > | | | < | | > | | | | > | > > | 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 | } } else { retVal = (*proc)(interp); } } fsRecPtr = fsRecPtr->nextPtr; } /* * Now the 'cwd' may NOT be normalized, at least on some platforms. * For the sake of efficiency, we want a completely normalized cwd at * all times. * * Finally, if retVal is NULL, we do not have a cwd, which could be * problematic. */ if (retVal != NULL) { Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); if (norm != NULL) { /* * We found a cwd, which is now in our global storage. We * must make a copy. Norm already has a refCount of 1. * * Threading issue: note that multiple threads at system * startup could in principle call this procedure * simultaneously. They will therefore each set the * cwdPathPtr independently. That behaviour is a bit * peculiar, but should be fine. Once we have a cwd, we'll * always be in the 'else' branch below which is simpler. */ ClientData cd = (ClientData) Tcl_FSGetNativePath(norm); FsUpdateCwd(norm, TclNativeDupInternalRep(cd)); Tcl_DecrRefCount(norm); } Tcl_DecrRefCount(retVal); } } else { /* * We already have a cwd cached, but we want to give the filesystem it * is in a chance to check whether that cwd has changed, or is perhaps * no longer accessible. This allows an error to be thrown if, say, * the permissions on that directory have changed. */ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); /* * If the filesystem couldn't be found, or if no cwd function exists * for this filesystem, then we simply assume the cached cwd is ok. * If we do call a cwd, we must watch for errors (if the cwd returns * NULL). This ensures that, say, on Unix if the permissions of the * cwd change, 'pwd' does actually throw the correct error in Tcl. * (This is tested for in the test suite on unix). */ if (fsPtr != NULL) { Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc; ClientData retCd = NULL; if (proc != NULL) { Tcl_Obj *retVal; if (fsPtr->version != TCL_FILESYSTEM_VERSION_1) { TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc; retCd = (*proc2)(tsdPtr->cwdClientData); if (retCd == NULL && interp != NULL) { Tcl_AppendResult(interp, "error getting working directory name: ", Tcl_PosixError(interp), (char *) NULL); } if (retCd == tsdPtr->cwdClientData) { goto cdDidNotChange; } /* * Looks like a new current directory. */ retVal = (*fsPtr->internalToNormalizedProc)(retCd); Tcl_IncrRefCount(retVal); } else { retVal = (*proc)(interp); } if (retVal != NULL) { Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); /* * Check whether cwd has changed from the value previously * stored in cwdPathPtr. Really 'norm' shouldn't be null, * but we are careful. */ if (norm == NULL) { /* Do nothing */ if (retCd != NULL) { (*fsPtr->freeInternalRepProc)(retCd); } } else if (norm == tsdPtr->cwdPathPtr) { goto cdEqual; } else { /* * Note that both 'norm' and 'tsdPtr->cwdPathPtr' are * normalized paths. Therefore we can be more * efficient than calling 'Tcl_FSEqualPaths', and in * addition avoid a nasty infinite loop bug when * trying to normalize tsdPtr->cwdPathPtr. */ int len1, len2; char *str1, *str2; str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); str2 = Tcl_GetStringFromObj(norm, &len2); if ((len1 == len2) && (strcmp(str1, str2) == 0)) { /* * If the paths were equal, we can be more * efficient and retain the old path object which * will probably already be shared. In this case * we can simply free the normalized path we just * calculated. */ cdEqual: Tcl_DecrRefCount(norm); if (retCd != NULL) { (*fsPtr->freeInternalRepProc)(retCd); } } else { FsUpdateCwd(norm, retCd); Tcl_DecrRefCount(norm); } } Tcl_DecrRefCount(retVal); } else { /* The 'cwd' function returned an error; reset the cwd */ FsUpdateCwd(NULL, NULL); } } } } cdDidNotChange: if (tsdPtr->cwdPathPtr != NULL) { Tcl_IncrRefCount(tsdPtr->cwdPathPtr); } return tsdPtr->cwdPathPtr; } /* *---------------------------------------------------------------------- * * Tcl_FSChdir -- * * This function replaces the library version of chdir(). * * The path is normalized and then passed to the filesystem which claims * it. * * Results: * See chdir() documentation. If successful, we keep a record of the * successful path in cwdPathPtr for subsequent calls to getcwd. * * Side effects: * See chdir() documentation. The global cwdPathPtr may change value. * *---------------------------------------------------------------------- */ int Tcl_FSChdir(pathPtr) Tcl_Obj *pathPtr; { Tcl_Filesystem *fsPtr; int retVal = -1; if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { Tcl_SetErrno(ENOENT); return retVal; } fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSChdirProc *proc = fsPtr->chdirProc; if (proc != NULL) { /* * If this fails, an appropriate errno will have been stored using * 'Tcl_SetErrno()'. */ retVal = (*proc)(pathPtr); } else { /* * Fallback on stat-based implementation. */ Tcl_StatBuf buf; /* * If the file can be stat'ed and is a directory and is readable, * then we can chdir. If any of these actions fail, then * 'Tcl_SetErrno()' should automatically have been called to set * an appropriate error code */ if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode)) && (Tcl_FSAccess(pathPtr, R_OK) == 0)) { /* * We allow the chdir. */ retVal = 0; } } } else { Tcl_SetErrno(ENOENT); } /* * The cwd changed, or an error was thrown. If an error was thrown, we * can just continue (and that will report the error to the user). If * there was no error we must assume that the cwd was actually changed to * the normalized value we calculated above, and we must therefore cache * that information. */ /* * If the filesystem in question has a getCwdProc, then the correct logic * which performs the part below is already part of the Tcl_FSGetCwd() * call, so no need to replicate it again. This will have a side effect * though. The private authoritative representation of the current * working directory stored in cwdPathPtr in static memory will be * out-of-sync with the real OS-maintained value. The first call to * Tcl_FSGetCwd will however recalculate the private copy to match the * OS-value so everything will work right. * * However, if there is no getCwdProc, then we _must_ update our private * storage of the cwd, since this is the only opportunity to do that! * * Note: We currently call this block of code irrespective of whether * there was a getCwdProc or not, but the code should all in principle * work if we only call this block if fsPtr->getCwdProc == NULL. */ if (retVal == 0) { /* * Note that this normalized path may be different to what we found * above (or at least a different object), if the filesystem epoch * changed recently. This can actually happen with scripted documents * very easily. Therefore we ask for the normalized path again (the * correct value will have been cached as a result of the * Tcl_FSGetFileSystemForPath call above anyway). */ Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normDirName == NULL) { /* Not really true, but what else to do? */ Tcl_SetErrno(ENOENT); return -1; } if (fsPtr == &tclNativeFilesystem) { /* * For the native filesystem, we keep a cache of the native * representation of the cwd. But, we want to do that for the * exact format that is returned by 'getcwd' (so that we can later * compare the two representations for equality), which might not * be exactly the same char-string as the native representation of * the fully normalized path (e.g. on Windows there's a * forward-slash vs backslash difference). Hence we ask for this * again here. On Unix it might actually be true that we always * have the correct form in the native rep in which case we could * simply use: * cd = Tcl_FSGetNativePath(pathPtr); * instead. This should be examined by someone on Unix. */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); ClientData cd; /* * Assumption we are using a filesystem version 2. */ TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc; cd = (*proc2)(tsdPtr->cwdClientData); FsUpdateCwd(normDirName, TclNativeDupInternalRep(cd)); } else { FsUpdateCwd(normDirName, NULL); } } return retVal; } /* *---------------------------------------------------------------------- * * Tcl_FSLoadFile -- * * Dynamically loads a binary code file into memory and returns the * addresses of two procedures within that file, if they are defined. * The appropriate function for the filesystem to which pathPtr belongs * will be called. * * Note that the native filesystem doesn't actually assume 'pathPtr' is a * path. Rather it assumes pathPtr is either a path or just the name * (tail) of a file which can be found somewhere in the environment's * loadable path. This behaviour is not very compatible with virtual * filesystems (and has other problems documented in the load man-page), * so it is advised that full 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. */ { CONST char *symbols[2]; Tcl_PackageInitProc **procPtrs[2]; ClientData clientData; int res; /* Initialize the arrays */ symbols[0] = sym1; symbols[1] = sym2; procPtrs[0] = proc1Ptr; procPtrs[1] = proc2Ptr; /* Perform the load */ res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, handlePtr, &clientData, unloadProcPtr); /* * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a shared * library, we don't keep the loadHandle (for TclpFindSymbol) and the * clientData (for the unloadProc) separately. In fact we effectively * throw away the loadHandle and only use the clientData. It just so * happens, for the native filesystem only, that these two are identical. * * This also means that the signatures Tcl_FSUnloadFileProc and * Tcl_FSLoadFileProc are both misleading. */ *handlePtr = (Tcl_LoadHandle) clientData; return res; } /* *---------------------------------------------------------------------- * * TclLoadFile -- * * Dynamically loads a binary code file into memory and returns the * addresses of a number of given procedures within that file, if they * are defined. The appropriate function for the filesystem to which * pathPtr belongs will be called. * * Note that the native filesystem doesn't actually assume 'pathPtr' is a * path. Rather it assumes pathPtr is either a path or just the name * (tail) of a file which can be found somewhere in the environment's * loadable path. This behaviour is not very compatible with virtual * filesystems (and has other problems documented in the load man-page), * so it is advised that full paths are always used. * * This function is currently private to Tcl. It may be exported in the * future and its interface fixed (but we should clean up the * loadHandle/clientData confusion at that time -- see the above comments * in Tcl_FSLoadFile for details). For a public function, see * Tcl_FSLoadFile. * * 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 TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, handlePtr, clientDataPtr, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code. */ int symc; /* Number of symbols/procPtrs in the next two * arrays. */ CONST char *symbols[]; /* Names of procedures to look up in the * file's symbol table. */ Tcl_PackageInitProc **procPtrs[]; /* Where to return the addresses corresponding * to symbols[]. */ Tcl_LoadHandle *handlePtr; /* Filled with token for shared library * information which can be used in * TclpFindSymbol. */ 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_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc; Tcl_Filesystem *copyFsPtr; Tcl_Obj *copyToPtr; if (proc != NULL) { int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr); if (retVal == TCL_OK) { int i; if (*handlePtr == NULL) { return TCL_ERROR; } for (i=0 ; i<symc ; i++) { if (symbols[i] != NULL) { *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, symbols[i]); } } /* * Copy this across, since both are equal for the native fs. */ *clientDataPtr = (ClientData)*handlePtr; Tcl_ResetResult(interp); return TCL_OK; } if (Tcl_GetErrno() != EXDEV) { return retVal; } } /* * The filesystem doesn't support 'load', so we fall back on the * following technique: * * First check if it is readable -- and exists! */ if (Tcl_FSAccess(pathPtr, R_OK) != 0) { Tcl_AppendResult(interp, "couldn't load library \"", Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } #ifdef TCL_LOAD_FROM_MEMORY /* * The platform supports loading code from memory, so ask for a buffer * of the appropriate size, read the file into it and load the code * from the buffer: */ do { int ret, size; void *buffer; Tcl_StatBuf statBuf; Tcl_Channel data; ret = Tcl_FSStat(pathPtr, &statBuf); if (ret < 0) { break; } size = (int) statBuf.st_size; /* * Tcl_Read takes an int: check that file size isn't wide. */ if (size != (Tcl_WideInt) statBuf.st_size) { break; } data = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0666); if (!data) { break; } buffer = TclpLoadMemoryGetBuffer(interp, size); if (!buffer) { Tcl_Close(interp, data); break; } Tcl_SetChannelOption(interp, data, "-translation", "binary"); ret = Tcl_Read(data, buffer, size); Tcl_Close(interp, data); ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, unloadProcPtr); if (ret == TCL_OK) { int i; if (*handlePtr == NULL) { break; } for (i = 0;i < symc;i++) { if (symbols[i] != NULL) { *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, symbols[i]); } } *clientDataPtr = (ClientData) *handlePtr; return TCL_OK; } } while (0); Tcl_ResetResult(interp); #endif /* * Get a temporary filename to use, first to copy the file into, and * then to load. */ copyToPtr = TclpTempFileName(); if (copyToPtr == NULL) { Tcl_AppendResult(interp, "couldn't create temporary file: ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } Tcl_IncrRefCount(copyToPtr); copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr); if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) { /* * We already know we can't use Tcl_FSLoadFile from this * filesystem, and we must avoid a possible infinite loop. Try to * delete the file we probably created, and then exit. */ Tcl_FSDeleteFile(copyToPtr); Tcl_DecrRefCount(copyToPtr); Tcl_AppendResult(interp, "couldn't load from current filesystem", (char *) NULL); return TCL_ERROR; } if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) == TCL_OK) { Tcl_LoadHandle newLoadHandle = NULL; ClientData newClientData = NULL; Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; FsDivertLoad *tvdlPtr; int retVal; #if !defined(__WIN32__) /* * Do we need to set appropriate permissions on the file? This * may be required on some systems. On Unix we could loop over * the file attributes, and set any that are called "-permissions" * to 0700. However, we just do this directly, like this: */ int index; Tcl_Obj* perm = Tcl_NewStringObj("0700",-1); Tcl_IncrRefCount(perm); if (TclFSFileAttrIndex(copyToPtr, "-permissions", &index) == TCL_OK) { Tcl_FSFileAttrsSet(NULL, index, copyToPtr, perm); } Tcl_DecrRefCount(perm); #endif /* * We need to reset the result now, because the cross- filesystem * copy may have stored the number of bytes in the result. */ Tcl_ResetResult(interp); retVal = TclLoadFile(interp, copyToPtr, symc, symbols, procPtrs, &newLoadHandle, &newClientData, &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); /* * We tell our caller about the real shared library which was * loaded. Note that this does mean that the package list * maintained by 'load' will store the original (vfs) path * alongside the temporary load handle and unload proc ptr. */ (*handlePtr) = newLoadHandle; (*clientDataPtr) = newClientData; (*unloadProcPtr) = newUnloadProcPtr; Tcl_ResetResult(interp); 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; if (copyFsPtr != &tclNativeFilesystem) { /* copyToPtr is already incremented for this reference */ tvdlPtr->divertedFile = copyToPtr; /* * This is the filesystem we loaded it into. 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; tvdlPtr->divertedFileNativeRep = NULL; } else { /* We need the native rep */ tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep( Tcl_FSGetInternalRep(copyToPtr, copyFsPtr)); /* * We don't need or want references to the copied Tcl_Obj or * the filesystem if it is the native one. */ tvdlPtr->divertedFile = NULL; tvdlPtr->divertedFilesystem = NULL; Tcl_DecrRefCount(copyToPtr); } copyToPtr = NULL; (*handlePtr) = newLoadHandle; (*clientDataPtr) = (ClientData) tvdlPtr; (*unloadProcPtr) = &FSUnloadTempFile; Tcl_ResetResult(interp); return retVal; } else { /* * Cross-platform copy failed. */ Tcl_FSDeleteFile(copyToPtr); Tcl_DecrRefCount(copyToPtr); return TCL_ERROR; } } Tcl_SetErrno(ENOENT); return TCL_ERROR; } /* * 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 an * intermediate temporary file. This function ensures the library is * correctly unloaded and the temporary file is correctly deleted. * * Results: * None. * * 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); } if (tvdlPtr->divertedFilesystem == NULL) { /* * It was the native filesystem, and we have a special function * available just for this purpose, which we know works even at this * late stage. */ TclpDeleteFile(tvdlPtr->divertedFileNativeRep); NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep); } else { /* * Remove the temporary file we created. Note, we may crash here * because encodings have been taken down already. */ if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile) != TCL_OK) { /* * The above may have failed because the filesystem, or something * it depends upon (e.g. encodings) have been taken down because * Tcl is exiting. * * We may need to work out how to delete this file more robustly * (or give the filesystem the information it needs to delete the * file more robustly). * * In particular, one problem might be that the filesystem cannot * extract the information it needs from the above path object * because Tcl's entire filesystem apparatus (the code in this * file) has been finalized, and it refuses to pass the internal * representation to the filesystem. */ } /* * And free up the allocations. This will also of course remove a * refCount from the Tcl_Filesystem to which this file belongs, which * could then free up the filesystem if we are exiting. */ Tcl_DecrRefCount(tvdlPtr->divertedFile); } ckfree((char*)tvdlPtr); } /* *--------------------------------------------------------------------------- * * Tcl_FSLink -- * * This function replaces the library version of readlink() and can also * be used to make links. The appropriate function for the filesystem to * which pathPtr belongs will be called. * * 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; } /* *--------------------------------------------------------------------------- * * Tcl_FSListVolumes -- * * Lists the currently mounted volumes. The chain of functions that have * been "inserted" into the filesystem will be called in succession; each * may return a list of volumes, all of which are added to the result * until all mounted file systems are listed. * * Notice that we assume the lists returned by each filesystem (if non * NULL) have been given a refCount for us already. However, we are NOT * allowed to hang on to the list itself (it belongs to the filesystem we * called). Therefore we quite naturally add its contents to the result * we are building, and then decrement the refCount. * * Results: * The list of volumes, in an object which has refCount 0. * * Side effects: * None * *--------------------------------------------------------------------------- */ Tcl_Obj* Tcl_FSListVolumes(void) { FilesystemRecord *fsRecPtr; Tcl_Obj *resultPtr = Tcl_NewObj(); /* * Call each of the "listVolumes" function in succession. A non-NULL * return value indicates the particular function has succeeded. We call * all the functions registered, since we want a list of all drives from * all filesystems. */ fsRecPtr = FsGetFirstFilesystem(); while (fsRecPtr != NULL) { Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; if (proc != NULL) { Tcl_Obj *thisFsVolumes = (*proc)(); if (thisFsVolumes != NULL) { Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes); Tcl_DecrRefCount(thisFsVolumes); } } fsRecPtr = fsRecPtr->nextPtr; } return resultPtr; } /* *--------------------------------------------------------------------------- * * FsListMounts -- * * List all mounts within the given directory, which match the given * pattern. * * Results: * The list of mounts, in a list object which has refCount 0, or NULL if * we didn't even find any filesystems to try to list mounts. * * Side effects: * None * *--------------------------------------------------------------------------- */ static Tcl_Obj* FsListMounts(pathPtr, pattern) Tcl_Obj *pathPtr; /* Contains path to directory to search. */ CONST char *pattern; /* Pattern to match against. */ { FilesystemRecord *fsRecPtr; Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL }; Tcl_Obj *resultPtr = NULL; /* * Call each of the "matchInDirectory" functions in succession, with the * specific type information 'mountsOnly'. A non-NULL return value * indicates the particular function has succeeded. We call all the * functions registered, since we want a list from each filesystems. */ fsRecPtr = FsGetFirstFilesystem(); while (fsRecPtr != NULL) { if (fsRecPtr != &nativeFilesystemRecord) { Tcl_FSMatchInDirectoryProc *proc = fsRecPtr->fsPtr->matchInDirectoryProc; if (proc != NULL) { if (resultPtr == NULL) { resultPtr = Tcl_NewObj(); } (*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly); } } fsRecPtr = fsRecPtr->nextPtr; } return resultPtr; } /* *--------------------------------------------------------------------------- * * Tcl_FSSplitPath -- * * This function takes the given Tcl_Obj, which should be a valid path, * and returns a Tcl List object containing each segment of that path as * an element. * * Results: * Returns list object with refCount of zero. If the passed in lenPtr is * non-NULL, we use it to return the number of elements in the returned * list. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_Obj* Tcl_FSSplitPath(pathPtr, lenPtr) Tcl_Obj *pathPtr; /* Path to split. */ int *lenPtr; /* int to store number of path elements. */ { Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Filesystem *fsPtr; char separator = '/'; int driveNameLength; char *p; /* * Perform platform specific splitting. */ if (TclFSGetPathType(pathPtr, &fsPtr, &driveNameLength) == TCL_PATH_ABSOLUTE) { if (fsPtr == &tclNativeFilesystem) { return TclpNativeSplitPath(pathPtr, lenPtr); } } else { return TclpNativeSplitPath(pathPtr, lenPtr); } /* * We assume separators are single characters. */ if (fsPtr->filesystemSeparatorProc != NULL) { Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr); if (sep != NULL) { Tcl_IncrRefCount(sep); separator = Tcl_GetString(sep)[0]; Tcl_DecrRefCount(sep); } } /* * Place the drive name as first element of the result list. The drive * name may contain strange characters, like colons and multiple forward * slashes (for example 'ftp://' is a valid vfs drive name) */ result = Tcl_NewObj(); p = Tcl_GetString(pathPtr); Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(p, driveNameLength)); p += driveNameLength; /* * Add the remaining path elements to the list. */ for (;;) { char *elementStart = p; int length; while ((*p != '\0') && (*p != separator)) { p++; } length = p - elementStart; |
︙ | ︙ | |||
3457 3458 3459 3460 3461 3462 3463 | } Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*p++ == '\0') { break; } } | | | | | | | | | | | | | < | | | | | < | | | | | | | | | | | | | < | | | | | | | | | | | < | | | | | < | | | | | < > | | | | | | < | | | | | | | < | | > > | | | | | | | | | | > | 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 | } Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*p++ == '\0') { break; } } /* * Compute the number of elements in the result. */ if (lenPtr != NULL) { Tcl_ListObjLength(NULL, result, lenPtr); } return result; } /* Simple helper function */ Tcl_Obj* TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) Tcl_Filesystem *fromFilesystem; ClientData clientData; FilesystemRecord **fsRecPtrPtr; { FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); while (fsRecPtr != NULL) { if (fsRecPtr->fsPtr == fromFilesystem) { *fsRecPtrPtr = fsRecPtr; break; } fsRecPtr = fsRecPtr->nextPtr; } if ((fsRecPtr != NULL) && (fromFilesystem->internalToNormalizedProc != NULL)) { return (*fromFilesystem->internalToNormalizedProc)(clientData); } else { return NULL; } } /* *---------------------------------------------------------------------- * * TclGetPathType -- * * Helper function used by FSGetPathType. * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and * only if it is non-NULL and the function's return value is * TCL_PATH_ABSOLUTE. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_PathType TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) Tcl_Obj *pathPtr; /* Path to determine type for */ Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is not * NULL, then set to the filesystem * which claims this path. */ int *driveNameLengthPtr; /* If the path is absolute, and this * is non-NULL, then set to the length * of the driveName. */ Tcl_Obj **driveNameRef; /* If the path is absolute, and this * is non-NULL, then set to the name * of the drive, network-volume which * contains the path, already with a * refCount for the caller. */ { int pathLen; char *path; Tcl_PathType type; path = Tcl_GetStringFromObj(pathPtr, &pathLen); type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, driveNameRef); if (type != TCL_PATH_ABSOLUTE) { type = TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef); if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) { *filesystemPtrPtr = &tclNativeFilesystem; } } return type; } /* *---------------------------------------------------------------------- * * TclFSNonnativePathType -- * * Helper function used by TclGetPathType. Its purpose is to check * whether the given path starts with a string which corresponds to a * file volume in any registered filesystem except the native one. For * speed and historical reasons the native filesystem has special * hard-coded checks dotted here and there in the filesystem code. * * Results: * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem * reference will be set if and only if it is non-NULL and the function's * return value is TCL_PATH_ABSOLUTE. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_PathType TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) CONST char *path; /* Path to determine type for */ int pathLen; /* Length of the path */ Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is not * NULL, then set to the filesystem * which claims this path. */ int *driveNameLengthPtr; /* If the path is absolute, and this * is non-NULL, then set to the length * of the driveName. */ Tcl_Obj **driveNameRef; /* If the path is absolute, and this * is non-NULL, then set to the name * of the drive, network-volume which * contains the path, already with a * refCount for the caller. */ { FilesystemRecord *fsRecPtr; Tcl_PathType type = TCL_PATH_RELATIVE; /* * Call each of the "listVolumes" function in succession, checking whether * the given path is an absolute path on any of the volumes returned (this * is done by checking whether the path's prefix matches). */ fsRecPtr = FsGetFirstFilesystem(); while (fsRecPtr != NULL) { Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; /* * We want to skip the native filesystem in this loop because * otherwise we won't necessarily pass all the Tcl testsuite -- this * is because some of the tests artificially change the current * platform (between win, unix) but the list of volumes we get by * calling (*proc) will reflect the current (real) platform only and * this may cause some tests to fail. In particular, on unix '/' will * match the beginning of certain absolute Windows paths starting '//' * and those tests will go wrong. * * Besides these test-suite issues, there is one other reason 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 didn't * return a valid list. Set numVolumes to -1 so that we * skip the while loop below and just return with the * current value of 'type'. * * It would be better if we could signal an error here * (but Tcl_Panic seems a bit excessive). */ numVolumes = -1; } while (numVolumes > 0) { Tcl_Obj *vol; int len; char *strVol; |
︙ | ︙ | |||
3682 3683 3684 3685 3686 3687 3688 | } /* *--------------------------------------------------------------------------- * * Tcl_FSRenameFile -- * | | | | | | 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 | } /* *--------------------------------------------------------------------------- * * Tcl_FSRenameFile -- * * If the two paths given belong to the same filesystem, we call that * filesystems rename function. Otherwise we simply return the posix * error 'EXDEV', and -1. * * Results: * Standard Tcl error code if a function was called. * * Side effects: * A file may be renamed. * *--------------------------------------------------------------------------- */ |
︙ | ︙ | |||
3724 3725 3726 3727 3728 3729 3730 | } /* *--------------------------------------------------------------------------- * * Tcl_FSCopyFile -- * | | | | | | | | | | | 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 | } /* *--------------------------------------------------------------------------- * * Tcl_FSCopyFile -- * * If the two paths given belong to the same filesystem, we call that * filesystem's copy function. Otherwise we simply return the posix * error 'EXDEV', and -1. * * Note that in the native filesystems, 'copyFileProc' is defined to copy * soft links (i.e. it copies the links themselves, not the things they * point to). * * Results: * Standard Tcl error code if a function was called. * * Side effects: * A file may be copied. * *--------------------------------------------------------------------------- */ int Tcl_FSCopyFile(srcPathPtr, destPathPtr) Tcl_Obj* srcPathPtr; /* Pathname of file to be copied (UTF-8). */ Tcl_Obj *destPathPtr; /* Pathname of file to copy to (UTF-8). */ { int retVal = -1; Tcl_Filesystem *fsPtr, *fsPtr2; fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); |
︙ | ︙ | |||
3768 3769 3770 3771 3772 3773 3774 | } /* *--------------------------------------------------------------------------- * * TclCrossFilesystemCopy -- * | | | | | | | | > | > > | | > | > > > > | | | < > | > | | | > | > | > > | | | | 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 | } /* *--------------------------------------------------------------------------- * * TclCrossFilesystemCopy -- * * Helper for above function, and for Tcl_FSLoadFile, to copy files from * one filesystem to another. This function will overwrite the target * file if it already exists. * * Results: * Standard Tcl error code. * * Side effects: * A file may be created. * *--------------------------------------------------------------------------- */ int TclCrossFilesystemCopy(interp, source, target) Tcl_Interp *interp; /* For error messages */ Tcl_Obj *source; /* Pathname of file to be copied (UTF-8). */ Tcl_Obj *target; /* Pathname of file to copy to (UTF-8). */ { int result = TCL_ERROR; int prot = 0666; Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot); if (out != NULL) { /* * It looks like we can copy it over. */ Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source, "r", prot); if (in == NULL) { /* * This is very strange, we checked this above */ Tcl_Close(interp, out); } else { Tcl_StatBuf sourceStatBuf; struct utimbuf tval; /* * Copy it synchronously. We might wish to add an asynchronous * option to support vfs's which are slow (e.g. network sockets). */ Tcl_SetChannelOption(interp, in, "-translation", "binary"); Tcl_SetChannelOption(interp, out, "-translation", "binary"); if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) { result = TCL_OK; } /* * If the copy failed, assume that copy channel left a good error * message. */ Tcl_Close(interp, in); Tcl_Close(interp, out); /* * Set modification date of copied file. */ if (Tcl_FSLstat(source, &sourceStatBuf) == 0) { tval.actime = sourceStatBuf.st_atime; tval.modtime = sourceStatBuf.st_mtime; Tcl_FSUtime(target, &tval); } } } return result; } /* *--------------------------------------------------------------------------- * * Tcl_FSDeleteFile -- * * The appropriate function for the filesystem to which pathPtr belongs * will be called. * * Results: * Standard Tcl error code. * * Side effects: * A file may be deleted. * *--------------------------------------------------------------------------- */ |
︙ | ︙ | |||
3866 3867 3868 3869 3870 3871 3872 | } /* *--------------------------------------------------------------------------- * * Tcl_FSCreateDirectory -- * | | | | | 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 | } /* *--------------------------------------------------------------------------- * * Tcl_FSCreateDirectory -- * * The appropriate function for the filesystem to which pathPtr belongs * will be called. * * Results: * Standard Tcl error code. * * Side effects: * A directory may be created. * *--------------------------------------------------------------------------- */ |
︙ | ︙ | |||
3898 3899 3900 3901 3902 3903 3904 | } /* *--------------------------------------------------------------------------- * * Tcl_FSCopyDirectory -- * | | | | | | | | | 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 | } /* *--------------------------------------------------------------------------- * * Tcl_FSCopyDirectory -- * * If the two paths given belong to the same filesystem, we call that * filesystems copy-directory function. Otherwise we simply return the * posix error 'EXDEV', and -1. * * Results: * Standard Tcl error code if a function was called. * * Side effects: * A directory may be copied. * *--------------------------------------------------------------------------- */ int Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr) Tcl_Obj* srcPathPtr; /* Pathname of directory to be copied * (UTF-8). */ Tcl_Obj *destPathPtr; /* Pathname of target directory (UTF-8). */ Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a new * object containing name of file causing * error, with refCount 1. */ { int retVal = -1; Tcl_Filesystem *fsPtr, *fsPtr2; fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); if (fsPtr == fsPtr2 && fsPtr != NULL) { |
︙ | ︙ | |||
3942 3943 3944 3945 3946 3947 3948 | } /* *--------------------------------------------------------------------------- * * Tcl_FSRemoveDirectory -- * | | | | | | | | | | < | | | | | > | > | | | | > | | | | | | | | | > | | > | | | | | | | | < | | | | | | | | | | | < | | | | | < | | | < | > > | | | > | | | | | | < | | | | | | | | < | | | | > | | | | | < | > | | | | | | | | | | | < > | | | | > | | | > | | | | | | | | | | | | | < | 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 | } /* *--------------------------------------------------------------------------- * * Tcl_FSRemoveDirectory -- * * The appropriate function for the filesystem to which pathPtr belongs * will be called. * * Results: * Standard Tcl error code. * * Side effects: * A directory may be deleted. * *--------------------------------------------------------------------------- */ int Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_Obj *pathPtr; /* Pathname of directory to be removed * (UTF-8). */ int recursive; /* If non-zero, removes directories that are * nonempty. Otherwise, will only remove * empty directories. */ Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a new * object containing name of file causing * error, with refCount 1. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL && fsPtr->removeDirectoryProc != NULL) { Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc; if (recursive) { /* * We check whether the cwd lies inside this directory and move it * if it does. */ Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); if (cwdPtr != NULL) { char *cwdStr, *normPathStr; int cwdLen, normLen; Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normPath != NULL) { normPathStr = Tcl_GetStringFromObj(normPath, &normLen); cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, (size_t) normLen) == 0)) { /* * The cwd is inside the directory, so we perform a * 'cd [file dirname $path]'. */ Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME); Tcl_FSChdir(dirPtr); Tcl_DecrRefCount(dirPtr); } } Tcl_DecrRefCount(cwdPtr); } } return (*proc)(pathPtr, recursive, errorPtr); } Tcl_SetErrno(ENOENT); return -1; } /* *--------------------------------------------------------------------------- * * Tcl_FSGetFileSystemForPath -- * * This function determines which filesystem to use for a particular path * object, and returns the filesystem which accepts this file. If no * filesystem will accept this object as a valid file path, then NULL is * returned. * * Results: * NULL or a filesystem which will accept this path. * * Side effects: * The object may be converted to a path type. * *--------------------------------------------------------------------------- */ Tcl_Filesystem* Tcl_FSGetFileSystemForPath(pathPtr) Tcl_Obj* pathPtr; { FilesystemRecord *fsRecPtr; Tcl_Filesystem* retVal = NULL; if (pathPtr == NULL) { Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object"); return NULL; } /* * If the object has a refCount of zero, we reject it. This is to avoid * possible segfaults or nondeterministic memory leaks (i.e. the user * doesn't know if they should decrement the ref count on return or not). */ if (pathPtr->refCount == 0) { Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0"); return NULL; } /* * Check if the filesystem has changed in some way since this object's * internal representation was calculated. Before doing that, assure we * have the most up-to-date copy of the master filesystem. This is * accomplished by the FsGetFirstFilesystem() call. */ fsRecPtr = FsGetFirstFilesystem(); if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) { return NULL; } /* * Call each of the "pathInFilesystem" functions in succession. A * non-return value of -1 indicates the particular function has succeeded. */ while ((retVal == NULL) && (fsRecPtr != NULL)) { Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc; if (proc != NULL) { ClientData clientData = NULL; int ret = (*proc)(pathPtr, &clientData); if (ret != -1) { /* * We assume the type of pathPtr hasn't been changed by the * above call to the pathInFilesystemProc. */ TclFSSetPathDetails(pathPtr, fsRecPtr, clientData); retVal = fsRecPtr->fsPtr; } } fsRecPtr = fsRecPtr->nextPtr; } return retVal; } /* *--------------------------------------------------------------------------- * * Tcl_FSGetNativePath -- * * This function is for use by the Win/Unix native filesystems, so that * they can easily retrieve the native (char* or TCHAR*) representation * of a path. Other filesystems will probably want to implement similar * functions. They basically act as a safety net around * Tcl_FSGetInternalRep. Normally your file- system procedures will * always be called with path objects already converted to the correct * filesystem, but if for some reason they are called directly (i.e. by * procedures not in this file), then one cannot necessarily guarantee * that the path object pointer is from the correct filesystem. * * Note: in the future it might be desireable to have separate versions * of this function with different signatures, for example * Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since * native paths are all string based, we use just one function. * * Results: * NULL or a valid native path. * * Side effects: * See Tcl_FSGetInternalRep. * *--------------------------------------------------------------------------- */ CONST char * Tcl_FSGetNativePath(pathPtr) Tcl_Obj *pathPtr; { return (CONST char *) Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); } /* *--------------------------------------------------------------------------- * * NativeFreeInternalRep -- * * Free a native internal representation, which will be non-NULL. * * Results: * None. * * Side effects: * Memory is released. * *--------------------------------------------------------------------------- */ static void NativeFreeInternalRep(clientData) ClientData clientData; { ckfree((char *) clientData); } /* *--------------------------------------------------------------------------- * * Tcl_FSFileSystemInfo -- * * This function returns a list of two elements. The first element is * the name of the filesystem (e.g. "native" or "vfs"), and the second is * the particular type of the given path within that filesystem. * * Results: * A list of two elements. * * Side effects: * The object may be converted to a path type. * *--------------------------------------------------------------------------- */ Tcl_Obj* Tcl_FSFileSystemInfo(pathPtr) Tcl_Obj* pathPtr; { Tcl_Obj *resPtr; Tcl_FSFilesystemPathTypeProc *proc; Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr == NULL) { return NULL; } resPtr = Tcl_NewListObj(0,NULL); Tcl_ListObjAppendElement(NULL, resPtr, Tcl_NewStringObj(fsPtr->typeName,-1)); proc = fsPtr->filesystemPathTypeProc; if (proc != NULL) { Tcl_Obj *typePtr = (*proc)(pathPtr); if (typePtr != NULL) { Tcl_ListObjAppendElement(NULL, resPtr, typePtr); } } return resPtr; } /* *--------------------------------------------------------------------------- * * Tcl_FSPathSeparator -- * * This function returns the separator to be used for a given path. The * object returned should have a refCount of zero * * Results: * A Tcl object, with a refCount of zero. If the caller needs to retain a * reference to the object, it should call Tcl_IncrRefCount, and should * otherwise free the object. * * Side effects: * The path object may be converted to a path type. * *--------------------------------------------------------------------------- */ Tcl_Obj* Tcl_FSPathSeparator(pathPtr) Tcl_Obj* pathPtr; { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr == NULL) { return NULL; } if (fsPtr->filesystemSeparatorProc != NULL) { return (*fsPtr->filesystemSeparatorProc)(pathPtr); } else { /* * Allow filesystems not to provide a filesystemSeparatorProc if they * wish to use the standard forward slash. */ return Tcl_NewStringObj("/", 1); } } /* *--------------------------------------------------------------------------- * * NativeFilesystemSeparator -- * * This function is part of the native filesystem support, and returns * the separator for the given path. * * Results: * String object containing the separator character. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static Tcl_Obj* NativeFilesystemSeparator(pathPtr) Tcl_Obj* pathPtr; { char *separator = NULL; /* lint */ switch (tclPlatform) { case TCL_PLATFORM_UNIX: separator = "/"; break; case TCL_PLATFORM_WINDOWS: separator = "\\"; break; } return Tcl_NewStringObj(separator,1); } /* Everything from here on is contained in this obsolete ifdef */ #ifdef USE_OBSOLETE_FS_HOOKS /* *---------------------------------------------------------------------- * * TclStatInsertProc -- * * Insert the passed procedure pointer at the head of the list of * functions which are used during a call to 'TclStat(...)'. The passed * function should behave exactly like 'TclStat' when called during that * time (see 'TclStat(...)' for more information). The function will be * added even if it already in the list. * * Results: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could * not be allocated. * * Side effects: * Memory allocated and modifies the link list for 'TclStat' functions. * *---------------------------------------------------------------------- */ int TclStatInsertProc (proc) TclStatProc_ *proc; |
︙ | ︙ | |||
4320 4321 4322 4323 4324 4325 4326 | /* *---------------------------------------------------------------------- * * TclStatDeleteProc -- * * Removed the passed function pointer from the list of 'TclStat' | | < | | | > | | | | 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 | /* *---------------------------------------------------------------------- * * TclStatDeleteProc -- * * Removed the passed function pointer from the list of 'TclStat' * functions. Ensures that the built-in stat function is not removvable. * * Results: * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR * otherwise. * * Side effects: * Memory is deallocated and the respective list updated. * *---------------------------------------------------------------------- */ int TclStatDeleteProc (proc) TclStatProc_ *proc; { int retVal = TCL_ERROR; StatProc *tmpStatProcPtr; StatProc *prevStatProcPtr = NULL; Tcl_MutexLock(&obsoleteFsHookMutex); tmpStatProcPtr = statProcList; /* * Traverse the 'statProcList' looking for the particular node whose * 'proc' member matches 'proc' and remove that one from the list. Ensure * that the "default" node cannot be removed. */ while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) { if (tmpStatProcPtr->proc == proc) { if (prevStatProcPtr == NULL) { statProcList = tmpStatProcPtr->nextPtr; } else { |
︙ | ︙ | |||
4377 4378 4379 4380 4381 4382 4383 | /* *---------------------------------------------------------------------- * * TclAccessInsertProc -- * * Insert the passed procedure pointer at the head of the list of | | | | | < | | | < | 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 | /* *---------------------------------------------------------------------- * * TclAccessInsertProc -- * * Insert the passed procedure pointer at the head of the list of * functions which are used during a call to 'TclAccess(...)'. The * passed function should behave exactly like 'TclAccess' when called * during that time (see 'TclAccess(...)' for more information). The * function will be added even if it already in the list. * * Results: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could * not be allocated. * * Side effects: * Memory allocated and modifies the link list for 'TclAccess' functions. * *---------------------------------------------------------------------- */ int TclAccessInsertProc(proc) TclAccessProc_ *proc; |
︙ | ︙ | |||
4429 4430 4431 4432 4433 4434 4435 | * TclAccessDeleteProc -- * * Removed the passed function pointer from the list of 'TclAccess' * functions. Ensures that the built-in access function is not * removvable. * * Results: | | | | | | | | 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 | * TclAccessDeleteProc -- * * Removed the passed function pointer from the list of 'TclAccess' * functions. Ensures that the built-in access function is not * removvable. * * Results: * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR * otherwise. * * Side effects: * Memory is deallocated and the respective list updated. * *---------------------------------------------------------------------- */ int TclAccessDeleteProc(proc) TclAccessProc_ *proc; { int retVal = TCL_ERROR; AccessProc *tmpAccessProcPtr; AccessProc *prevAccessProcPtr = NULL; /* * Traverse the 'accessProcList' looking for the particular node whose * 'proc' member matches 'proc' and remove that one from the list. Ensure * that the "default" node cannot be removed. */ Tcl_MutexLock(&obsoleteFsHookMutex); tmpAccessProcPtr = accessProcList; while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) { if (tmpAccessProcPtr->proc == proc) { if (prevAccessProcPtr == NULL) { |
︙ | ︙ | |||
4482 4483 4484 4485 4486 4487 4488 | /* *---------------------------------------------------------------------- * * TclOpenFileChannelInsertProc -- * * Insert the passed procedure pointer at the head of the list of * functions which are used during a call to | | | | | | | | | | | < | | | | | | | | < | | | | | | | | < | > > > > > > > > | 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 | /* *---------------------------------------------------------------------- * * TclOpenFileChannelInsertProc -- * * Insert the passed procedure pointer at the head of the list of * functions which are used during a call to * 'Tcl_OpenFileChannel(...)'. The passed function should behave exactly * like 'Tcl_OpenFileChannel' when called during that time (see * 'Tcl_OpenFileChannel(...)' for more information). The function will be * added even if it already in the list. * * Results: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could * not be allocated. * * Side effects: * Memory allocated and modifies the link list for 'Tcl_OpenFileChannel' * functions. * *---------------------------------------------------------------------- */ int TclOpenFileChannelInsertProc(proc) TclOpenFileChannelProc_ *proc; { int retVal = TCL_ERROR; if (proc != NULL) { OpenFileChannelProc *newOpenFileChannelProcPtr; newOpenFileChannelProcPtr = (OpenFileChannelProc *) ckalloc(sizeof(OpenFileChannelProc)); newOpenFileChannelProcPtr->proc = proc; Tcl_MutexLock(&obsoleteFsHookMutex); newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; openFileChannelProcList = newOpenFileChannelProcPtr; Tcl_MutexUnlock(&obsoleteFsHookMutex); retVal = TCL_OK; } return retVal; } /* *---------------------------------------------------------------------- * * TclOpenFileChannelDeleteProc -- * * Removed the passed function pointer from the list of * 'Tcl_OpenFileChannel' functions. Ensures that the built-in open file * channel function is not removable. * * Results: * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR * otherwise. * * Side effects: * Memory is deallocated and the respective list updated. * *---------------------------------------------------------------------- */ int TclOpenFileChannelDeleteProc(proc) TclOpenFileChannelProc_ *proc; { int retVal = TCL_ERROR; OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; /* * Traverse the 'openFileChannelProcList' looking for the particular node * whose 'proc' member matches 'proc' and remove that one from the list. */ Tcl_MutexLock(&obsoleteFsHookMutex); tmpOpenFileChannelProcPtr = openFileChannelProcList; while ((retVal == TCL_ERROR) && (tmpOpenFileChannelProcPtr != NULL)) { if (tmpOpenFileChannelProcPtr->proc == proc) { if (prevOpenFileChannelProcPtr == NULL) { openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; } else { prevOpenFileChannelProcPtr->nextPtr = tmpOpenFileChannelProcPtr->nextPtr; } ckfree((char *) tmpOpenFileChannelProcPtr); retVal = TCL_OK; } else { prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; } } Tcl_MutexUnlock(&obsoleteFsHookMutex); return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclIndexObj.c.
|
| | | | | | | | | | | | | | | < | | < | | | < | | | | | | | > | | | < | > | | > | | | < < | | | < | | | | | | | | | | > | | | > | | | | | | > > | | | | > | | | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 | /* * tclIndexObj.c -- * * This file implements objects of type "index". This object type is used * to lookup a keyword in a table of valid values and cache the index of * the matching entry. * * Copyright (c) 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclIndexObj.c,v 1.22.2.2 2005/08/02 18:15:40 dgp Exp $ */ #include "tclInt.h" /* * Prototypes for functions defined later in this file: */ static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); static void DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr)); static void FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); /* * The structure below defines the index Tcl object type by means of functions * that can be invoked by generic object code. */ static Tcl_ObjType indexType = { "index", /* name */ FreeIndex, /* freeIntRepProc */ DupIndex, /* dupIntRepProc */ UpdateStringOfIndex, /* updateStringProc */ SetIndexFromAny /* setFromAnyProc */ }; /* * The definition of the internal representation of the "index" object; The * internalRep.otherValuePtr field of an object of "index" type will be a * pointer to one of these structures. * * Keep this structure declaration in sync with tclTestObj.c */ typedef struct { VOID *tablePtr; /* Pointer to the table of strings */ int offset; /* Offset between table entries */ int index; /* Selected index into table. */ } IndexRep; /* * The following macros greatly simplify moving through a table... */ #define STRING_AT(table, offset, index) \ (*((CONST char * CONST *)(((char *)(table)) + ((offset) * (index))))) #define NEXT_ENTRY(table, offset) \ (&(STRING_AT(table, offset, 1))) #define EXPAND_OF(indexRep) \ STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index) /* *---------------------------------------------------------------------- * * Tcl_GetIndexFromObj -- * * This function looks up an object's value in a table of strings and * returns the index of the matching string, if any. * * Results: * If the value of objPtr is identical to or a unique abbreviation for * one of the entries in objPtr, then the return value is TCL_OK and the * index of the matching entry is stored at *indexPtr. If there isn't a * proper match, then TCL_ERROR is returned and an error message is left * in interp's result (unless interp is NULL). The msg argument is used * in the error message; for example, if msg has the value "option" then * the error message will say something flag 'bad option "foo": must be * ...' * * Side effects: * The result of the lookup is cached as the internal rep of objPtr, so * that repeated lookups can be done quickly. * *---------------------------------------------------------------------- */ int Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr; /* Object containing the string to lookup. */ CONST char **tablePtr; /* Array of strings to compare against the * value of objPtr; last entry must be NULL * and there must not be duplicate entries. */ CONST char *msg; /* Identifying word to use in error * messages. */ int flags; /* 0 or TCL_EXACT */ int *indexPtr; /* Place to store resulting integer index. */ { /* * See if there is a valid cached result from a previous lookup (doing the * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in * the common case where the result is cached). */ if (objPtr->typePtr == &indexType) { IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; /* * Here's hoping we don't get hit by unfortunate packing constraints * on odd platforms like a Cray PVP... */ if (indexRep->tablePtr == (VOID *)tablePtr && indexRep->offset == sizeof(char *)) { *indexPtr = indexRep->index; return TCL_OK; } } return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), msg, flags, indexPtr); } /* *---------------------------------------------------------------------- * * Tcl_GetIndexFromObjStruct -- * * This function looks up an object's value given a starting string and * an offset for the amount of space between strings. This is useful when * the strings are embedded in some other kind of array. * * Results: * If the value of objPtr is identical to or a unique abbreviation for * one of the entries in objPtr, then the return value is TCL_OK and the * index of the matching entry is stored at *indexPtr. If there isn't a * proper match, then TCL_ERROR is returned and an error message is left * in interp's result (unless interp is NULL). The msg argument is used * in the error message; for example, if msg has the value "option" then * the error message will say something flag 'bad option "foo": must be * ...' * * Side effects: * The result of the lookup is cached as the internal rep of objPtr, so * that repeated lookups can be done quickly. * *---------------------------------------------------------------------- */ int Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr; /* Object containing the string to lookup. */ CONST VOID *tablePtr; /* The first string in the table. The second * string will be at this address plus the * offset, the third plus the offset again, * etc. The last entry must be NULL and there * must not be duplicate entries. */ int offset; /* The number of bytes between entries */ CONST char *msg; /* Identifying word to use in error * messages. */ int flags; /* 0 or TCL_EXACT */ int *indexPtr; /* Place to store resulting integer index. */ { int index, length, i, numAbbrev; char *key, *p1; CONST char *p2; CONST char * CONST *entryPtr; Tcl_Obj *resultPtr; IndexRep *indexRep; /* * See if there is a valid cached result from a previous lookup. */ if (objPtr->typePtr == &indexType) { indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; return TCL_OK; } } /* * Lookup the value of the object in the table. Accept unique * abbreviations unless TCL_EXACT is set in flags. */ key = Tcl_GetStringFromObj(objPtr, &length); index = -1; numAbbrev = 0; /* * The key should not be empty, otherwise it's not a match. */ if (key[0] == '\0') { goto error; } /* * Scan the table looking for one of: * - An exact match (always preferred) * - A single abbreviation (allowed depending on flags) * - Several abbreviations (never allowed, but overridden by exact match) */ for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr = NEXT_ENTRY(entryPtr, offset), i++) { for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { if (*p1 == '\0') { index = i; goto done; } } if (*p1 == '\0') { /* * The value is an abbreviation for this entry. Continue checking * other entries to make sure it's unique. If we get more than one * unique abbreviation, keep searching to see if there is an exact * match, but remember the number of unique abbreviations and * don't allow either. */ numAbbrev++; index = i; } } /* * Check if we were instructed to disallow abbreviations. */ if ((flags & TCL_EXACT) || (numAbbrev != 1)) { goto error; } done: /* * Cache the found representation. Note that we want to avoid allocating a * new internal-rep if at all possible since that is potentially a slow * operation. */ if (objPtr->typePtr == &indexType) { indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; } else { TclFreeIntRep(objPtr); indexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); objPtr->internalRep.otherValuePtr = (VOID *) indexRep; objPtr->typePtr = &indexType; } indexRep->tablePtr = (VOID*) tablePtr; indexRep->offset = offset; indexRep->index = index; *indexPtr = index; return TCL_OK; error: if (interp != NULL) { /* * Produce a fancy error message. */ int count; TclNewObj(resultPtr); Tcl_SetObjResult(interp, resultPtr); Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", key, "\": must be ", STRING_AT(tablePtr,offset,0), (char*) NULL); for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0; *entryPtr != NULL; entryPtr = NEXT_ENTRY(entryPtr, offset), count++) { if (*NEXT_ENTRY(entryPtr, offset) == NULL) { Tcl_AppendStringsToObj(resultPtr, (count > 0) ? ", or " : " or ", *entryPtr, (char *) NULL); |
︙ | ︙ | |||
290 291 292 293 294 295 296 | } /* *---------------------------------------------------------------------- * * SetIndexFromAny -- * | | | | | | | | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 | } /* *---------------------------------------------------------------------- * * SetIndexFromAny -- * * This function is called to convert a Tcl object to index internal * form. However, this doesn't make sense (need to have a table of * keywords in order to do the conversion) so the function always * generates an error. * * Results: * The return value is always TCL_ERROR, and an error message is left in * interp's result if interp isn't NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
321 322 323 324 325 326 327 | } /* *---------------------------------------------------------------------- * * UpdateStringOfIndex -- * | | | < | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 | } /* *---------------------------------------------------------------------- * * UpdateStringOfIndex -- * * This function is called to convert a Tcl object from index internal * form to its string form. No abbreviation is ever generated. * * Results: * None. * * Side effects: * The string representation of the object is updated. * |
︙ | ︙ | |||
355 356 357 358 359 360 361 | } /* *---------------------------------------------------------------------- * * DupIndex -- * | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * DupIndex -- * * This function is called to copy the internal rep of an index Tcl * object from to another object. * * Results: * None. * * Side effects: * The internal representation of the target object is updated and the * type is set. * *---------------------------------------------------------------------- */ static void DupIndex(srcPtr, dupPtr) Tcl_Obj *srcPtr, *dupPtr; { IndexRep *srcIndexRep = (IndexRep *) srcPtr->internalRep.otherValuePtr; IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); dupPtr->internalRep.otherValuePtr = (VOID *) dupIndexRep; dupPtr->typePtr = &indexType; } /* *---------------------------------------------------------------------- * * FreeIndex -- * * This function is called to delete the internal rep of an index Tcl * object. * * Results: * None. * * Side effects: * The internal representation of the target object is deleted. * |
︙ | ︙ | |||
409 410 411 412 413 414 415 | } /* *---------------------------------------------------------------------- * * Tcl_WrongNumArgs -- * | | | | | | | | | | > > > > > > > > > > > > > > > | | < | | < | | | > > > > > > > > > > > | | | < | | | > | > > > > > | | > | | < > > > > | | | > > > > | > > > > | | > | | | | > | | | | < | > | | > | | | | | | | | | < | | | | < | | | | | | < | | > | | | | | > > | | < | > | | | | > > > > > > > > > | 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 | } /* *---------------------------------------------------------------------- * * Tcl_WrongNumArgs -- * * This function generates a "wrong # args" error message in an * interpreter. It is used as a utility function by many command * functions, including the function that implements procedures. * * Results: * None. * * Side effects: * An error message is generated in interp's result object to indicate * that a command was invoked with the wrong number of arguments. The * message has the form * wrong # args: should be "foo bar additional stuff" * where "foo" and "bar" are the initial objects in objv (objc determines * how many of these are printed) and "additional stuff" is the contents * of the message argument. * * The message printed is modified somewhat if the command is wrapped * inside an ensemble. In that case, the error message generated is * rewritten in such a way that it appears to be generated from the * user-visible command and not how that command is actually implemented, * giving a better overall user experience. * * Internally, the Tcl core may set the flag INTERP_ALTERNATE_WRONG_ARGS * in the interpreter to generate complex multi-part messages by calling * this function repeatedly. This allows the code that knows how to * handle ensemble-related error messages to be kept here while still * generating suitable error messages for commands like [read] and * [socket]. Ideally, this would be done through an extra flags argument, * but that wouldn't be source-compatible with the existing API and it's * a fairly rare requirement anyway. * *---------------------------------------------------------------------- */ void Tcl_WrongNumArgs(interp, objc, objv, message) Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments to print from objv. */ Tcl_Obj *CONST objv[]; /* Initial argument objects, which should be * included in the error message. */ CONST char *message; /* Error message to print after the leading * objects in objv. The message may be * NULL. */ { Tcl_Obj *objPtr; int i, len, elemLen, flags; register IndexRep *indexRep; Interp *iPtr = (Interp *) interp; char *elementStr; /* * [incr Tcl] does something fairly horrific when generating error * messages for its ensembles; it passes the whole set of ensemble * arguments as a list in the first argument. This means that this code * causes a problem in iTcl if it attempts to correctly quote all * arguments, which would be the correct thing to do. We work around this * nasty behaviour for now, and hope that we can remove it all in the * future... */ #ifndef AVOID_HACKS_FOR_ITCL int isFirst = 1; /* Special flag used to inhibit the treating * of the first word as a list element so the * hacky way Itcl generates error messages for * its ensembles will still work. [Bug * 1066837] */ # define MAY_QUOTE_WORD (!isFirst) # define AFTER_FIRST_WORD (isFirst = 0) #else /* !AVOID_HACKS_FOR_ITCL */ # define MAY_QUOTE_WORD 1 # define AFTER_FIRST_WORD (void) 0 #endif /* AVOID_HACKS_FOR_ITCL */ TclNewObj(objPtr); if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) { Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp)); Tcl_AppendToObj(objPtr, " or \"", -1); } else { Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); } /* * Check to see if we are processing an ensemble implementation, and if so * rewrite the results in terms of how the ensemble was invoked. */ if (iPtr->ensembleRewrite.sourceObjs != NULL) { int toSkip = iPtr->ensembleRewrite.numInsertedObjs; int toPrint = iPtr->ensembleRewrite.numRemovedObjs; Tcl_Obj * CONST *origObjv = iPtr->ensembleRewrite.sourceObjs; /* * We only know how to do rewriting if all the replaced objects are * actually arguments (in objv) to this function. Otherwise it just * gets too complicated and we'd be better off just giving a slightly * confusing error message... */ if (objc < toSkip) { goto addNormalArgumentsToMessage; } /* * Strip out the actual arguments that the ensemble inserted. */ objv += toSkip; objc -= toSkip; /* * We assume no object is of index type. */ for (i=0 ; i<toPrint ; i++) { /* * Add the element, quoting it if necessary. */ elementStr = Tcl_GetStringFromObj(origObjv[i], &elemLen); len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { char *quotedElementStr = ckalloc((unsigned) len); len = Tcl_ConvertCountedElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); ckfree(quotedElementStr); } else { Tcl_AppendToObj(objPtr, elementStr, elemLen); } AFTER_FIRST_WORD; /* * Add a space if the word is not the last one (which has a * moderately complex condition here). */ if (i<toPrint-1 || objc!=0 || message!=NULL) { Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); } } } /* * Now add the arguments (other than those rewritten) that the caller took * from its calling context. */ addNormalArgumentsToMessage: for (i = 0; i < objc; i++) { /* * If the object is an index type use the index table which allows for * the correct error message even if the subcommand was abbreviated. * Otherwise, just use the string rep. */ if (objv[i]->typePtr == &indexType) { indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL); } else { /* * Quote the argument if it contains spaces (Bug 942757). */ elementStr = Tcl_GetStringFromObj(objv[i], &elemLen); len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { char *quotedElementStr = ckalloc((unsigned) len); len = Tcl_ConvertCountedElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); ckfree(quotedElementStr); } else { Tcl_AppendToObj(objPtr, elementStr, elemLen); } } AFTER_FIRST_WORD; /* * Append a space character (" ") if there is more text to follow * (either another element from objv, or the message string). */ if (i<objc-1 || message!=NULL) { Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); } } /* * Add any trailing message bits and set the resulting string as the * interpreter result. Caller is responsible for reporting this as an * actual error. */ if (message != NULL) { Tcl_AppendStringsToObj(objPtr, message, (char *) NULL); } Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL); Tcl_SetObjResult(interp, objPtr); #undef MAY_QUOTE_WORD #undef AFTER_FIRST_WORD } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
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.84.2.12 2005/08/23 06:15:21 dgp Exp $ library tcl # Define the unsupported generic interfaces. interface tclInt |
︙ | ︙ | |||
110 111 112 113 114 115 116 | int TclFindElement(Tcl_Interp *interp, CONST char *listStr, int listLength, CONST char **elementPtr, CONST char **nextPtr, int *sizePtr, int *bracePtr) } declare 23 generic { Proc *TclFindProc(Interp *iPtr, CONST char *procName) } | > | | < > | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | int TclFindElement(Tcl_Interp *interp, CONST char *listStr, int listLength, CONST char **elementPtr, CONST char **nextPtr, int *sizePtr, int *bracePtr) } declare 23 generic { Proc *TclFindProc(Interp *iPtr, CONST char *procName) } # Replaced with macro (see tclInt.h) in Tcl 8.5 #declare 24 generic { # int TclFormatInt(char *buffer, long n) #} declare 25 generic { void TclFreePackageInfo(Interp *iPtr) } # Removed in 8.1: # declare 26 generic { # char *TclGetCwd(Tcl_Interp *interp) # } |
︙ | ︙ | |||
205 206 207 208 209 210 211 | # int localIndex, Tcl_Obj *elemPtr, long incrAmount) #} # Removed in 8.4b2: #declare 48 generic { # Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, # long incrAmount) #} | | | | < > | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 | # 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) } |
︙ | ︙ | |||
548 549 550 551 552 553 554 | 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) #} | | | < > | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 | 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) |
︙ | ︙ | |||
704 705 706 707 708 709 710 | declare 173 generic { int TclUniCharMatch(CONST Tcl_UniChar *string, int strLen, CONST Tcl_UniChar *pattern, int ptnLen, int nocase) } # added for 8.4.3 | | | | < > | 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 | declare 173 generic { int TclUniCharMatch(CONST Tcl_UniChar *string, int strLen, CONST Tcl_UniChar *pattern, int ptnLen, int nocase) } # added for 8.4.3 #declare 174 generic { # Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, # Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed) #} # Factoring out of trace code declare 175 generic { int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr, CONST char *part1, CONST char *part2, int flags, int leaveErrMsg) } |
︙ | ︙ | |||
730 731 732 733 734 735 736 737 | declare 178 generic { void Tcl_SetStartupScript(Tcl_Obj *pathPtr, CONST char* encodingName) } declare 179 generic { Tcl_Obj *Tcl_GetStartupScript(CONST char **encodingNamePtr) } # Allocate lists without copying arrays | > | | < > | | | < > > > > | | < > | | < > | | < > | | < > | | < > | | < > | | < > | | < > | | < > | | < > | | < > | | < > | | < > | | < > | 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 | declare 178 generic { void Tcl_SetStartupScript(Tcl_Obj *pathPtr, CONST char* encodingName) } declare 179 generic { Tcl_Obj *Tcl_GetStartupScript(CONST char **encodingNamePtr) } # REMOVED # Allocate lists without copying arrays # declare 180 generic { # Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv) # } #declare 181 generic { # Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv, # CONST char *file, int line) #} # TclpGmtime and TclpLocaltime promoted to the generic interface from unix declare 182 generic { struct tm *TclpLocaltime(CONST time_t *clock) } declare 183 generic { struct tm *TclpGmtime(CONST time_t *clock) } # For the new "Thread Storage" subsystem. ### REMOVED on grounds it should never have been exposed. All these ### functions are now either static in tclThreadStorage.c or ### MODULE_SCOPE. # declare 184 generic { # void TclThreadStorageLockInit(void) # } # declare 185 generic { # void TclThreadStorageLock(void) # } # declare 186 generic { # void TclThreadStorageUnlock(void) # } # declare 187 generic { # void TclThreadStoragePrint(FILE *outFile, int flags) # } # declare 188 generic { # Tcl_HashTable *TclThreadStorageGetHashTable(Tcl_ThreadId id) # } # declare 189 generic { # Tcl_HashTable *TclThreadStorageInit(Tcl_ThreadId id, void *reserved) # } # declare 190 generic { # void TclThreadStorageDataKeyInit(Tcl_ThreadDataKey *keyPtr) # } # declare 191 generic { # void *TclThreadStorageDataKeyGet(Tcl_ThreadDataKey *keyPtr) # } # declare 192 generic { # void TclThreadStorageDataKeySet(Tcl_ThreadDataKey *keyPtr, void *data) # } # declare 193 generic { # void TclFinalizeThreadStorageThread(Tcl_ThreadId id) # } # declare 194 generic { # void TclFinalizeThreadStorage(void) # } # declare 195 generic { # void TclFinalizeThreadStorageData(Tcl_ThreadDataKey *keyPtr) # } # declare 196 generic { # void TclFinalizeThreadStorageDataKey(Tcl_ThreadDataKey *keyPtr) # } # # Added in tcl8.5a5 for compiler/executor experimentation. # declare 197 generic { int TclCompEvalObj (Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 198 generic { int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr, CallFrame **framePtrPtr) } #declare 199 generic { # int TclMatchIsTrivial(CONST char *pattern) #} # 200-208 exported for use by the test suite [Bug 1054748] declare 200 generic { int TclpObjRemoveDirectory (Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr) } declare 201 generic { |
︙ | ︙ | |||
855 856 857 858 859 860 861 862 863 864 865 866 867 868 | } declare 213 generic { Tcl_Obj * TclGetObjNameOfExecutable(void) } declare 214 generic { void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding) } ############################################################################## # Define the platform specific internal Tcl interface. These functions are # only available on the designated platform. interface tclIntPlat | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } declare 213 generic { Tcl_Obj * TclGetObjNameOfExecutable(void) } declare 214 generic { void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding) } declare 215 generic { char * TclStackAlloc(Tcl_Interp *interp, int numBytes) } declare 216 generic { void TclStackFree(Tcl_Interp *interp) } declare 217 generic { int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame ) } declare 218 generic { void TclPopStackFrame(Tcl_Interp *interp) } # Entries in tommath needed only by tcltest declare 219 generic { int TclBN_mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d) } declare 220 generic { int TclBN_mp_mul_d(mp_int *a, mp_digit b, mp_int *c) } declare 221 generic { void TclBN_mp_clear(mp_int *a) } declare 222 generic { int TclBN_mp_init(mp_int *a) } declare 223 generic { int TclBN_mp_read_radix(mp_int *a, const char *str, int radix) } # for use in tclTest.c declare 224 generic { TclPlatformType *TclGetPlatform(void) } # declare 225 generic { Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *CONST keyv[], int flags) } ############################################################################## # Define the platform specific internal Tcl interface. These functions are # only available on the designated platform. interface tclIntPlat |
︙ | ︙ | |||
957 958 959 960 961 962 963 | } declare 23 win { char *TclpGetTZName(int isdst) } declare 24 win { char *TclWinNoBackslash(char *path) } | > | | < > | 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 | } declare 23 win { char *TclpGetTZName(int isdst) } declare 24 win { char *TclWinNoBackslash(char *path) } # replaced by generic TclGetPlatform #declare 25 win { # TclPlatformType *TclWinGetPlatform(void) #} declare 26 win { void TclWinSetInterfaces(int wide) } # Added in Tcl 8.3.3 / 8.4 declare 27 win { |
︙ | ︙ |
Changes to generic/tclInt.h.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclInt.h -- * * Declarations of things used internally by the Tcl interpreter. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-19/99 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. 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 44 45 46 47 48 49 | /* * tclInt.h -- * * Declarations of things used internally by the Tcl interpreter. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-19/99 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.202.2.42 2005/10/07 20:15:09 dgp Exp $ */ #ifndef _TCLINT #define _TCLINT /* * Some numerics configuration options */ #undef NO_WIDE_TYPE #undef ACCEPT_NAN /* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but * greater modularity. The order of the three groups of #includes is * important. For example, stdio.h is needed by tcl.h, and the _ANSI_ARGS_ * declaration in tcl.h is needed by stdlib.h in some configurations. */ #ifdef HAVE_TCL_CONFIG_H #include "tclConfig.h" #endif #ifndef _TCL #include "tcl.h" #endif #include <stdio.h> #include <ctype.h> #ifdef NO_LIMITS_H # include "../compat/limits.h" #else |
︙ | ︙ | |||
56 57 58 59 60 61 62 | #ifdef STDC_HEADERS #include <stddef.h> #else typedef int ptrdiff_t; #endif /* | > > > > > > > > > > > > > > > > > > > > > > > > > > | | < > > > > > > > > | | < | | | < | < < < | | | | < | | | < | > | | | | | | | | | | | | < | | < | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | < | | | | | | | | | | | | > | | | | | | > | | | | | | | < | | | | < | | | | > > | | | | | | < | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | 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 | #ifdef STDC_HEADERS #include <stddef.h> #else typedef int ptrdiff_t; #endif /* * Ensure WORDS_BIGENDIAN is defined correcly: * Needs to happen here in addition to configure to work with fat compiles on * Darwin (i.e. ppc and i386 at the same time). */ #ifdef HAVE_SYS_TYPES_H # include <sys/types.h> #endif #ifdef HAVE_SYS_PARAM_H # include <sys/param.h> #endif #ifdef BYTE_ORDER # ifdef BIG_ENDIAN # if BYTE_ORDER == BIG_ENDIAN # undef WORDS_BIGENDIAN # define WORDS_BIGENDIAN # endif # endif # ifdef LITTLE_ENDIAN # if BYTE_ORDER == LITTLE_ENDIAN # undef WORDS_BIGENDIAN # endif # endif #endif /* * Used to tag functions that are only to be visible within the module being * built and not outside it (where this is supported by the linker). */ #ifndef MODULE_SCOPE # ifdef __cplusplus # define MODULE_SCOPE extern "C" # else # define MODULE_SCOPE extern # endif #endif /* * When Tcl_WideInt and long are the same type, there's no value in * having a tclWideIntType separate from the tclIntType. */ #ifdef TCL_WIDE_INT_IS_LONG #define NO_WIDE_TYPE #endif /* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. */ struct Tcl_ResolvedVarInfo; typedef Tcl_Var (Tcl_ResolveRuntimeVarProc) (Tcl_Interp* interp, struct Tcl_ResolvedVarInfo *vinfoPtr); typedef void (Tcl_ResolveVarDeleteProc)(struct Tcl_ResolvedVarInfo *vinfoPtr); /* * The following structure encapsulates the routines needed to resolve a * variable reference at runtime. Any variable specific state will typically * be appended to this structure. */ typedef struct Tcl_ResolvedVarInfo { Tcl_ResolveRuntimeVarProc *fetchProc; Tcl_ResolveVarDeleteProc *deleteProc; } Tcl_ResolvedVarInfo; typedef int (Tcl_ResolveCompiledVarProc) (Tcl_Interp* interp, CONST84 char* name, int length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr); typedef int (Tcl_ResolveVarProc) (Tcl_Interp* interp, CONST84 char* name, Tcl_Namespace *context, int flags, Tcl_Var *rPtr); typedef int (Tcl_ResolveCmdProc) (Tcl_Interp* interp, CONST84 char* name, Tcl_Namespace *context, int flags, Tcl_Command *rPtr); typedef struct Tcl_ResolverInfo { Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name * resolution. */ Tcl_ResolveVarProc *varResProc; /* Procedure handling variable name * resolution for variables that * can only be handled at runtime. */ Tcl_ResolveCompiledVarProc *compiledVarResProc; /* Procedure handling variable name * resolution at compile time. */ } Tcl_ResolverInfo; /* *---------------------------------------------------------------- * Data structures related to namespaces. *---------------------------------------------------------------- */ typedef struct Tcl_Ensemble Tcl_Ensemble; typedef struct NamespacePathEntry NamespacePathEntry; /* * The structure below defines a namespace. * Note: the first five fields must match exactly the fields in a * Tcl_Namespace structure (see tcl.h). If you change one, be sure to change * the other. */ typedef struct Namespace { char *name; /* The namespace's simple (unqualified) name. * This contains no ::'s. The name of the * global namespace is "" although "::" is an * synonym. */ char *fullName; /* The namespace's fully qualified name. This * starts with ::. */ ClientData clientData; /* An arbitrary value associated with this * namespace. */ Tcl_NamespaceDeleteProc *deleteProc; /* Procedure invoked when deleting the * namespace to, e.g., free clientData. */ struct Namespace *parentPtr;/* Points to the namespace that contains this * one. NULL if this is the global * namespace. */ Tcl_HashTable childTable; /* Contains any child namespaces. Indexed by * strings; values have type (Namespace *). */ long nsId; /* Unique id for the namespace. */ Tcl_Interp *interp; /* The interpreter containing this * namespace. */ int flags; /* OR-ed combination of the namespace status * flags NS_DYING and NS_DEAD listed below. */ int activationCount; /* Number of "activations" or active call * frames for this namespace that are on the * Tcl call stack. The namespace won't be * freed until activationCount becomes zero. */ int refCount; /* Count of references by namespaceName * objects. The namespace can't be freed until * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently * registered in the namespace. Indexed by * strings; values have type (Command *). * Commands imported by Tcl_Import have * Command structures that point (via an * ImportedCmdRef structure) to the Command * structure in the source namespace's command * table. */ Tcl_HashTable varTable; /* Contains all the (global) variables * currently in this namespace. Indexed by * strings; values have type (Var *). */ char **exportArrayPtr; /* Points to an array of string patterns * specifying which commands are exported. A * pattern may include "string match" style * wildcard characters to specify multiple * commands; however, no namespace qualifiers * are allowed. NULL if no export patterns are * registered. */ int numExportPatterns; /* Number of export patterns currently * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ int cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command * pointer; * this causes all its cached Command* * pointers to be invalidated. */ int resolverEpoch; /* Incremented whenever (a) the name * resolution rules change for this namespace * or (b) a newly added command shadows a * command that is compiled to bytecodes. This * invalidates all byte codes compiled in the * namespace, causing the code to be * recompiled under the new rules.*/ Tcl_ResolveCmdProc *cmdResProc; /* If non-null, this procedure overrides the * usual command resolution mechanism in Tcl. * This procedure is invoked within * Tcl_FindCommand to resolve all command * references within the namespace. */ Tcl_ResolveVarProc *varResProc; /* If non-null, this procedure overrides the * usual variable resolution mechanism in Tcl. * This procedure is invoked within * Tcl_FindNamespaceVar to resolve all * variable references within the namespace at * runtime. */ Tcl_ResolveCompiledVarProc *compiledVarResProc; /* If non-null, this procedure overrides the * usual variable resolution mechanism in Tcl. * This procedure is invoked within * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ int exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be * validated efficiently. */ Tcl_Ensemble *ensembles; /* List of structures that contain the details * of the ensembles that are implemented on * top of this namespace. */ int commandPathLength; /* The length of the explicit path. */ NamespacePathEntry *commandPathArray; /* The explicit path of the namespace as an * array. */ NamespacePathEntry *commandPathSourceList; /* Linked list of path entries that point to * this namespace. */ } Namespace; /* * An entry on a namespace's command resolution path. */ struct NamespacePathEntry { Namespace *nsPtr; /* What does this path entry point to? If it * is NULL, this path entry points is * redundant and should be skipped. */ Namespace *creatorNsPtr; /* Where does this path entry point from? This * allows for efficient invalidation of * references when the path entry's target * updates its current list of defined * commands. */ NamespacePathEntry *prevPtr, *nextPtr; /* Linked list pointers or NULL at either end * of the list that hangs off Namespace's * commandPathSourceList field. */ }; /* * Flags used to represent the status of a namespace: * * NS_DYING - 1 means Tcl_DeleteNamespace has been called to delete the * namespace but there are still active call frames on the Tcl * stack that refer to the namespace. When the last call frame * referring to it has been popped, it's variables and command * will be destroyed and it will be marked "dead" (NS_DEAD). The * namespace can no longer be looked up by name. * NS_DEAD - 1 means Tcl_DeleteNamespace has been called to delete the * namespace and no call frames still refer to it. Its variables * and command have already been destroyed. This bit allows the * namespace resolution code to recognize that the namespace is * "deleted". When the last namespaceName object in any byte code * unit that refers to the namespace has been freed (i.e., when * the namespace's refCount is 0), the namespace's storage will * be freed. */ #define NS_DYING 0x01 #define NS_DEAD 0x02 /* * Flags passed to TclGetNamespaceForQualName: * * TCL_GLOBAL_ONLY - (see tcl.h) Look only in the global ns. * TCL_NAMESPACE_ONLY - (see tcl.h) Look only in the context ns. * TCL_CREATE_NS_IF_UNKNOWN - Create unknown namespaces. * TCL_FIND_ONLY_NS - The name sought is a namespace name. */ #define TCL_CREATE_NS_IF_UNKNOWN 0x800 #define TCL_FIND_ONLY_NS 0x1000 /* *---------------------------------------------------------------- * Data structures related to variables. These are used primarily in tclVar.c *---------------------------------------------------------------- */ /* * The following structure defines a variable trace, which is used to invoke a * specific C procedure whenever certain operations are performed on a * variable. */ typedef struct VarTrace { Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by * flags are performed on variable. */ ClientData clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is * interested in: OR-ed combination of * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */ struct VarTrace *nextPtr; /* Next in list of traces associated with a * particular variable. */ } VarTrace; /* * The following structure defines a command trace, which is used to invoke a * specific C procedure whenever certain operations are performed on a * command. */ typedef struct CommandTrace { Tcl_CommandTraceProc *traceProc; /* Procedure to call when operations given by * flags are performed on command. */ ClientData clientData; /* Argument to pass to proc. */ 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. */ int refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ } 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. */ int reverseScan; /* Boolean set true when traces are scanning * in reverse order. */ } ActiveCommandTrace; /* * When a variable trace is active (i.e. its associated procedure is * executing) one of the following structures is linked into a list associated * with the variable's interpreter. The information in the structure is needed * in order for Tcl to behave reasonably if traces are deleted while traces * are active. */ typedef struct ActiveVarTrace { struct Var *varPtr; /* Variable that's being traced. */ struct ActiveVarTrace *nextPtr; /* Next in list of all active variable traces * for the interpreter, or NULL if no more. */ VarTrace *nextTracePtr; /* Next trace to check after current trace * procedure returns; if this trace gets * deleted, must update pointer to avoid using * free'd memory. */ } ActiveVarTrace; /* * The following structure describes an enumerative search in progress on an * array variable; this are invoked with options to the "array" command. */ typedef struct ArraySearch { int id; /* Integer id used to distinguish among * multiple concurrent searches for the same * array. */ struct Var *varPtr; /* Pointer to array variable that's being * searched. */ Tcl_HashSearch search; /* Info kept by the hash module about progress * through the array. */ Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to * be enumerated (it's leftover from the * Tcl_FirstHashEntry call or from an "array * anymore" command). NULL means must call * Tcl_NextHashEntry to get value to * return. */ struct ArraySearch *nextPtr;/* Next in list of all active searches for * this variable, or NULL if this is the last * one. */ } ArraySearch; /* * The structure below defines a variable, which associates a string name with * a Tcl_Obj value. These structures are kept in procedure call frames (for * local variables recognized by the compiler) or in the heap (for global * variables and any variable not known to the compiler). For each Var * structure in the heap, a hash table entry holds the variable name and a * pointer to the Var structure. */ typedef struct Var { union { Tcl_Obj *objPtr; /* The variable's object value. Used for * scalar variables and array elements. */ Tcl_HashTable *tablePtr;/* For array variables, this points to * information about the hash table used to * implement the associative array. Points to * ckalloc-ed data. */ struct Var *linkPtr; /* If this is a global variable being referred * to in a procedure, or a variable created by * "upvar", this field points to the * referenced variable's Var struct. */ } value; char *name; /* NULL if the variable is in a hashtable, * otherwise points to the variable's name. It * is used, e.g., by TclLookupVar and "info * locals". The storage for the characters of * the name is not owned by the Var and must * not be freed when freeing the Var. */ Namespace *nsPtr; /* Points to the namespace that contains this * variable or NULL if the variable is a local * variable in a Tcl procedure. */ Tcl_HashEntry *hPtr; /* If variable is in a hashtable, either the * hash table entry that refers to this * variable or NULL if the variable has been * detached from its hash table (e.g. an array * is deleted, but some of its elements are * still referred to in upvars). NULL if the * variable is not in a hashtable. This is * used to delete an variable from its * hashtable if it is no longer needed. */ int refCount; /* Counts number of active uses of this * variable, not including its entry in the * call frame or the hash table: 1 for each * additional variable whose linkPtr points * here, 1 for each nested trace active on * variable, and 1 if the variable is a * namespace variable. This record can't be * deleted until refCount becomes 0. */ VarTrace *tracePtr; /* First in list of all traces set for this * variable. */ ArraySearch *searchPtr; /* First in list of all searches active for * this variable, or NULL if none. */ int flags; /* Miscellaneous bits of information about * variable. See below for definitions. */ } Var; /* * Flag bits for variables. The first three (VAR_SCALAR, VAR_ARRAY, and * VAR_LINK) are mutually exclusive and give the "type" of the variable. * VAR_UNDEFINED is independent of the variable's type. * * VAR_SCALAR - 1 means this is a scalar variable and not an * array or link. The "objPtr" field points to * the variable's value, a Tcl object. * VAR_ARRAY - 1 means this is an array variable rather than * a scalar variable or link. The "tablePtr" * field points to the array's hashtable for its * elements. * VAR_LINK - 1 means this Var structure contains a pointer * to another Var structure that either has the * real value or is itself another VAR_LINK * pointer. Variables like this come about * through "upvar" and "global" commands, or * through references to variables in enclosing * namespaces. * VAR_UNDEFINED - 1 means that the variable is in the process of * being deleted. An undefined variable logically * does not exist and survives only while it has * a trace, or if it is a global variable * currently being used by some procedure. * VAR_IN_HASHTABLE - 1 means this variable is in a hashtable and * the Var structure is malloced. 0 if it is a * local variable that was assigned a slot in a * procedure frame by the compiler so the Var * storage is part of the call frame. * VAR_TRACE_ACTIVE - 1 means that trace processing is currently * underway for a read or write access, so new * read or write accesses should not cause trace * procedures to be called and the variable can't * be deleted. * VAR_ARRAY_ELEMENT - 1 means that this variable is an array * element, so it is not legal for it to be an * array itself (the VAR_ARRAY flag had better * not be set). * VAR_NAMESPACE_VAR - 1 means that this variable was declared as a * namespace variable. This flag ensures it * persists until its namespace is destroyed or * until the variable is unset; it will persist * even if it has not been initialized and is * marked undefined. The variable's refCount is * incremented to reflect the "reference" from * its namespace. * * The following additional flags are used with the CompiledLocal type defined * below: * * VAR_ARGUMENT - 1 means that this variable holds a procedure * argument. * VAR_TEMPORARY - 1 if the local variable is an anonymous * temporary variable. Temporaries have a NULL * name. * VAR_RESOLVED - 1 if name resolution has been done for this * variable. */ #define VAR_SCALAR 0x1 #define VAR_ARRAY 0x2 #define VAR_LINK 0x4 #define VAR_UNDEFINED 0x8 #define VAR_IN_HASHTABLE 0x10 #define VAR_TRACE_ACTIVE 0x20 #define VAR_ARRAY_ELEMENT 0x40 #define VAR_NAMESPACE_VAR 0x80 #define VAR_ARGUMENT 0x100 #define VAR_TEMPORARY 0x200 #define VAR_RESOLVED 0x400 #define VAR_IS_ARGS 0x800 /* * Macros to ensure that various flag bits are set properly for variables. * The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE void TclSetVarScalar(Var *varPtr); * MODULE_SCOPE void TclSetVarArray(Var *varPtr); * MODULE_SCOPE void TclSetVarLink(Var *varPtr); * MODULE_SCOPE void TclSetVarArrayElement(Var *varPtr); * MODULE_SCOPE void TclSetVarUndefined(Var *varPtr); * MODULE_SCOPE void TclClearVarUndefined(Var *varPtr); */ #define TclSetVarScalar(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_SCALAR #define TclSetVarArray(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_LINK)) | VAR_ARRAY |
︙ | ︙ | |||
553 554 555 556 557 558 559 | #define TclClearVarNamespaceVar(varPtr) \ (varPtr)->flags &= ~VAR_NAMESPACE_VAR /* * Macros to read various flag bits of variables. * The ANSI C "prototypes" for these macros are: * | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | < | | | | > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | < < | | | < | > > > | | | | | | | | | | | | | < | | > > | | | | < | | | | | | | | | | | < | | > > | | | < | | | | | | | | | | | | | > > | | | | | | | | | | < | | | > | | | | | | | | | | < | | < | | | > > > | | | | | < | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | > | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | > | | | < | | | | | | | | | | < | < | | | | | | | | | | | | | | | < | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | > | | | > > > | | | | | | | | | | > > > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | > > > > > | | | > | > | | | | | | | | | | | | | | | | | | < | | | | | < | | | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | | | | | > | | | | | | | | | | | | | | | | | | | | | < < | | | | | < | > > | | | | | | | < | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < > < > < | 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 | #define TclClearVarNamespaceVar(varPtr) \ (varPtr)->flags &= ~VAR_NAMESPACE_VAR /* * Macros to read various flag bits of variables. * The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE int TclIsVarScalar(Var *varPtr); * MODULE_SCOPE int TclIsVarLink(Var *varPtr); * MODULE_SCOPE int TclIsVarArray(Var *varPtr); * MODULE_SCOPE int TclIsVarUndefined(Var *varPtr); * MODULE_SCOPE int TclIsVarArrayElement(Var *varPtr); * MODULE_SCOPE int TclIsVarTemporary(Var *varPtr); * MODULE_SCOPE int TclIsVarArgument(Var *varPtr); * MODULE_SCOPE int TclIsVarResolved(Var *varPtr); */ #define TclIsVarScalar(varPtr) \ ((varPtr)->flags & VAR_SCALAR) #define TclIsVarLink(varPtr) \ ((varPtr)->flags & VAR_LINK) #define TclIsVarArray(varPtr) \ ((varPtr)->flags & VAR_ARRAY) #define TclIsVarUndefined(varPtr) \ ((varPtr)->flags & VAR_UNDEFINED) #define TclIsVarArrayElement(varPtr) \ ((varPtr)->flags & VAR_ARRAY_ELEMENT) #define TclIsVarNamespaceVar(varPtr) \ ((varPtr)->flags & VAR_NAMESPACE_VAR) #define TclIsVarTemporary(varPtr) \ ((varPtr)->flags & VAR_TEMPORARY) #define TclIsVarArgument(varPtr) \ ((varPtr)->flags & VAR_ARGUMENT) #define TclIsVarResolved(varPtr) \ ((varPtr)->flags & VAR_RESOLVED) #define TclIsVarTraceActive(varPtr) \ ((varPtr)->flags & VAR_TRACE_ACTIVE) #define TclIsVarUntraced(varPtr) \ ((varPtr)->tracePtr == NULL) /* * Macros for direct variable access by TEBC */ #define TclIsVarDirectReadable(varPtr) \ (TclIsVarScalar(varPtr) \ && !TclIsVarUndefined(varPtr) \ && TclIsVarUntraced(varPtr)) #define TclIsVarDirectWritable(varPtr) \ ( !(((varPtr)->flags & VAR_IN_HASHTABLE) \ && ((varPtr)->hPtr == NULL)) \ && TclIsVarUntraced(varPtr) \ && (TclIsVarScalar(varPtr) \ || TclIsVarUndefined(varPtr))) /* *---------------------------------------------------------------- * Data structures related to procedures. These are used primarily in * tclProc.c, tclCompile.c, and tclExecute.c. *---------------------------------------------------------------- */ /* * Forward declaration to prevent an error when the forward reference to * Command is encountered in the Proc and ImportRef types declared below. */ struct Command; /* * The variable-length structure below describes a local variable of a * procedure that was recognized by the compiler. These variables have a name, * an element in the array of compiler-assigned local variables in the * procedure's call frame, and various other items of information. If the * local variable is a formal argument, it may also have a default value. The * compiler can't recognize local variables whose names are expressions (these * names are only known at runtime when the expressions are evaluated) or * local variables that are created as a result of an "upvar" or "uplevel" * command. These other local variables are kept separately in a hash table in * the call frame. */ typedef struct CompiledLocal { struct CompiledLocal *nextPtr; /* Next compiler-recognized local variable for * this procedure, or NULL if this is the last * local. */ int nameLength; /* The number of characters in local * variable's name. Used to speed up variable * lookups. */ int frameIndex; /* Index in the array of compiler-assigned * variables in the procedure call frame. */ int flags; /* Flag bits for the local variable. Same as * the flags for the Var structure above, * although only VAR_SCALAR, VAR_ARRAY, * VAR_LINK, VAR_ARGUMENT, VAR_TEMPORARY, and * VAR_RESOLVED make sense. */ Tcl_Obj *defValuePtr; /* Pointer to the default value of an * argument, if any. NULL if not an argument * or, if an argument, no default value. */ Tcl_ResolvedVarInfo *resolveInfo; /* Customized variable resolution info * supplied by the Tcl_ResolveCompiledVarProc * associated with a namespace. Each variable * is marked by a unique ClientData tag during * compilation, and that same tag is used to * find the variable at runtime. */ char name[4]; /* Name of the local variable starts here. If * the name is NULL, this will just be '\0'. * The actual size of this field will be large * enough to hold the name. MUST BE THE LAST * FIELD IN THE STRUCTURE! */ } CompiledLocal; /* * The structure below defines a command procedure, which consists of a * collection of Tcl commands plus information about arguments and other local * variables recognized at compile time. */ typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ int refCount; /* Reference count: 1 if still present in * command table plus 1 for each call to the * procedure that is currently active. This * structure can be freed when refCount * becomes zero. */ struct Command *cmdPtr; /* Points to the Command structure for this * procedure. This is used to get the * namespace in which to execute the * procedure. */ Tcl_Obj *bodyPtr; /* Points to the ByteCode object for * procedure's body command. */ int numArgs; /* Number of formal parameters. */ int numCompiledLocals; /* Count of local variables recognized by the * compiler including arguments and * temporaries. */ CompiledLocal *firstLocalPtr; /* Pointer to first of the procedure's * compiler-allocated local variables, or NULL * if none. The first numArgs entries in this * list describe the procedure's formal * arguments. */ CompiledLocal *lastLocalPtr;/* Pointer to the last allocated local * variable or NULL if none. This has frame * index (numCompiledLocals-1). */ } Proc; /* * The structure below defines a command trace. This is used to allow Tcl * clients to find out whenever a command is about to be executed. */ typedef struct Trace { int level; /* Only trace commands at nesting level less * than or equal to this. */ Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ ClientData clientData; /* Arbitrary value to pass to proc. */ 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. */ int reverseScan; /* Boolean set true when traces are scanning * in reverse order. */ } ActiveInterpTrace; /* * Flag values designating types of execution traces. See tclTrace.c for * related flag values. * * TCL_TRACE_ENTER_EXEC - triggers enter/enterstep traces. * - passed to Tcl_CreateObjTrace to set up * "enterstep" traces. * TCL_TRACE_LEAVE_EXEC - triggers leave/leavestep traces. * - passed to Tcl_CreateObjTrace to set up * "leavestep" traces. * */ #define TCL_TRACE_ENTER_EXEC 1 #define TCL_TRACE_LEAVE_EXEC 2 /* * 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. */ typedef struct AssocData { Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */ ClientData clientData; /* Value to pass to proc. */ } AssocData; /* * The structure below defines a call frame. A call frame defines a naming * context for a procedure call: its local naming scope (for local variables) * and its global naming scope (a namespace, perhaps the global :: namespace). * A call frame can also define the naming context for a namespace eval or * namespace inscope command: the namespace in which the command's code should * execute. The Tcl_CallFrame structures exist only while procedures or * namespace eval/inscope's are being executed, and provide a kind of Tcl call * stack. * * WARNING!! The structure definition must be kept consistent with the * Tcl_CallFrame structure in tcl.h. If you change one, change the other. */ typedef struct CallFrame { Namespace *nsPtr; /* Points to the namespace used to resolve * commands and global variables. */ int isProcCallFrame; /* If 0, the frame was pushed to execute a * namespace command and var references are * treated as references to namespace vars; * varTablePtr and compiledLocals are ignored. * If FRAME_IS_PROC is set, the frame was * pushed to execute a Tcl procedure and may * have local vars. */ int objc; /* This and objv below describe the arguments * for this procedure call. */ Tcl_Obj *CONST *objv; /* Array of argument objects. */ struct CallFrame *callerPtr; /* Value of interp->framePtr when this * procedure was invoked (i.e. next higher in * stack of all active procedures). */ struct CallFrame *callerVarPtr; /* Value of interp->varFramePtr when this * procedure was invoked (i.e. determines * variable scoping within caller). Same as * callerPtr unless an "uplevel" command or * something equivalent was active in the * caller). */ int level; /* Level of this procedure, for "uplevel" * purposes (i.e. corresponds to nesting of * callerVarPtr's, not callerPtr's). 1 for * outermost procedure, 0 for top-level. */ Proc *procPtr; /* Points to the structure defining the called * procedure. Used to get information such as * the number of compiled local variables * (local variables assigned entries ["slots"] * in the compiledLocals array below). */ Tcl_HashTable *varTablePtr; /* Hash table containing local variables not * recognized by the compiler, or created at * execution time through, e.g., upvar. * Initially NULL and created if needed. */ int numCompiledLocals; /* Count of local variables recognized by the * compiler including arguments. */ Var* compiledLocals; /* Points to the array of local variables * recognized by the compiler. The compiler * emits code that refers to these variables * using an index into this array. */ } CallFrame; #define FRAME_IS_PROC 0x1 /* *---------------------------------------------------------------- * Data structures and procedures related to TclHandles, which are a very * lightweight method of preserving enough information to determine if an * arbitrary malloc'd block has been deleted. *---------------------------------------------------------------- */ typedef VOID **TclHandle; /* *---------------------------------------------------------------- * Data structures related to expressions. These are used only in tclExpr.c. *---------------------------------------------------------------- */ /* * The data structure below defines a math function (e.g. sin or hypot) for * use in Tcl expressions. */ #define MAX_MATH_ARGS 5 typedef struct MathFunc { int builtinFuncIndex; /* If this is a builtin math function, its * index in the array of builtin functions. * (tclCompilation.h lists these indices.) * The value is -1 if this is a new function * defined by Tcl_CreateMathFunc. The value is * also -1 if a builtin function is replaced * by a Tcl_CreateMathFunc call. */ int numArgs; /* Number of arguments for function. */ Tcl_ValueType argTypes[MAX_MATH_ARGS]; /* Acceptable types for each argument. */ Tcl_MathProc *proc; /* Procedure that implements this function. * NULL if isBuiltinFunc is 1. */ ClientData clientData; /* Additional argument to pass to the function * when invoking it. NULL if isBuiltinFunc is * 1. */ } MathFunc; /* * These are a thin layer over TclpThreadKeyDataGet and TclpThreadKeyDataSet * when threads are used, or an emulation if there are no threads. These are * really internal and Tcl clients should use Tcl_GetThreadData. */ MODULE_SCOPE VOID * TclThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr); MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr, VOID *data); /* * This is a convenience macro used to initialize a thread local storage ptr. */ #define TCL_TSD_INIT(keyPtr) \ (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) /* *---------------------------------------------------------------- * Data structures related to bytecode compilation and execution. These are * used primarily in tclCompile.c, tclExecute.c, and tclBasic.c. *---------------------------------------------------------------- */ /* * Forward declaration to prevent errors when the forward references to * Tcl_Parse and CompileEnv are encountered in the procedure type CompileProc * declared below. */ struct CompileEnv; /* * The type of procedures called by the Tcl bytecode compiler to compile * commands. Pointers to these procedures are kept in the Command structure * describing each command. The integer value returned by a CompileProc must * be one of the following: * * TCL_OK Compilation completed normally. * TCL_ERROR Compilation could not be completed. This can be just a * judgment by the CompileProc that the command is too * complex to compile effectively, or it can indicate * that in the current state of the interp, the command * would raise an error. The bytecode compiler will not * do any error reporting at compiler time. Error * reporting is deferred until the actual runtime, * because by then changes in the interp state may allow * the command to be successfully evaluated. * TCL_OUT_LINE_COMPILE A source-compatible alias for TCL_ERROR, kept for the * sake of old code only. */ #define TCL_OUT_LINE_COMPILE TCL_ERROR typedef int (CompileProc) (Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *compEnvPtr); /* * The type of procedure called from the compilation hook point in * SetByteCodeFromAny. */ typedef int (CompileHookProc) (Tcl_Interp *interp, struct CompileEnv *compEnvPtr, ClientData clientData); /* * The data structure defining the execution environment for ByteCode's. * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation * stack that holds command operands and results. The stack grows towards * increasing addresses. The "stackTop" member is cached by TclExecuteByteCode * in a local variable: it must be set before calling TclExecuteByteCode and * will be restored by TclExecuteByteCode before it returns. */ typedef struct ExecEnv { Tcl_Obj **stackPtr; /* Points to the first item in the evaluation * stack on the heap. */ Tcl_Obj **tosPtr; /* Points to current top of stack; * (stackPtr-1) when the stack is empty. */ Tcl_Obj **endPtr; /* Points to last usable item in stack. */ Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */ } 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 that * refer to the literal. Each distinct literal has one LiteralEntry entry in * the LiteralTable. A literal table is a specialized hash table that is * indexed by the literal's string representation, which may contain null * characters. * * Note that we reduce the space needed for literals by sharing literal * objects both within a ByteCode (each ByteCode contains a local * LiteralTable) and across all an interpreter's ByteCodes (with the * interpreter's global LiteralTable). */ typedef struct LiteralEntry { struct LiteralEntry *nextPtr; /* Points to next entry in this hash bucket or * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ int refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to * 0. If in a local literal table, -1. */ Namespace *nsPtr; /* Namespace in which this literal is used. We * try to avoid sharing literal non-FQ command * names among different namespaces to reduce * shimmering. */ } LiteralEntry; typedef struct LiteralTable { LiteralEntry **buckets; /* Pointer to bucket array. Each element * points to first entry in bucket's hash * chain, or NULL. */ LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables to avoid * mallocs and frees. */ int numBuckets; /* Total number of buckets allocated at * **buckets. */ int numEntries; /* Total number of entries present in * table. */ int rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ int mask; /* Mask value used in hashing function. */ } LiteralTable; /* * The following structure defines for each Tcl interpreter various * statistics-related information about the bytecode compiler and * interpreter's operation in that interpreter. */ #ifdef TCL_COMPILE_STATS typedef struct ByteCodeStats { long numExecutions; /* Number of ByteCodes executed. */ long numCompilations; /* Number of ByteCodes created. */ long numByteCodesFreed; /* Number of ByteCodes destroyed. */ long instructionCount[256]; /* Number of times each instruction was * executed. */ double totalSrcBytes; /* Total source bytes ever compiled. */ double totalByteCodeBytes; /* Total bytes for all ByteCodes. */ double currentSrcBytes; /* Src bytes for all current ByteCodes. */ double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */ long srcCount[32]; /* Source size distribution: # of srcs of * size [2**(n-1)..2**n), n in [0..32). */ long byteCodeCount[32]; /* ByteCode size distribution. */ long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ double currentInstBytes; /* Instruction bytes-current ByteCodes. */ double currentLitBytes; /* Current literal bytes. */ double currentExceptBytes; /* Current exception table bytes. */ double currentAuxBytes; /* Current auxiliary information bytes. */ double currentCmdMapBytes; /* Current src<->code map bytes. */ long numLiteralsCreated; /* Total literal objects ever compiled. */ double totalLitStringBytes; /* Total string bytes in all literals. */ double currentLitStringBytes; /* String bytes in current literals. */ long literalCount[32]; /* Distribution of literal string sizes. */ } ByteCodeStats; #endif /* TCL_COMPILE_STATS */ /* *---------------------------------------------------------------- * Data structures related to commands. *---------------------------------------------------------------- */ /* * An imported command is created in an namespace when it imports a "real" * command from another namespace. An imported command has a Command structure * that points (via its ClientData value) to the "real" Command structure in * the source namespace's command table. The real command records all the * imported commands that refer to it in a list of ImportRef structures so * that they can be deleted when the real command is deleted. */ typedef struct ImportRef { struct Command *importedCmdPtr; /* Points to the imported command created in * an importing namespace; this command * redirects its invocations to the "real" * command. */ struct ImportRef *nextPtr; /* Next element on the linked list of imported * commands that refer to the "real" command. * The real command deletes these imported * commands on this list when it is * deleted. */ } ImportRef; /* * Data structure used as the ClientData of imported commands: commands * created in an namespace when it imports a "real" command from another * namespace. */ typedef struct ImportedCmdData { struct Command *realCmdPtr; /* "Real" command that this imported command * refers to. */ struct Command *selfPtr; /* Pointer to this imported command. Needed * only when deleting it in order to remove it * from the real command's linked list of * imported commands that refer to it. */ } ImportedCmdData; /* * A Command structure exists for each command in a namespace. The Tcl_Command * opaque type actually refers to these structures. */ typedef struct Command { Tcl_HashEntry *hPtr; /* Pointer to the hash table entry that refers * to this command. The hash table is either a * namespace's command table or an * interpreter's hidden command table. This * pointer is used to get a command's name * from its Tcl_Command handle. NULL means * that the hash table entry has been removed * already (this can happen if deleteProc * causes the command to be deleted or * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ int refCount; /* 1 if in command hashtable plus 1 for each * reference from a CmdName Tcl object * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ int cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL * if no compile proc exists for command. */ Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */ ClientData objClientData; /* Arbitrary value passed to object proc. */ Tcl_CmdProc *proc; /* String-based command procedure. */ ClientData clientData; /* Arbitrary value passed to string proc. */ Tcl_CmdDeleteProc *deleteProc; /* Procedure invoked when deleting command to, * e.g., free all client data. */ ClientData deleteData; /* Arbitrary value passed to deleteProc. */ int flags; /* Miscellaneous bits of information about * command. See below for definitions. */ ImportRef *importRefPtr; /* List of each imported Command created in * another namespace when this command is * imported. These imported commands redirect * invocations back to this command. The list * is used to remove all those imported * commands when deleting this "real" * command. */ CommandTrace *tracePtr; /* First in list of all traces set for this * command. */ } Command; /* * Flag bits for commands. * * CMD_IS_DELETED - Means that the command is in the process 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. *---------------------------------------------------------------- */ /* * The interpreter keeps a linked list of name resolution schemes. The scheme * for a namespace is consulted first, followed by the list of schemes in an * interpreter, followed by the default name resolution in Tcl. Schemes are * added/removed from the interpreter's list by calling Tcl_AddInterpResolver * and Tcl_RemoveInterpResolver. */ typedef struct ResolverScheme { char *name; /* Name identifying this scheme. */ Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name * resolution. */ Tcl_ResolveVarProc *varResProc; /* Procedure handling variable name resolution * for variables that can only be handled at * runtime. */ Tcl_ResolveCompiledVarProc *compiledVarResProc; /* Procedure handling variable name resolution * at compile time. */ struct ResolverScheme *nextPtr; /* Pointer to next record in linked list. */ } ResolverScheme; /* * Forward declaration of the TIP#143 limit handler structure. */ typedef struct LimitHandler LimitHandler; /* *---------------------------------------------------------------- * This structure defines an interpreter, which is a collection of commands * plus other state information related to interpreting commands, such as * variable storage. Primary responsibility for this data structure is in * tclBasic.c, but almost every Tcl source file uses something in here. *---------------------------------------------------------------- */ typedef struct Interp { /* * Note: the first three fields must match exactly the fields in a * Tcl_Interp struct (see tcl.h). If you change one, be sure to change the * other. * * The interpreter's result is held in both the string and the * objResultPtr fields. These fields hold, respectively, the result's * string or object value. The interpreter's result is always in the * result field if that is non-empty, otherwise it is in objResultPtr. * The two fields are kept consistent unless some C code sets * interp->result directly. Programs should not access result and * objResultPtr directly; instead, they should always get and set the * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, and * Tcl_GetStringResult. See the SetResult man page for details. */ char *result; /* If the last command returned a string * result, this points to it. Should not be * accessed directly; see comment above. */ Tcl_FreeProc *freeProc; /* Zero means a string result is statically * allocated. TCL_DYNAMIC means string result * was allocated with ckalloc and should be * freed with ckfree. Other values give * address of procedure to invoke to free the * string result. Tcl_Eval must free it before * executing next command. */ int errorLine; /* When TCL_ERROR is returned, this gives the * line number in the command where the error * occurred (1 means first line). */ struct TclStubs *stubTable; /* Pointer to the exported Tcl stub table. On * previous versions of Tcl this is a pointer * to the objResultPtr or a pointer to a * buckets array in a hash table. We therefore * have to do some careful checking before we * can use this. */ TclHandle handle; /* Handle used to keep track of when this * interp is deleted. */ Namespace *globalNsPtr; /* The interpreter's global namespace. */ Tcl_HashTable *hiddenCmdTablePtr; /* Hash table used by tclBasic.c to keep track * of hidden commands on a per-interp * basis. */ ClientData interpInfo; /* Information used by tclInterp.c to keep * track of master/slave interps on a * per-interp basis. */ Tcl_HashTable mathFuncTable;/* Contains all the math functions currently * defined for the interpreter. Indexed by * strings (function names); values have type * (MathFunc *). */ /* * Information related to procedures and variables. See tclProc.c and * tclVar.c for usage. */ int numLevels; /* Keeps track of how many nested calls to * Tcl_Eval are in progress for this * interpreter. It's used to delay deletion of * the table until all Tcl_Eval invocations * are completed. */ int maxNestingDepth; /* If numLevels exceeds this value then Tcl * assumes that infinite recursion has * occurred and it generates an error. */ CallFrame *framePtr; /* Points to top-most in stack of all nested * 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; /* [return -code] parameter */ char *unused3; /* No longer used (was errorInfo) */ char *unused4; /* No longer used (was errorCode) */ /* * Information used by Tcl_AppendResult to keep track of partial results. * See Tcl_AppendResult code for details. */ char *appendResult; /* Storage space for results generated by * Tcl_AppendResult. Ckalloc-ed. NULL means * not yet allocated. */ int appendAvl; /* Total amount of space available at * partialResult. */ int appendUsed; /* Number of non-null bytes currently stored * at partialResult. */ /* * Information about packages. Used only in tclPkg.c. */ Tcl_HashTable packageTable; /* Describes all of the packages loaded in or * available to this interpreter. Keys are * package names, values are (Package *) * pointers. */ char *packageUnknown; /* Command to invoke during "package require" * commands for packages that aren't described * in packageTable. Ckalloc'ed, may be * NULL. */ /* * Miscellaneous information: */ int cmdCount; /* Total number of times a command procedure * has been called for this interpreter. */ int evalFlags; /* Flags to control next call to Tcl_Eval. * Normally zero, but may be set before * calling Tcl_Eval. See below for valid * values. */ int unused1; /* No longer used (was termOffset) */ LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl * objects holding literals of scripts * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ int compileEpoch; /* Holds the current "compilation epoch" for * this interpreter. This is incremented to * invalidate existing ByteCodes when, e.g., a * command with a compile procedure is * redefined. */ Proc *compiledProcPtr; /* If a procedure is being compiled, a pointer * to its Proc structure; otherwise, this is * NULL. Set by ObjInterpProc in tclProc.c and * used by tclCompile.c to process local * variables appropriately. */ ResolverScheme *resolverPtr; /* Linked list of name resolution schemes * added to this interpreter. Schemes are * added and removed by calling * Tcl_AddInterpResolvers and * Tcl_RemoveInterpResolver respectively. */ Tcl_Obj *scriptFile; /* NULL means there is no nested source * command active; otherwise this points to * pathPtr of the file being sourced. */ int flags; /* Various flag bits. See below. */ long randSeed; /* Seed used for rand() function. */ Trace *tracePtr; /* List of traces for this interpreter. */ Tcl_HashTable *assocData; /* Hash table for associating data with this * interpreter. Cleaned up when this * interpreter is deleted. */ struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode * execution. Contains a pointer to the Tcl * evaluation stack. */ Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ char resultSpace[TCL_RESULT_SIZE+1]; /* Static space holding small results. */ Tcl_Obj *objResultPtr; /* If the last command returned an object * 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 */ /* Fields used to manage extensible return options (TIP 90) */ Tcl_Obj *returnOpts; /* A dictionary holding the options to the * last [return] command */ Tcl_Obj *errorInfo; /* errorInfo value (now as a Tcl_Obj) */ Tcl_Obj *eiVar; /* cached ref to ::errorInfo variable */ Tcl_Obj *errorCode; /* errorCode value (now as a Tcl_Obj) */ Tcl_Obj *ecVar; /* cached ref to ::errorInfo variable */ int returnLevel; /* [return -level] parameter */ /* * Resource limiting framework support (TIP#143). */ struct { int active; /* Flag values defining which limits have been * set. */ int granularityTicker; /* Counter used to determine how often to * check the limits. */ int exceeded; /* Which limits have been exceeded, described * as flag values the same as the 'active' * field. */ int cmdCount; /* Limit for how many commands to execute in * the interpreter. */ LimitHandler *cmdHandlers; /* Handlers to execute when the limit is * reached. */ int cmdGranularity; /* Mod factor used to determine how often to * evaluate the limit check. */ Tcl_Time time; /* Time limit for execution within the * interpreter. */ LimitHandler *timeHandlers; /* Handlers to execute when the limit is * reached. */ int timeGranularity; /* Mod factor used to determine how often to * evaluate the limit check. */ Tcl_TimerToken timeEvent; /* Handle for a timer callback that will occur * when the time-limit is exceeded. */ Tcl_HashTable callbacks;/* Mapping from (interp,type) pair to data * used to install a limit handler callback to * run in _this_ interp when the limit is * exceeded. */ } limit; /* * Information for improved default error generation from ensembles * (TIP#112). */ struct { Tcl_Obj * CONST *sourceObjs; /* What arguments were actually input into the * *root* ensemble command? (Nested ensembles * don't rewrite this.) NULL if we're not * processing an ensemble. */ int numRemovedObjs; /* How many arguments have been stripped off * because of ensemble processing. */ int numInsertedObjs; /* How many of the current arguments were * inserted by an ensemble. */ } ensembleRewrite; /* * TIP #219 ... Global info for the I/O system ... */ Tcl_Obj* chanMsg; /* Error message set by channel drivers, for * the propagation of arbitrary Tcl errors. * This information, if present (chanMsg not * NULL), takes precedence over a posix error * code returned by a channel operation. */ /* * Statistical information about the bytecode compiler and interpreter's * operation. */ #ifdef TCL_COMPILE_STATS ByteCodeStats stats; /* Holds compilation and execution statistics * for this interpreter. */ #endif /* TCL_COMPILE_STATS */ } Interp; /* * General list of interpreters. Doubly linked for easier removal of items * deep in the list. */ typedef struct InterpList { Interp* interpPtr; struct InterpList* prevPtr; struct InterpList* nextPtr; } InterpList; /* * Macros for splicing into and out of doubly linked lists. They assume * existence of struct items 'prevPtr' and 'nextPtr'. * * a = element to add or remove. * b = list head. * * TclSpliceIn adds to the head of the list. */ #define TclSpliceIn(a,b) \ (a)->nextPtr = (b); \ if ((b) != NULL) { \ (b)->prevPtr = (a); \ } \ (a)->prevPtr = NULL, (b) = (a); #define TclSpliceOut(a,b) \ if ((a)->prevPtr != NULL) { \ (a)->prevPtr->nextPtr = (a)->nextPtr; \ } else { \ (b) = (a)->nextPtr; \ } \ if ((a)->nextPtr != NULL) { \ (a)->nextPtr->prevPtr = (a)->prevPtr; \ } /* * EvalFlag bits for Interp structures: * * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with a * code other than TCL_OK or TCL_ERROR; 0 means codes * other than these should be turned into errors. */ #define TCL_ALLOW_EXCEPTIONS 4 /* * Flag bits for Interp structures: * * DELETED: Non-zero means the interpreter has been deleted: * don't process any more commands for it, and destroy * the structure as soon as all nested invocations of * Tcl_Eval are done. * ERR_ALREADY_LOGGED: Non-zero means information has already been logged in * iPtr->errorInfo for the current Tcl_Eval instance, so * Tcl_Eval needn't log it (used to implement the "error * message log" command). * DONT_COMPILE_CMDS_INLINE: Non-zero means that the bytecode compiler should * not compile any commands into an inline sequence of * instructions. This is set 1, for example, when command * traces are requested. * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the interp * has not be initialized. This is set 1 when we first * use the rand() or srand() functions. * SAFE_INTERP: Non zero means that the current interp is a safe * interp (i.e. it has only the safe commands installed, * less priviledge than a regular interp). * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently * active; so no further trace callbacks should be * invoked. * INTERP_ALTERNATE_WRONG_ARGS: Used for listing second and subsequent forms * of the wrong-num-args string in Tcl_WrongNumArgs. * Makes it append instead of replacing and uses * different intermediate text. * * WARNING: For the sake of some extensions that have made use of former * internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS) * or 8 (formerly ERROR_CODE_SET). */ #define DELETED 1 #define ERR_ALREADY_LOGGED 4 #define DONT_COMPILE_CMDS_INLINE 0x20 #define RAND_SEED_INITIALIZED 0x40 #define SAFE_INTERP 0x80 #define INTERP_TRACE_IN_PROGRESS 0x200 #define INTERP_ALTERNATE_WRONG_ARGS 0x400 /* * Maximum number of levels of nesting permitted in Tcl commands (used to * catch infinite recursion). */ #define MAX_NESTING_DEPTH 1000 /* * TIP#143 limit handler internal representation. */ struct LimitHandler { int flags; /* The state of this particular handler. */ Tcl_LimitHandlerProc *handlerProc; /* The handler callback. */ ClientData clientData; /* Opaque argument to the handler callback. */ Tcl_LimitHandlerDeleteProc *deleteProc; /* How to delete the clientData */ LimitHandler *prevPtr; /* Previous item in linked list of handlers */ LimitHandler *nextPtr; /* Next item in linked list of handlers */ }; /* * Values for the LimitHandler flags field. * LIMIT_HANDLER_ACTIVE - Whether the handler is currently being * processed; handlers are never to be entered reentrantly. * LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This * should not normally be observed because when a handler is * deleted it is also spliced out of the list of handlers, but * even so we will be careful. */ #define LIMIT_HANDLER_ACTIVE 0x01 #define LIMIT_HANDLER_DELETED 0x02 /* * The macro below is used to modify a "char" value (e.g. by casting it to an * unsigned character) so that it can be used safely with macros such as * isspace. */ #define UCHAR(c) ((unsigned char) (c)) /* * This macro is used to determine the offset needed to safely allocate any * data structure in memory. Given a starting offset or size, it "rounds up" * or "aligns" the offset to the next 8-byte boundary so that any data * structure can be placed at the resulting offset without fear of an * alignment error. * * WARNING!! DO NOT USE THIS MACRO TO ALIGN POINTERS: it will produce the * wrong result on platforms that allocate addresses that are divisible by 4 * or 2. Only use it for offsets or sizes. * * This macro is only used by tclCompile.c in the core (Bug 926445). It * however not be made file static, as extensions that touch bytecodes * (notably tbcload) require it. */ #define TCL_ALIGN(x) (((int)(x) + 7) & ~7) /* * The following enum values are used to specify the runtime platform setting * of the tclPlatform variable. */ typedef enum { TCL_PLATFORM_UNIX = 0, /* Any Unix-like OS. */ TCL_PLATFORM_WINDOWS = 2 /* Any Microsoft Windows OS. */ } TclPlatformType; /* * The following enum values are used to indicate the translation of a Tcl * channel. Declared here so that each platform can define * TCL_PLATFORM_TRANSLATION to the native translation on that platform */ typedef enum TclEolTranslation { TCL_TRANSLATE_AUTO, /* Eol == \r, \n and \r\n. */ TCL_TRANSLATE_CR, /* Eol == \r. */ TCL_TRANSLATE_LF, /* Eol == \n. */ TCL_TRANSLATE_CRLF /* Eol == \r\n. */ } TclEolTranslation; /* * Flags for TclInvoke: * * TCL_INVOKE_HIDDEN Invoke a hidden command; if not set, invokes * an exposed command. * TCL_INVOKE_NO_UNKNOWN If set, "unknown" is not invoked if the * command to be invoked is not found. Only has * an effect if invoking an exposed command, * i.e. if TCL_INVOKE_HIDDEN is not also set. * TCL_INVOKE_NO_TRACEBACK Does not record traceback information if the * invoked command returns an error. Used if the * caller plans on recording its own traceback * information. */ #define TCL_INVOKE_HIDDEN (1<<0) #define TCL_INVOKE_NO_UNKNOWN (1<<1) #define TCL_INVOKE_NO_TRACEBACK (1<<2) /* * The structure used as the internal representation of Tcl list objects. This * struct is grown (reallocated and copied) as necessary to hold all the * list's element pointers. The struct might contain more slots than currently * used to hold all element pointers. This is done to make append operations * faster. */ typedef struct List { int refCount; int maxElemCount; /* Total number of element array slots. */ int elemCount; /* Current number of list elements. */ int canonicalFlag; /* Set if the string representation was * derived from the list representation. May * be ignored if there is no string rep at * all.*/ Tcl_Obj *elements; /* First list element; the struct is grown to * accomodate all elements. */ } List; /* * Macro used to get the elements of a list object - do NOT forget to verify * that it is of list type before using! */ #define TclListObjGetElements(listPtr, objc, objv) \ { \ List *listRepPtr = \ (List *) (listPtr)->internalRep.twoPtrValue.ptr1;\ (objc) = listRepPtr->elemCount;\ (objv) = &listRepPtr->elements;\ } /* * Flag values for TclTraceDictPath(). * * DICT_PATH_READ indicates that all entries on the path must exist but no * updates will be needed. * * DICT_PATH_UPDATE indicates that we are going to be doing an update at the * tip of the path, so duplication of shared objects should be done along the * way. * * DICT_PATH_EXISTS indicates that we are performing an existance test and a * lookup failure should therefore not be an error. If (and only if) this flag * is set, TclTraceDictPath() will return the special value * DICT_PATH_NON_EXISTENT if the path is not traceable. * * DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to be set) * indicates that we are to create non-existant dictionaries on the path. */ #define DICT_PATH_READ 0 #define DICT_PATH_UPDATE 1 #define DICT_PATH_EXISTS 2 #define DICT_PATH_CREATE 5 #define DICT_PATH_NON_EXISTENT ((Tcl_Obj *) (void *) 1) /* *---------------------------------------------------------------- * Data structures related to the filesystem internals *---------------------------------------------------------------- */ /* * The version_2 filesystem is private to Tcl. As and when these changes have * been thoroughly tested and investigated a new public filesystem interface * will be released. The aim is more versatile virtual filesystem interfaces, * more efficiency in 'path' manipulation and usage, and cleaner filesystem * code internally. */ #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) typedef ClientData (TclFSGetCwdProc2) (ClientData clientData); /* * The following types are used for getting and storing platform-specific file * attributes in tclFCmd.c and the various platform-versions of that file. * This is done to have as much common code as possible in the file attributes * code. For more information about the callbacks, see TclFileAttrsCmd in * tclFCmd.c. */ typedef int (TclGetFileAttrProc) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attrObjPtrPtr); typedef int (TclSetFileAttrProc) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attrObjPtr); typedef struct TclFileAttrProcs { TclGetFileAttrProc *getProc;/* The procedure for getting attrs. */ TclSetFileAttrProc *setProc;/* The procedure for setting attrs. */ } TclFileAttrProcs; /* * Opaque handle used in pipeline routines to encapsulate platform-dependent * state. */ typedef struct TclFile_ *TclFile; /* * The "globParameters" argument of the function TclGlob is an or'ed * combination of the following values: */ #define TCL_GLOBMODE_NO_COMPLAIN 1 #define TCL_GLOBMODE_JOIN 2 #define TCL_GLOBMODE_DIR 4 #define TCL_GLOBMODE_TAILS 8 typedef enum Tcl_PathPart { TCL_PATH_DIRNAME, TCL_PATH_TAIL, TCL_PATH_EXTENSION, TCL_PATH_ROOT } Tcl_PathPart; /* *---------------------------------------------------------------- * Data structures related to obsolete filesystem hooks *---------------------------------------------------------------- */ typedef int (TclStatProc_) (CONST char *path, struct stat *buf); typedef int (TclAccessProc_) (CONST char *path, int mode); typedef Tcl_Channel (TclOpenFileChannelProc_) (Tcl_Interp *interp, CONST char *fileName, CONST char *modeString, int permissions); /* *---------------------------------------------------------------- * Data structures related to procedures *---------------------------------------------------------------- */ typedef Tcl_CmdProc *TclCmdProcType; typedef Tcl_ObjCmdProc *TclObjCmdProcType; /* *---------------------------------------------------------------- * Data structures for process-global values. *---------------------------------------------------------------- */ typedef void (TclInitProcessGlobalValueProc) (char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr); /* * A ProcessGlobalValue struct exists for each internal value in Tcl that is * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of * the value, and the master is kept as a counted string, with epoch and mutex * control. Each ProcessGlobalValue struct should be a static variable in some * file. */ typedef struct ProcessGlobalValue { int epoch; /* Epoch counter to detect changes in the * master value. */ int numBytes; /* Length of the master string. */ char *value; /* The master string value. */ Tcl_Encoding encoding; /* system encoding when master string was * initialized. */ TclInitProcessGlobalValueProc *proc; /* A procedure to initialize the master string * copy when a "get" request comes in before * any "set" request has been received. */ Tcl_Mutex mutex; /* Enforce orderly access from multiple * threads. */ Tcl_ThreadDataKey key; /* Key for per-thread data holding the * (Tcl_Obj) copy for each thread. */ } ProcessGlobalValue; /* *---------------------------------------------------------------------- * Flags for TclParseNumber *---------------------------------------------------------------------- */ #define TCL_PARSE_DECIMAL_ONLY 1 /* Leading zero doesn't denote octal or hex */ #define TCL_PARSE_OCTAL_ONLY 2 /* Parse octal even without prefix */ #define TCL_PARSE_HEXADECIMAL_ONLY 4 /* Parse hexadecimal even without prefix */ #define TCL_PARSE_INTEGER_ONLY 8 /* Disable floating point parsing */ #define TCL_PARSE_SCAN_PREFIXES 16 /* Use [scan] rules dealing with 0? prefixes */ /* *---------------------------------------------------------------------- * Type values TclGetNumberFromObj *---------------------------------------------------------------------- */ #define TCL_NUMBER_LONG 1 #define TCL_NUMBER_WIDE 2 #define TCL_NUMBER_BIG 3 #define TCL_NUMBER_DOUBLE 4 #define TCL_NUMBER_NAN 5 /* *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. *---------------------------------------------------------------- */ MODULE_SCOPE char * tclNativeExecutableName; MODULE_SCOPE int tclFindExecutableSearchDone; MODULE_SCOPE char * tclMemDumpFileName; MODULE_SCOPE TclPlatformType tclPlatform; MODULE_SCOPE Tcl_NotifierProcs tclOriginalNotifier; /* * TIP #233 (Virtualized Time) * Data for the time hooks, if any. */ MODULE_SCOPE Tcl_GetTimeProc* tclGetTimeProcPtr; MODULE_SCOPE Tcl_ScaleTimeProc* tclScaleTimeProcPtr; MODULE_SCOPE ClientData tclTimeClientData; /* * Variables denoting the Tcl object types defined in the core. */ MODULE_SCOPE Tcl_ObjType tclBignumType; MODULE_SCOPE Tcl_ObjType tclBooleanType; MODULE_SCOPE Tcl_ObjType tclByteArrayType; MODULE_SCOPE Tcl_ObjType tclByteCodeType; MODULE_SCOPE Tcl_ObjType tclDoubleType; MODULE_SCOPE Tcl_ObjType tclEndOffsetType; MODULE_SCOPE Tcl_ObjType tclIntType; MODULE_SCOPE Tcl_ObjType tclListType; MODULE_SCOPE Tcl_ObjType tclDictType; MODULE_SCOPE Tcl_ObjType tclProcBodyType; MODULE_SCOPE Tcl_ObjType tclStringType; MODULE_SCOPE Tcl_ObjType tclArraySearchType; MODULE_SCOPE Tcl_ObjType tclNsNameType; #ifndef NO_WIDE_TYPE MODULE_SCOPE Tcl_ObjType tclWideIntType; #endif MODULE_SCOPE Tcl_ObjType tclRegexpType; /* * Variables denoting the hash key types defined in the core. */ MODULE_SCOPE Tcl_HashKeyType tclArrayHashKeyType; MODULE_SCOPE Tcl_HashKeyType tclOneWordHashKeyType; |
︙ | ︙ | |||
1775 1776 1777 1778 1779 1780 1781 | MODULE_SCOPE long tclObjsAlloced; MODULE_SCOPE long tclObjsFreed; #define TCL_MAX_SHARED_OBJ_STATS 5 MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; #endif /* TCL_COMPILE_STATS */ /* | | | | | < > > > | | | | | | > > | > > > > > | | | > | < | | | | | | | | | | | | | > | | > > > > > > > > > | | | | | | | | | | | | > > > > > > > > > > | < | | | > > > > | > > | > | | | | | | | | > | < | < | < | | | < | | < | | | < | | | | | | < | | | > > | | | | | > > | | > | | | | | | < | | | | | | | < | | < | < | < | < < | < | | | | | | | | | | | | | | < | | | | < | < | | | < | | | | | | | | | | < < < < | < | | | > | | < | < < < | | | | | < > | > > | | > > > < < < < < < < < < | < | < | | < | | < | < | | < | | | < | > > | > > > > > > | | | | | | | | | | | | | | | | > > > | | | | | | | | | | | | | | | | | | | | | | > > > | | | | | | > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > | | | | > > | | < | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < | | | | | | < < < < < < < < < < < | > | | | | | | | > | | | | > | 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 | MODULE_SCOPE long tclObjsAlloced; MODULE_SCOPE long tclObjsFreed; #define TCL_MAX_SHARED_OBJ_STATS 5 MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; #endif /* TCL_COMPILE_STATS */ /* * Pointer to a heap-allocated string of length zero that the Tcl core uses as * the value of an empty string representation for an object. This value is * shared by all new objects allocated by Tcl_NewObj. */ MODULE_SCOPE char * tclEmptyStringRep; MODULE_SCOPE char tclEmptyString; /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: *---------------------------------------------------------------- */ MODULE_SCOPE int TclAppendFormattedObjs(Tcl_Interp *interp, Tcl_Obj *appendObj, CONST char *format, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE void TclAppendLimitedToObj(Tcl_Obj *objPtr, CONST char *bytes, int length, int limit, CONST char *ellipsis); MODULE_SCOPE void TclAppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE int TclArraySet(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj); MODULE_SCOPE double TclBignumToDouble(mp_int* bignum); MODULE_SCOPE double TclCeil(mp_int* a); MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,CONST char *value); MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclChanPostEventObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp* interp, LiteralTable* tablePtr); MODULE_SCOPE int TclDoubleDigits(char* buf, double value, int* signum); MODULE_SCOPE void TclExpandTokenArray(Tcl_Parse *parsePtr); MODULE_SCOPE int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclFileCopyCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclFileDeleteCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclFileMakeDirsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclFileRenameCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeCompilation(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); MODULE_SCOPE void TclFinalizeEnvironment(void); MODULE_SCOPE void TclFinalizeExecution(void); MODULE_SCOPE void TclFinalizeIOSubsystem(void); MODULE_SCOPE void TclFinalizeFilesystem(void); MODULE_SCOPE void TclResetFilesystem(void); MODULE_SCOPE void TclFinalizeLoad(void); MODULE_SCOPE void TclFinalizeLock(void); MODULE_SCOPE void TclFinalizeMemorySubsystem(void); MODULE_SCOPE void TclFinalizeNotifier(void); MODULE_SCOPE void TclFinalizeObjects(void); MODULE_SCOPE void TclFinalizePreserve(void); MODULE_SCOPE void TclFinalizeSynchronization(void); MODULE_SCOPE void TclFinalizeThreadData(void); MODULE_SCOPE double TclFloor(mp_int* a); MODULE_SCOPE void TclFormatNaN(double value, char* buffer); MODULE_SCOPE int TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...); MODULE_SCOPE int TclFormatToErrorInfo(Tcl_Interp *interp, CONST char *format, ...); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, CONST char *attributeName, int *indexPtr); MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); MODULE_SCOPE int TclGetEncodingFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientDataPtr, int *typePtr); MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, CONST char *modeString, int *seekFlagPtr, int *binaryPtr); MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData* types); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE int TclInitBignumFromDouble(Tcl_Interp *interp, double d, mp_int *b); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( Tcl_Interp *interp); MODULE_SCOPE void TclInitEncodingSubsystem(void); MODULE_SCOPE void TclInitIOSubsystem(void); MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE void TclInitSubsystems (); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsLocalScalar(CONST char *src, int len); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int* result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp* interp, Tcl_Obj* listPtr, Tcl_Obj* argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp* interp, Tcl_Obj* listPtr, int indexCount, Tcl_Obj *CONST indexArray[]); MODULE_SCOPE int TclLoadFile(Tcl_Interp* interp, Tcl_Obj *pathPtr, int symc, CONST char *symbols[], Tcl_PackageInitProc **procPtrs[], Tcl_LoadHandle *handlePtr, ClientData *clientDataPtr, Tcl_FSUnloadFileProc **unloadProcPtr); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp* interp, Tcl_Obj* listPtr, Tcl_Obj* indexPtr, Tcl_Obj* valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp* interp, Tcl_Obj* listPtr, int indexCount, Tcl_Obj *CONST indexArray[], Tcl_Obj* valuePtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], Tcl_Namespace *nsPtr, int flags); MODULE_SCOPE int TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...); MODULE_SCOPE int TclParseBackslash(CONST char *src, int numBytes, int *readPtr, char *dst); MODULE_SCOPE int TclParseHex(CONST char *src, int numBytes, Tcl_UniChar *resultPtr); MODULE_SCOPE int TclParseNumber(Tcl_Interp* interp, Tcl_Obj* objPtr, CONST char* type, CONST char* string, size_t length, CONST char** endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, CONST char *string, int numBytes, Tcl_Parse *parsePtr); #if 0 MODULE_SCOPE int TclParseInteger(CONST char *string, int numBytes); #endif MODULE_SCOPE int TclParseWhiteSpace(CONST char *src, int numBytes, Tcl_Parse *parsePtr, char *typePtr); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE int TclpCheckStackSpace(void); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len); MODULE_SCOPE int TclpDeleteFile(CONST char *path); MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags); MODULE_SCOPE int TclpFindVariable(CONST char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE int TclpLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, CONST char *sym1, CONST char *sym2, Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr, Tcl_FSUnloadFileProc **unloadProcPtr); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); MODULE_SCOPE void TclpMasterLock(void); MODULE_SCOPE void TclpMasterUnlock(void); MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, Tcl_DString *dirPtr, char *pattern, char *tail); MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, char *joining); MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr); MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, int *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp, Tcl_Obj *source, Tcl_Obj *target); MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types); MODULE_SCOPE ClientData TclpGetNativeCwd(ClientData clientData); MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep; MODULE_SCOPE Tcl_Obj* TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType); MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_PathPart portion); MODULE_SCOPE void TclpPanic(CONST char *format, ...); MODULE_SCOPE char * TclpReadlink(CONST char *fileName, Tcl_DString *linkPtr); MODULE_SCOPE void TclpReleaseFile(TclFile file); MODULE_SCOPE void TclpSetInterfaces(void); MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp); MODULE_SCOPE void TclpUnloadFile(Tcl_LoadHandle loadHandle); MODULE_SCOPE VOID * TclpThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr); MODULE_SCOPE void TclpThreadDataKeySet(Tcl_ThreadDataKey *keyPtr, VOID *data); MODULE_SCOPE void TclpThreadExit(int status); MODULE_SCOPE int TclpThreadGetStackSize(void); MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex); MODULE_SCOPE VOID TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep (Tcl_Obj *objPtr, mp_int *bignumValue); MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE VOID TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr); MODULE_SCOPE void TclTransferResult(Tcl_Interp *sourceInterp, int result, Tcl_Interp *targetInterp); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_PackageInitProc* TclpFindSymbol(Tcl_Interp *interp, Tcl_LoadHandle loadHandle, CONST char *symbol); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr); MODULE_SCOPE int TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval); #ifdef TCL_LOAD_FROM_MEMORY MODULE_SCOPE void* TclpLoadMemoryGetBuffer(Tcl_Interp *interp, int size); MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer, int size, int codeSize, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr); #endif MODULE_SCOPE void TclInitThreadStorage(void); MODULE_SCOPE void TclpFinalizeThreadDataThread(void); MODULE_SCOPE void TclFinalizeThreadStorage(void); /* *---------------------------------------------------------------- * Command procedures in the generic core: *---------------------------------------------------------------- */ MODULE_SCOPE int Tcl_AfterObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_AppendObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ArrayObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_BinaryObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_CdObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclChanTruncateObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclClockClicksObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclClockGetenvObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclClockMicrosecondsObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclClockMillisecondsObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclClockSecondsObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclClockLocaltimeObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclClockMktimeObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclClockOldscanObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ConcatObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ContinueObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, ClientData clientData); MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_DictObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclEncodingDirsObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ErrorObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_EvalObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ExecObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ExitObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ExprObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_FblockedObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_FconfigureObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_FileObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_FileEventObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_FlushObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ForObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ForeachObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_FormatObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_GetsObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_GlobalObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_GlobObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_IfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_InfoObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_JoinObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_LappendObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_LassignObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_LindexObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_LinsertObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_LrepeatObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_LreplaceObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_LsearchObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_NamespaceObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_OpenObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_PackageObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_PidObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_PutsObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_PwdObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ReadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_RegexpObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_RegsubObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_RenameObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ReturnObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ScanObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_SeekObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_SetObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_SplitObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_SocketObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_SourceObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_StringObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_SubstObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_SwitchObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_TellObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_UnloadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_UnsetObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_UpdateObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_UplevelObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_UpvarObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_VariableObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_VwaitObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); /* *---------------------------------------------------------------- * Compilation procedures for commands in the generic core: *---------------------------------------------------------------- */ MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileExprCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp* interp, Tcl_Parse* parsePtr, struct CompileEnv* envPtr); MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp* interp, Tcl_Parse* parsePtr, struct CompileEnv* envPtr); MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileWhileCmd(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. */ MODULE_SCOPE Var * TclLookupArrayElement(Tcl_Interp *interp, CONST char *arrayName, CONST char *elName, CONST int flags, CONST char *msg, CONST int createPart1, CONST int createPart2, Var *arrayPtr); MODULE_SCOPE Var * TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, CONST char *part2, int flags, CONST char *msg, CONST int createPart1, CONST int createPart2, Var **arrayPtrPtr); MODULE_SCOPE Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, CONST char *part1, CONST char *part2, CONST int flags); MODULE_SCOPE Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, CONST char *part1, CONST char *part2, Tcl_Obj *newValuePtr, CONST int flags); MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVar (Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, CONST char *part1, CONST char *part2, Tcl_Obj *incrPtr, CONST int flags); #if 0 MODULE_SCOPE Tcl_Obj * TclPtrIncrVar(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, CONST char *part1, CONST char *part2, CONST long i, CONST int flags); MODULE_SCOPE Tcl_Obj * TclPtrIncrWideVar(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, CONST char *part1, CONST char *part2, CONST Tcl_WideInt i, CONST int flags); #endif MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); /* *---------------------------------------------------------------- * 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: * * MODULE_SCOPE void TclNewObj(Tcl_Obj *objPtr); * MODULE_SCOPE void TclDecrRefCount(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 */ #ifndef TCL_MEM_DEBUG # define TclNewObj(objPtr) \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL # define TclDecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) { \ if ((objPtr)->typePtr && (objPtr)->typePtr->freeIntRepProc) { \ TclFreeObj(objPtr); \ } else { \ if ((objPtr)->bytes \ && ((objPtr)->bytes != tclEmptyStringRep)) { \ ckfree((char *) (objPtr)->bytes); \ } \ TclFreeObjStorage(objPtr); \ TclIncrObjsFreed(); \ } \ } #if 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_Alloc(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. */ MODULE_SCOPE Tcl_Obj * TclThreadAllocObj(void); MODULE_SCOPE void TclThreadFreeObj(Tcl_Obj *); MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); MODULE_SCOPE void TclFreeAllocCache(void *); MODULE_SCOPE void * TclpGetAllocCache(void); MODULE_SCOPE void TclpSetAllocCache(void *); MODULE_SCOPE void TclFinalizeThreadAlloc(void); MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex* mutex); MODULE_SCOPE void TclpFreeAllocCache(void *); # define TclAllocObjStorage(objPtr) \ (objPtr) = TclThreadAllocObj() # define TclFreeObjStorage(objPtr) \ TclThreadFreeObj((objPtr)) |
︙ | ︙ | |||
2578 2579 2580 2581 2582 2583 2584 | Tcl_MutexLock(&tclObjMutex); \ (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ tclFreeObjList = (objPtr); \ Tcl_MutexUnlock(&tclObjMutex) #endif #else /* TCL_MEM_DEBUG */ | | | | | | | < < | > > > | | | < | | | | | | | > > | < < | | > > > > > | | > > > > > > > | > > | | | | < | | < | | | | | < | | < | | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > | 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 | Tcl_MutexLock(&tclObjMutex); \ (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ tclFreeObjList = (objPtr); \ Tcl_MutexUnlock(&tclObjMutex) #endif #else /* TCL_MEM_DEBUG */ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr); # define TclDbNewObj(objPtr, file, line) \ TclIncrObjsAllocated(); \ (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ TclDbInitNewObj(objPtr); # define TclNewObj(objPtr) \ TclDbNewObj(objPtr, __FILE__, __LINE__); # define TclDecrRefCount(objPtr) \ Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) # define TclNewListObjDirect(objc, objv) \ TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__) #undef USE_THREAD_ALLOC #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 is correct. Because "len" * is referenced multiple times, it should be as simple an expression as * possible. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, int len); * * This macro should only be called on an unshared objPtr where * objPtr->typePtr->freeIntRepProc == NULL *---------------------------------------------------------------- */ #define TclInitStringRep(objPtr, bytePtr, len) \ if ((len) == 0) { \ (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ } else { \ (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ memcpy((VOID *) (objPtr)->bytes, (VOID *) (bytePtr), \ (unsigned) (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ } /* *---------------------------------------------------------------- * Macro used by the Tcl core to get the string representation's byte array * pointer from a Tcl_Obj. This is an inline version of Tcl_GetString(). The * macro's expression result is the string rep's byte pointer which might be * NULL. The bytes referenced by this pointer must not be modified by the * caller. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE char * TclGetString(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclGetString(objPtr) \ ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr))) /* *---------------------------------------------------------------- * Macro used by the Tcl core to clean out an object's internal * representation. Does not actually reset the rep's bytes. The ANSI C * "prototype" for this macro is: * * MODULE_SCOPE void TclFreeIntRep(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclFreeIntRep(objPtr) \ if ((objPtr)->typePtr != NULL && \ (objPtr)->typePtr->freeIntRepProc != NULL) { \ (objPtr)->typePtr->freeIntRepProc(objPtr); \ } /* *---------------------------------------------------------------- * Macro used by the Tcl core to clean out an object's string representation. * The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclInvalidateStringRep(objPtr) \ if (objPtr->bytes != NULL) { \ if (objPtr->bytes != tclEmptyStringRep) {\ ckfree((char *) objPtr->bytes);\ }\ objPtr->bytes = NULL;\ }\ #if 0 /* *---------------------------------------------------------------- * Macro used by the Tcl core to get a Tcl_WideInt value out of a Tcl_Obj of * the "wideInt" type. *---------------------------------------------------------------- */ #ifndef NO_WIDE_TYPE # define TclGetWide(resultVar, objPtr) \ (resultVar) = (objPtr)->internalRep.wideValue # define TclGetLongFromWide(resultVar, objPtr) \ (resultVar) = Tcl_WideAsLong((objPtr)->internalRep.wideValue) #endif #endif /* *---------------------------------------------------------------- * Macro used by the Tcl core get a unicode char from a utf string. It checks * to see if we have a one-byte utf char before calling the real * Tcl_UtfToUniChar, as this will save a lot of time for primarily ascii * string handling. The macro's expression result is 1 for the 1-byte case or * the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclUtfToUniChar(CONST char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #define TclUtfToUniChar(str, chPtr) \ ((((unsigned char) *(str)) < 0xC0) ? \ ((*(chPtr) = (Tcl_UniChar) *(str)), 1) \ : Tcl_UtfToUniChar(str, chPtr)) /* *---------------------------------------------------------------- * Macro used by the Tcl core to compare Unicode strings. On big-endian * systems we can use the more efficient memcmp, but this would not be * lexically correct on little-endian systems. The ANSI C "prototype" for * this macro is: * * MODULE_SCOPE int TclUniCharNcmp(CONST Tcl_UniChar *cs, * CONST Tcl_UniChar *ct, unsigned long n); *---------------------------------------------------------------- */ #ifdef WORDS_BIGENDIAN # define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) #else /* !WORDS_BIGENDIAN */ # define TclUniCharNcmp Tcl_UniCharNcmp #endif /* WORDS_BIGENDIAN */ /* *---------------------------------------------------------------- * Macro used by the Tcl core to increment a namespace's export export epoch * counter. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); *---------------------------------------------------------------- */ #define TclInvalidateNsCmdLookup(nsPtr) \ if ((nsPtr)->numExportPatterns) { \ (nsPtr)->exportLookupEpoch++; \ } /* *---------------------------------------------------------------------- * * Core procedures added to libtommath for bignum manipulation. * *---------------------------------------------------------------------- */ MODULE_SCOPE void * TclBNAlloc(size_t nBytes); MODULE_SCOPE void * TclBNRealloc(void *oldBlock, size_t newNBytes); MODULE_SCOPE void TclBNFree(void *block); MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal); MODULE_SCOPE void TclBNInitBignumFromWideInt(mp_int* bignum, Tcl_WideInt initVal); MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int* bignum, Tcl_WideUInt initVal); /* *---------------------------------------------------------------- * Macro used by the Tcl core to check whether a pattern has any characters * special to [string match]. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclMatchIsTrivial(CONST char *pattern); *---------------------------------------------------------------- */ #define TclMatchIsTrivial(pattern) strpbrk((pattern), "*[]]?\\") == NULL /* *---------------------------------------------------------------- * Macro used by the Tcl core to write the string rep of a long integer to a * character buffer. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclFormatInt(char *buf, long n); *---------------------------------------------------------------- */ #define TclFormatInt(buf, n) sprintf((buf), "%ld", (long)(n)) /* *---------------------------------------------------------------- * Macros used by the Tcl core to set a Tcl_Obj's numeric representation * avoiding the corresponding function calls in time critical parts of the * core. They should only be called on unshared objects. The ANSI C * "prototypes" for these macros are: * * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, int intValue); * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue); * MODULE_SCOPE void TclSetBooleanObj(Tcl_Obj *objPtr, long boolValue); * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d); *---------------------------------------------------------------- */ #define TclSetIntObj(objPtr, i) \ TclInvalidateStringRep(objPtr);\ TclFreeIntRep(objPtr); \ (objPtr)->internalRep.longValue = (long)(i); \ (objPtr)->typePtr = &tclIntType #define TclSetLongObj(objPtr, l) \ TclSetIntObj((objPtr), (l)) /* * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1. * The only "boolean" Tcl_Obj's shall be those holding the cached boolean * value of strings like: "yes", "no", "true", "false", "on", "off". */ #define TclSetBooleanObj(objPtr, b) \ TclSetIntObj((objPtr), ((b)? 1 : 0)); #ifndef NO_WIDE_TYPE #define TclSetWideIntObj(objPtr, w) \ TclInvalidateStringRep(objPtr);\ TclFreeIntRep(objPtr); \ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ (objPtr)->typePtr = &tclWideIntType #endif #define TclSetDoubleObj(objPtr, d) \ TclInvalidateStringRep(objPtr);\ TclFreeIntRep(objPtr); \ (objPtr)->internalRep.doubleValue = (double)(d); \ (objPtr)->typePtr = &tclDoubleType /* *---------------------------------------------------------------- * Macros used by the Tcl core to create and initialise objects of standard * types, avoiding the corresponding function calls in time critical parts of * the core. The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, int i); * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l); * MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b); * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len); * *---------------------------------------------------------------- */ #ifndef TCL_MEM_DEBUG #define TclNewIntObj(objPtr, i) \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ (objPtr)->internalRep.longValue = (long)(i); \ (objPtr)->typePtr = &tclIntType #define TclNewLongObj(objPtr, l) \ TclNewIntObj((objPtr), (l)) /* * NOTE: There is to be no such thing as a "pure" boolean. * See comment above TclSetBooleanObj macro above. */ #define TclNewBooleanObj(objPtr, b) \ TclNewIntObj((objPtr), ((b)? 1 : 0)) #define TclNewDoubleObj(objPtr, d) \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ (objPtr)->internalRep.doubleValue = (double)(d); \ (objPtr)->typePtr = &tclDoubleType #define TclNewStringObj(objPtr, s, len) \ TclNewObj(objPtr); \ TclInitStringRep((objPtr), (s), (len)) #else /* TCL_MEM_DEBUG */ #define TclNewIntObj(objPtr, i) \ (objPtr) = Tcl_NewIntObj(i) #define TclNewLongObj(objPtr, l) \ (objPtr) = Tcl_NewLongObj(l) #define TclNewBooleanObj(objPtr, b) \ (objPtr) = Tcl_NewBooleanObj(b) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) #define TclNewStringObj(objPtr, s, len) \ (objPtr) = Tcl_NewStringObj((s), (len)) #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------- * Macros used by the Tcl core to test for some special double values. * The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE int TclIsInfinite _ANSI_ARGS_((double d)); * MODULE_SCOPE int TclIsNaN _ANSI_ARGS_((double d)); */ #ifdef _MSC_VER #define TclIsInfinite(d) ( ! (_finite((d))) ) #define TclIsNaN(d) (_isnan((d))) #else #define TclIsInfinite(d) ( (d) > DBL_MAX || (d) < -DBL_MAX ) #define TclIsNaN(d) ((d) != (d)) #endif #include "tclPort.h" #include "tclIntDecls.h" #include "tclIntPlatDecls.h" #endif /* _TCLINT */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
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 22 23 24 25 | /* * 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. * <<<<<<< tclIntDecls.h * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.12 2005/08/23 06:15:21 dgp Exp $ ======= * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.12 2005/08/23 06:15:21 dgp Exp $ >>>>>>> 1.83 */ #ifndef _TCLINTDECLS #define _TCLINTDECLS #include "tclPort.h" |
︙ | ︙ | |||
166 167 168 169 170 171 172 | #endif #ifndef TclFindProc_TCL_DECLARED #define TclFindProc_TCL_DECLARED /* 23 */ EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); #endif | < < | < < | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 | #endif #ifndef TclFindProc_TCL_DECLARED #define TclFindProc_TCL_DECLARED /* 23 */ EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); #endif /* Slot 24 is reserved */ #ifndef TclFreePackageInfo_TCL_DECLARED #define TclFreePackageInfo_TCL_DECLARED /* 25 */ EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr)); #endif /* Slot 26 is reserved */ /* Slot 27 is reserved */ |
︙ | ︙ | |||
271 272 273 274 275 276 277 | #ifndef TclInExit_TCL_DECLARED #define TclInExit_TCL_DECLARED /* 46 */ EXTERN int TclInExit _ANSI_ARGS_((void)); #endif /* Slot 47 is reserved */ /* Slot 48 is reserved */ | < < | < < < < | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 | #ifndef TclInExit_TCL_DECLARED #define TclInExit_TCL_DECLARED /* 46 */ EXTERN int TclInExit _ANSI_ARGS_((void)); #endif /* Slot 47 is reserved */ /* Slot 48 is reserved */ /* Slot 49 is reserved */ #ifndef TclInitCompiledLocals_TCL_DECLARED #define TclInitCompiledLocals_TCL_DECLARED /* 50 */ EXTERN void TclInitCompiledLocals _ANSI_ARGS_(( Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); #endif |
︙ | ︙ | |||
684 685 686 687 688 689 690 | #ifndef TclGetEnv_TCL_DECLARED #define TclGetEnv_TCL_DECLARED /* 138 */ EXTERN CONST84_RETURN char * TclGetEnv _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); #endif /* Slot 139 is reserved */ | < < | < < < | 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 | #ifndef TclGetEnv_TCL_DECLARED #define TclGetEnv_TCL_DECLARED /* 138 */ EXTERN CONST84_RETURN char * TclGetEnv _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); #endif /* Slot 139 is reserved */ /* Slot 140 is reserved */ #ifndef TclpGetCwd_TCL_DECLARED #define TclpGetCwd_TCL_DECLARED /* 141 */ EXTERN CONST84_RETURN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); #endif #ifndef TclSetByteCodeFromAny_TCL_DECLARED |
︙ | ︙ | |||
872 873 874 875 876 877 878 | #define TclUniCharMatch_TCL_DECLARED /* 173 */ EXTERN int TclUniCharMatch _ANSI_ARGS_(( CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); #endif | < < | < < < < < | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 | #define TclUniCharMatch_TCL_DECLARED /* 173 */ EXTERN int TclUniCharMatch _ANSI_ARGS_(( CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); #endif /* Slot 174 is reserved */ #ifndef TclCallVarTraces_TCL_DECLARED #define TclCallVarTraces_TCL_DECLARED /* 175 */ EXTERN int TclCallVarTraces _ANSI_ARGS_((Interp * iPtr, Var * arrayPtr, Var * varPtr, CONST char * part1, CONST char * part2, int flags, int leaveErrMsg)); |
︙ | ︙ | |||
913 914 915 916 917 918 919 | #endif #ifndef Tcl_GetStartupScript_TCL_DECLARED #define Tcl_GetStartupScript_TCL_DECLARED /* 179 */ EXTERN Tcl_Obj * Tcl_GetStartupScript _ANSI_ARGS_(( CONST char ** encodingNamePtr)); #endif | < < | < < < < < | < < < < < | < < < < | < < < < | < < < < | < < < < < | < < < < < | < | < < < < < < < < < | < < < < < | < < < < < | < < < < < | < < < < | < < < < < | < < < < < | < < | 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 | #endif #ifndef Tcl_GetStartupScript_TCL_DECLARED #define Tcl_GetStartupScript_TCL_DECLARED /* 179 */ EXTERN Tcl_Obj * Tcl_GetStartupScript _ANSI_ARGS_(( CONST char ** encodingNamePtr)); #endif /* Slot 180 is reserved */ /* Slot 181 is reserved */ #ifndef TclpLocaltime_TCL_DECLARED #define TclpLocaltime_TCL_DECLARED /* 182 */ EXTERN struct tm * TclpLocaltime _ANSI_ARGS_((CONST time_t * clock)); #endif #ifndef TclpGmtime_TCL_DECLARED #define TclpGmtime_TCL_DECLARED /* 183 */ EXTERN struct tm * TclpGmtime _ANSI_ARGS_((CONST time_t * clock)); #endif /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ /* Slot 187 is reserved */ /* Slot 188 is reserved */ /* Slot 189 is reserved */ /* Slot 190 is reserved */ /* Slot 191 is reserved */ /* Slot 192 is reserved */ /* Slot 193 is reserved */ /* Slot 194 is reserved */ /* Slot 195 is reserved */ /* Slot 196 is reserved */ #ifndef TclCompEvalObj_TCL_DECLARED #define TclCompEvalObj_TCL_DECLARED /* 197 */ EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); #endif #ifndef TclObjGetFrame_TCL_DECLARED #define TclObjGetFrame_TCL_DECLARED /* 198 */ EXTERN int TclObjGetFrame _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CallFrame ** framePtrPtr)); #endif /* Slot 199 is reserved */ #ifndef TclpObjRemoveDirectory_TCL_DECLARED #define TclpObjRemoveDirectory_TCL_DECLARED /* 200 */ EXTERN int TclpObjRemoveDirectory _ANSI_ARGS_(( Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); #endif |
︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 | #endif #ifndef TclSetObjNameOfExecutable_TCL_DECLARED #define TclSetObjNameOfExecutable_TCL_DECLARED /* 214 */ EXTERN void TclSetObjNameOfExecutable _ANSI_ARGS_(( Tcl_Obj * name, Tcl_Encoding encoding)); #endif typedef struct TclIntStubs { int magic; struct TclIntStubHooks *hooks; void *reserved0; int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #endif #ifndef TclSetObjNameOfExecutable_TCL_DECLARED #define TclSetObjNameOfExecutable_TCL_DECLARED /* 214 */ EXTERN void TclSetObjNameOfExecutable _ANSI_ARGS_(( Tcl_Obj * name, Tcl_Encoding encoding)); #endif #ifndef TclStackAlloc_TCL_DECLARED #define TclStackAlloc_TCL_DECLARED /* 215 */ EXTERN char * TclStackAlloc _ANSI_ARGS_((Tcl_Interp * interp, int numBytes)); #endif #ifndef TclStackFree_TCL_DECLARED #define TclStackFree_TCL_DECLARED /* 216 */ EXTERN void TclStackFree _ANSI_ARGS_((Tcl_Interp * interp)); #endif #ifndef TclPushStackFrame_TCL_DECLARED #define TclPushStackFrame_TCL_DECLARED /* 217 */ EXTERN int TclPushStackFrame _ANSI_ARGS_((Tcl_Interp * interp, Tcl_CallFrame ** framePtrPtr, Tcl_Namespace * namespacePtr, int isProcCallFrame)); #endif #ifndef TclPopStackFrame_TCL_DECLARED #define TclPopStackFrame_TCL_DECLARED /* 218 */ EXTERN void TclPopStackFrame _ANSI_ARGS_((Tcl_Interp * interp)); #endif #ifndef TclBN_mp_div_d_TCL_DECLARED #define TclBN_mp_div_d_TCL_DECLARED /* 219 */ EXTERN int TclBN_mp_div_d _ANSI_ARGS_((mp_int * a, mp_digit b, mp_int * c, mp_digit * d)); #endif #ifndef TclBN_mp_mul_d_TCL_DECLARED #define TclBN_mp_mul_d_TCL_DECLARED /* 220 */ EXTERN int TclBN_mp_mul_d _ANSI_ARGS_((mp_int * a, mp_digit b, mp_int * c)); #endif #ifndef TclBN_mp_clear_TCL_DECLARED #define TclBN_mp_clear_TCL_DECLARED /* 221 */ EXTERN void TclBN_mp_clear _ANSI_ARGS_((mp_int * a)); #endif #ifndef TclBN_mp_init_TCL_DECLARED #define TclBN_mp_init_TCL_DECLARED /* 222 */ EXTERN int TclBN_mp_init _ANSI_ARGS_((mp_int * a)); #endif #ifndef TclBN_mp_read_radix_TCL_DECLARED #define TclBN_mp_read_radix_TCL_DECLARED /* 223 */ EXTERN int TclBN_mp_read_radix _ANSI_ARGS_((mp_int * a, const char * str, int radix)); #endif #ifndef TclGetPlatform_TCL_DECLARED #define TclGetPlatform_TCL_DECLARED /* 224 */ EXTERN TclPlatformType * TclGetPlatform _ANSI_ARGS_((void)); #endif #ifndef TclTraceDictPath_TCL_DECLARED #define TclTraceDictPath_TCL_DECLARED /* 225 */ EXTERN Tcl_Obj * TclTraceDictPath _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * rootPtr, int keyc, Tcl_Obj *CONST keyv[], int flags)); #endif typedef struct TclIntStubs { int magic; struct TclIntStubHooks *hooks; void *reserved0; int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */ |
︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 | void *reserved17; void *reserved18; void *reserved19; void *reserved20; void *reserved21; int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */ Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); /* 23 */ | | | 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 | void *reserved17; void *reserved18; void *reserved19; void *reserved20; void *reserved21; int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */ Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); /* 23 */ void *reserved24; void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */ void *reserved26; void *reserved27; Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */ void *reserved29; void *reserved30; CONST char * (*tclGetExtension) _ANSI_ARGS_((CONST char * name)); /* 31 */ |
︙ | ︙ | |||
1178 1179 1180 1181 1182 1183 1184 | char * (*tclpGetUserHome) _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 42 */ void *reserved43; 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; | | | 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 | char * (*tclpGetUserHome) _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 42 */ void *reserved43; 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; void *reserved49; void (*tclInitCompiledLocals) _ANSI_ARGS_((Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 50 */ int (*tclInterpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 51 */ void *reserved52; 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; |
︙ | ︙ | |||
1274 1275 1276 1277 1278 1279 1280 | struct tm * (*tclpGetDate) _ANSI_ARGS_((CONST time_t * time, int useGMT)); /* 133 */ void *reserved134; void *reserved135; void *reserved136; void *reserved137; CONST84_RETURN char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */ void *reserved139; | | | 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 | struct tm * (*tclpGetDate) _ANSI_ARGS_((CONST time_t * time, int useGMT)); /* 133 */ void *reserved134; void *reserved135; void *reserved136; void *reserved137; CONST84_RETURN char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */ void *reserved139; void *reserved140; 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 */ |
︙ | ︙ | |||
1308 1309 1310 1311 1312 1313 1314 | void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */ Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */ int (*tclpUtfNcmp2) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 169 */ int (*tclCheckInterpTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 170 */ int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */ int (*tclInThreadExit) _ANSI_ARGS_((void)); /* 172 */ int (*tclUniCharMatch) _ANSI_ARGS_((CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); /* 173 */ | | | | | | | | | | | | | | | | | | > > > > > > > > > > > | 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 | void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */ Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */ int (*tclpUtfNcmp2) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 169 */ int (*tclCheckInterpTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 170 */ int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */ int (*tclInThreadExit) _ANSI_ARGS_((void)); /* 172 */ int (*tclUniCharMatch) _ANSI_ARGS_((CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); /* 173 */ void *reserved174; int (*tclCallVarTraces) _ANSI_ARGS_((Interp * iPtr, Var * arrayPtr, Var * varPtr, CONST char * part1, CONST char * part2, int flags, int leaveErrMsg)); /* 175 */ void (*tclCleanupVar) _ANSI_ARGS_((Var * varPtr, Var * arrayPtr)); /* 176 */ void (*tclVarErrMsg) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * operation, CONST char * reason)); /* 177 */ void (*tcl_SetStartupScript) _ANSI_ARGS_((Tcl_Obj * pathPtr, CONST char* encodingName)); /* 178 */ Tcl_Obj * (*tcl_GetStartupScript) _ANSI_ARGS_((CONST char ** encodingNamePtr)); /* 179 */ void *reserved180; void *reserved181; struct tm * (*tclpLocaltime) _ANSI_ARGS_((CONST time_t * clock)); /* 182 */ struct tm * (*tclpGmtime) _ANSI_ARGS_((CONST time_t * clock)); /* 183 */ void *reserved184; void *reserved185; void *reserved186; void *reserved187; void *reserved188; void *reserved189; void *reserved190; void *reserved191; void *reserved192; void *reserved193; void *reserved194; void *reserved195; void *reserved196; int (*tclCompEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 197 */ int (*tclObjGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CallFrame ** framePtrPtr)); /* 198 */ void *reserved199; int (*tclpObjRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 200 */ int (*tclpObjCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 201 */ int (*tclpObjCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 202 */ int (*tclpObjDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 203 */ int (*tclpObjCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 204 */ int (*tclpObjRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 205 */ int (*tclpObjStat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 206 */ int (*tclpObjAccess) _ANSI_ARGS_((Tcl_Obj * pathPtr, int mode)); /* 207 */ Tcl_Channel (*tclpOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, int mode, int permissions)); /* 208 */ Tcl_Obj * (*tclGetEncodingSearchPath) _ANSI_ARGS_((void)); /* 209 */ int (*tclSetEncodingSearchPath) _ANSI_ARGS_((Tcl_Obj * searchPath)); /* 210 */ CONST char * (*tclpGetEncodingNameFromEnvironment) _ANSI_ARGS_((Tcl_DString * bufPtr)); /* 211 */ void (*tclpFindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 212 */ Tcl_Obj * (*tclGetObjNameOfExecutable) _ANSI_ARGS_((void)); /* 213 */ void (*tclSetObjNameOfExecutable) _ANSI_ARGS_((Tcl_Obj * name, Tcl_Encoding encoding)); /* 214 */ char * (*tclStackAlloc) _ANSI_ARGS_((Tcl_Interp * interp, int numBytes)); /* 215 */ void (*tclStackFree) _ANSI_ARGS_((Tcl_Interp * interp)); /* 216 */ int (*tclPushStackFrame) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_CallFrame ** framePtrPtr, Tcl_Namespace * namespacePtr, int isProcCallFrame)); /* 217 */ void (*tclPopStackFrame) _ANSI_ARGS_((Tcl_Interp * interp)); /* 218 */ int (*tclBN_mp_div_d) _ANSI_ARGS_((mp_int * a, mp_digit b, mp_int * c, mp_digit * d)); /* 219 */ int (*tclBN_mp_mul_d) _ANSI_ARGS_((mp_int * a, mp_digit b, mp_int * c)); /* 220 */ void (*tclBN_mp_clear) _ANSI_ARGS_((mp_int * a)); /* 221 */ int (*tclBN_mp_init) _ANSI_ARGS_((mp_int * a)); /* 222 */ int (*tclBN_mp_read_radix) _ANSI_ARGS_((mp_int * a, const char * str, int radix)); /* 223 */ TclPlatformType * (*tclGetPlatform) _ANSI_ARGS_((void)); /* 224 */ Tcl_Obj * (*tclTraceDictPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * rootPtr, int keyc, Tcl_Obj *CONST keyv[], int flags)); /* 225 */ } TclIntStubs; #ifdef __cplusplus extern "C" { #endif extern TclIntStubs *tclIntStubsPtr; #ifdef __cplusplus |
︙ | ︙ | |||
1450 1451 1452 1453 1454 1455 1456 | #define TclFindElement \ (tclIntStubsPtr->tclFindElement) /* 22 */ #endif #ifndef TclFindProc #define TclFindProc \ (tclIntStubsPtr->tclFindProc) /* 23 */ #endif | | < < < | 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 | #define TclFindElement \ (tclIntStubsPtr->tclFindElement) /* 22 */ #endif #ifndef TclFindProc #define TclFindProc \ (tclIntStubsPtr->tclFindProc) /* 23 */ #endif /* Slot 24 is reserved */ #ifndef TclFreePackageInfo #define TclFreePackageInfo \ (tclIntStubsPtr->tclFreePackageInfo) /* 25 */ #endif /* Slot 26 is reserved */ /* Slot 27 is reserved */ #ifndef TclpGetDefaultStdChannel |
︙ | ︙ | |||
1523 1524 1525 1526 1527 1528 1529 | #endif #ifndef TclInExit #define TclInExit \ (tclIntStubsPtr->tclInExit) /* 46 */ #endif /* Slot 47 is reserved */ /* Slot 48 is reserved */ | < < | < | 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 | #endif #ifndef TclInExit #define TclInExit \ (tclIntStubsPtr->tclInExit) /* 46 */ #endif /* Slot 47 is reserved */ /* Slot 48 is reserved */ /* Slot 49 is reserved */ #ifndef TclInitCompiledLocals #define TclInitCompiledLocals \ (tclIntStubsPtr->tclInitCompiledLocals) /* 50 */ #endif #ifndef TclInterpInit #define TclInterpInit \ (tclIntStubsPtr->tclInterpInit) /* 51 */ |
︙ | ︙ | |||
1805 1806 1807 1808 1809 1810 1811 | /* Slot 136 is reserved */ /* Slot 137 is reserved */ #ifndef TclGetEnv #define TclGetEnv \ (tclIntStubsPtr->tclGetEnv) /* 138 */ #endif /* Slot 139 is reserved */ | < < | < | 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 | /* Slot 136 is reserved */ /* Slot 137 is reserved */ #ifndef TclGetEnv #define TclGetEnv \ (tclIntStubsPtr->tclGetEnv) /* 138 */ #endif /* Slot 139 is reserved */ /* Slot 140 is reserved */ #ifndef TclpGetCwd #define TclpGetCwd \ (tclIntStubsPtr->tclpGetCwd) /* 141 */ #endif #ifndef TclSetByteCodeFromAny #define TclSetByteCodeFromAny \ (tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */ |
︙ | ︙ | |||
1932 1933 1934 1935 1936 1937 1938 | #define TclInThreadExit \ (tclIntStubsPtr->tclInThreadExit) /* 172 */ #endif #ifndef TclUniCharMatch #define TclUniCharMatch \ (tclIntStubsPtr->tclUniCharMatch) /* 173 */ #endif | < < | < < < | < < < | < < < | < < < | < < < | < < < | < < < | < < < | < < < | < < < | < < < | < < < | < < < | < < < | < < < | < < < | < | 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 | #define TclInThreadExit \ (tclIntStubsPtr->tclInThreadExit) /* 172 */ #endif #ifndef TclUniCharMatch #define TclUniCharMatch \ (tclIntStubsPtr->tclUniCharMatch) /* 173 */ #endif /* Slot 174 is reserved */ #ifndef TclCallVarTraces #define TclCallVarTraces \ (tclIntStubsPtr->tclCallVarTraces) /* 175 */ #endif #ifndef TclCleanupVar #define TclCleanupVar \ (tclIntStubsPtr->tclCleanupVar) /* 176 */ #endif #ifndef TclVarErrMsg #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ #endif #ifndef Tcl_SetStartupScript #define Tcl_SetStartupScript \ (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */ #endif #ifndef Tcl_GetStartupScript #define Tcl_GetStartupScript \ (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */ #endif /* Slot 180 is reserved */ /* Slot 181 is reserved */ #ifndef TclpLocaltime #define TclpLocaltime \ (tclIntStubsPtr->tclpLocaltime) /* 182 */ #endif #ifndef TclpGmtime #define TclpGmtime \ (tclIntStubsPtr->tclpGmtime) /* 183 */ #endif /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ /* Slot 187 is reserved */ /* Slot 188 is reserved */ /* Slot 189 is reserved */ /* Slot 190 is reserved */ /* Slot 191 is reserved */ /* Slot 192 is reserved */ /* Slot 193 is reserved */ /* Slot 194 is reserved */ /* Slot 195 is reserved */ /* Slot 196 is reserved */ #ifndef TclCompEvalObj #define TclCompEvalObj \ (tclIntStubsPtr->tclCompEvalObj) /* 197 */ #endif #ifndef TclObjGetFrame #define TclObjGetFrame \ (tclIntStubsPtr->tclObjGetFrame) /* 198 */ #endif /* Slot 199 is reserved */ #ifndef TclpObjRemoveDirectory #define TclpObjRemoveDirectory \ (tclIntStubsPtr->tclpObjRemoveDirectory) /* 200 */ #endif #ifndef TclpObjCopyDirectory #define TclpObjCopyDirectory \ (tclIntStubsPtr->tclpObjCopyDirectory) /* 201 */ |
︙ | ︙ | |||
2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 | #define TclGetObjNameOfExecutable \ (tclIntStubsPtr->tclGetObjNameOfExecutable) /* 213 */ #endif #ifndef TclSetObjNameOfExecutable #define TclSetObjNameOfExecutable \ (tclIntStubsPtr->tclSetObjNameOfExecutable) /* 214 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLINTDECLS */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #define TclGetObjNameOfExecutable \ (tclIntStubsPtr->tclGetObjNameOfExecutable) /* 213 */ #endif #ifndef TclSetObjNameOfExecutable #define TclSetObjNameOfExecutable \ (tclIntStubsPtr->tclSetObjNameOfExecutable) /* 214 */ #endif #ifndef TclStackAlloc #define TclStackAlloc \ (tclIntStubsPtr->tclStackAlloc) /* 215 */ #endif #ifndef TclStackFree #define TclStackFree \ (tclIntStubsPtr->tclStackFree) /* 216 */ #endif #ifndef TclPushStackFrame #define TclPushStackFrame \ (tclIntStubsPtr->tclPushStackFrame) /* 217 */ #endif #ifndef TclPopStackFrame #define TclPopStackFrame \ (tclIntStubsPtr->tclPopStackFrame) /* 218 */ #endif #ifndef TclBN_mp_div_d #define TclBN_mp_div_d \ (tclIntStubsPtr->tclBN_mp_div_d) /* 219 */ #endif #ifndef TclBN_mp_mul_d #define TclBN_mp_mul_d \ (tclIntStubsPtr->tclBN_mp_mul_d) /* 220 */ #endif #ifndef TclBN_mp_clear #define TclBN_mp_clear \ (tclIntStubsPtr->tclBN_mp_clear) /* 221 */ #endif #ifndef TclBN_mp_init #define TclBN_mp_init \ (tclIntStubsPtr->tclBN_mp_init) /* 222 */ #endif #ifndef TclBN_mp_read_radix #define TclBN_mp_read_radix \ (tclIntStubsPtr->tclBN_mp_read_radix) /* 223 */ #endif #ifndef TclGetPlatform #define TclGetPlatform \ (tclIntStubsPtr->tclGetPlatform) /* 224 */ #endif #ifndef TclTraceDictPath #define TclTraceDictPath \ (tclIntStubsPtr->tclTraceDictPath) /* 225 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLINTDECLS */ |
Changes to generic/tclIntPlatDecls.h.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclIntPlatDecls.h -- * * This file contains the declarations for all platform dependent * unsupported functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. * * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclIntPlatDecls.h -- * * This file contains the declarations for all platform dependent * unsupported functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. * * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.26.2.1 2005/05/21 15:10:27 kennykb Exp $ */ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl |
︙ | ︙ | |||
245 246 247 248 249 250 251 | EXTERN char * TclpGetTZName _ANSI_ARGS_((int isdst)); #endif #ifndef TclWinNoBackslash_TCL_DECLARED #define TclWinNoBackslash_TCL_DECLARED /* 24 */ EXTERN char * TclWinNoBackslash _ANSI_ARGS_((char * path)); #endif | < < | < < | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 | EXTERN char * TclpGetTZName _ANSI_ARGS_((int isdst)); #endif #ifndef TclWinNoBackslash_TCL_DECLARED #define TclWinNoBackslash_TCL_DECLARED /* 24 */ EXTERN char * TclWinNoBackslash _ANSI_ARGS_((char * path)); #endif /* Slot 25 is reserved */ #ifndef TclWinSetInterfaces_TCL_DECLARED #define TclWinSetInterfaces_TCL_DECLARED /* 26 */ EXTERN void TclWinSetInterfaces _ANSI_ARGS_((int wide)); #endif #ifndef TclWinFlushDirtyChannels_TCL_DECLARED #define TclWinFlushDirtyChannels_TCL_DECLARED |
︙ | ︙ | |||
344 345 346 347 348 349 350 | TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 18 */ TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 19 */ void (*tclWinAddProcess) _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 20 */ void *reserved21; TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 22 */ char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */ char * (*tclWinNoBackslash) _ANSI_ARGS_((char * path)); /* 24 */ | | | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 | TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 18 */ TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 19 */ void (*tclWinAddProcess) _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 20 */ void *reserved21; TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 22 */ char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */ char * (*tclWinNoBackslash) _ANSI_ARGS_((char * path)); /* 24 */ void *reserved25; void (*tclWinSetInterfaces) _ANSI_ARGS_((int wide)); /* 26 */ void (*tclWinFlushDirtyChannels) _ANSI_ARGS_((void)); /* 27 */ void (*tclWinResetInterfaces) _ANSI_ARGS_((void)); /* 28 */ int (*tclWinCPUID) _ANSI_ARGS_((unsigned int index, unsigned int * regs)); /* 29 */ #endif /* __WIN32__ */ #ifdef MAC_OSX_TCL int (*tclMacOSXGetFileAttribute) _ANSI_ARGS_((Tcl_Interp * interp, int objIndex, Tcl_Obj * fileName, Tcl_Obj ** attributePtrPtr)); /* 15 */ |
︙ | ︙ | |||
516 517 518 519 520 521 522 | #define TclpGetTZName \ (tclIntPlatStubsPtr->tclpGetTZName) /* 23 */ #endif #ifndef TclWinNoBackslash #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ #endif | | < < < | 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 | #define TclpGetTZName \ (tclIntPlatStubsPtr->tclpGetTZName) /* 23 */ #endif #ifndef TclWinNoBackslash #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ #endif /* Slot 25 is reserved */ #ifndef TclWinSetInterfaces #define TclWinSetInterfaces \ (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */ #endif #ifndef TclWinFlushDirtyChannels #define TclWinFlushDirtyChannels \ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ |
︙ | ︙ |
Changes to generic/tclInterp.c.
|
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | /* * 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. * Copyright (c) 2004 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclInterp.c,v 1.54.2.3 2005/08/02 18:15:58 dgp Exp $ */ #include "tclInt.h" /* * A pointer to a string that holds an initialization script that if non-NULL * is evaluated in Tcl_Init() prior to the built-in initialization script * above. This variable can be modified by the procedure below. */ static char * tclPreInitScript = NULL; /* Forward declaration */ struct Target; /* * struct Alias: * * Stores information about an alias. Is stored in the slave interpreter and * used by the source command to find the target command in the master when * the source command is invoked. */ typedef struct Alias { Tcl_Obj *token; /* Token for the alias command in the slave * interp. This used to be the command name in * the slave when the alias was first * created. */ 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. */ struct Target *targetPtr; /* 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. */ 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 * interpreters. Maps from a command name in the master to information about a * slave interpreter, e.g. what aliases are defined in it. */ typedef struct Slave { Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ Tcl_HashEntry *slaveEntryPtr; /* Hash entry in masters slave table for this * slave interpreter. Used to find this * record, and used when deleting the slave * interpreter to delete it from the master's * table. */ Tcl_Interp *slaveInterp; /* The slave interpreter. */ Tcl_Command interpCmd; /* Interpreter object command. */ Tcl_HashTable aliasTable; /* Table which maps from names of commands in * slave interpreter to struct Alias defined * below. */ } Slave; /* * struct Target: * * Maps from master interpreter commands back to the source commands in slave * interpreters. This is needed because aliases can be created between sibling |
︙ | ︙ | |||
112 113 114 115 116 117 118 | struct Target *prevPtr; /* Previous in list of target records, or NULL * if at the start of the list of targets. */ } Target; /* * struct Master: * | | | | | | | | | | | | | | | 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 | struct Target *prevPtr; /* Previous in list of target records, or NULL * if at the start of the list of targets. */ } Target; /* * struct Master: * * This record is used for two purposes: First, slaveTable (a hashtable) maps * from names of commands to slave interpreters. This hashtable is used to * store information about slave interpreters of this interpreter, to map over * all slaves, etc. The second purpose is to store information about all * aliases in slaves (or siblings) which direct to target commands in this * interpreter (using the targetsPtr doubly-linked list). * * NB: the flags field in the interp structure, used with SAFE_INTERP mask * denotes whether the interpreter is safe or not. Safe interpreters have * restricted functionality, can only create safe slave interpreters and can * only load safe extensions. */ typedef struct Master { Tcl_HashTable slaveTable; /* Hash table for slave interpreters. Maps * from command names to Slave records. */ Target *targetsPtr; /* The head of a doubly-linked list of all the * target records which denote aliases from * slaves or sibling interpreters that direct * to commands in this interpreter. This list * is used to remove dangling pointers from * the slave (or sibling) interpreters when * this interpreter is deleted. */ |
︙ | ︙ | |||
150 151 152 153 154 155 156 | Master master; /* Keeps track of all interps for which this * interp is the Master. */ Slave slave; /* Information necessary for this interp to * function as a slave. */ } InterpInfo; /* | | | | | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | Master master; /* Keeps track of all interps for which this * interp is the Master. */ Slave slave; /* Information necessary for this interp to * function as a slave. */ } InterpInfo; /* * Limit callbacks handled by scripts are modelled as structures which are * stored in hashes indexed by a two-word key. Note that the type of the * 'type' field in the key is not int; this is to make sure that things are * likely to work properly on 64-bit architectures. */ struct ScriptLimitCallback { Tcl_Interp *interp; Tcl_Obj *scriptObj; int type; Tcl_HashEntry *entryPtr; |
︙ | ︙ | |||
181 182 183 184 185 186 187 | Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, Tcl_Obj *CONST objv[])); static int AliasDelete _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *namePtr)); static int AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *objPtr)); static int AliasList _ANSI_ARGS_((Tcl_Interp *interp, | | | | | | 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 | Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, Tcl_Obj *CONST objv[])); static int AliasDelete _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *namePtr)); static int AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *objPtr)); static int AliasList _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp)); static int AliasObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *currentInterp, int objc, Tcl_Obj *CONST objv[])); static void AliasObjCmdDeleteProc _ANSI_ARGS_(( ClientData clientData)); static Tcl_Interp * GetInterp _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); static Tcl_Interp * GetInterp2 _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void InterpInfoDeleteProc _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); static int SlaveBgerror _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *CONST objv[])); static Tcl_Interp * SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, int safe)); static int SlaveEval _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *CONST objv[])); static int SlaveExpose _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *CONST objv[])); static int SlaveHide _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *CONST objv[])); static int SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp)); static int SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, CONST char *namespaceName, int objc, Tcl_Obj *CONST objv[])); static int SlaveMarkTrusted _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp)); static int SlaveObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void SlaveObjCmdDeleteProc _ANSI_ARGS_(( |
︙ | ︙ | |||
242 243 244 245 246 247 248 249 250 251 252 253 254 255 | Tcl_Obj *scriptObj)); static void CallScriptLimitCallback _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); static void DeleteScriptLimitCallback _ANSI_ARGS_(( ClientData clientData)); static void RunLimitHandlers _ANSI_ARGS_((LimitHandler *handlerPtr, Tcl_Interp *interp)); /* *---------------------------------------------------------------------- * * TclSetPreInitScript -- * | > | | | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 | Tcl_Obj *scriptObj)); static void CallScriptLimitCallback _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); static void DeleteScriptLimitCallback _ANSI_ARGS_(( ClientData clientData)); static void RunLimitHandlers _ANSI_ARGS_((LimitHandler *handlerPtr, Tcl_Interp *interp)); static void TimeLimitCallback _ANSI_ARGS_((ClientData clientData)); /* *---------------------------------------------------------------------- * * TclSetPreInitScript -- * * This routine is used to change the value of the internal variable, * tclPreInitScript. * * Results: * Returns the current value of tclPreInitScript. * * Side effects: * Changes the way Tcl_Init() routine behaves. * |
︙ | ︙ | |||
275 276 277 278 279 280 281 | } /* *---------------------------------------------------------------------- * * Tcl_Init -- * | | | | | | | | < < < < > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | < < < < < | > | < | | | | < | < < < < < | | | | > < | | | | | | | | | | | > | > > > | > | | | < < > > > > | | < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_Init -- * * This procedure is typically invoked by Tcl_AppInit procedures to find * and source the "init.tcl" script, which should exist somewhere on the * Tcl library path. * * Results: * Returns a standard Tcl completion code and sets the interp's result if * there is an error. * * Side effects: * Depends on what's in the init.tcl script. * *---------------------------------------------------------------------- */ int Tcl_Init(interp) Tcl_Interp *interp; /* Interpreter to initialize. */ { if (tclPreInitScript != NULL) { if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { return (TCL_ERROR); }; } /* * In order to find init.tcl during initialization, the following script * is invoked by Tcl_Init(). It looks in several different directories: * * $tcl_library - can specify a primary location, if set, no * other locations will be checked. This is * the recommended way for a program that * embeds Tcl to specifically tell Tcl where to * find an init.tcl file. * * $env(TCL_LIBRARY) - highest priority so user can always override * the search path unless the application has * specified an exact directory above * * $tclDefaultLibrary - INTERNAL: This variable is set by Tcl * on those platforms where it can determine at * runtime the directory where it expects the * init.tcl file to be. After [tclInit] reads * and uses this value, it [unset]s it. * External users of Tcl should not make use of * the variable to customize [tclInit]. * * $tcl_libPath - OBSOLETE: This variable is no longer * set by Tcl itself, but [tclInit] examines it * in case some program that embeds Tcl is * customizing [tclInit] by setting this * variable to a list of directories in which * to search. * * [tcl::pkgconfig get scriptdir,runtime] * - the directory determined by configure to be * the place where Tcl's script library is to * be installed. * * The first directory on this path that contains a valid init.tcl script * will be set as the value of tcl_library. * * Note that this entire search mechanism can be bypassed by defining an * alternate tclInit procedure before calling Tcl_Init(). */ return Tcl_Eval(interp, "if {[info proc tclInit]==\"\"} {\n" " proc tclInit {} {\n" " global tcl_libPath tcl_library env tclDefaultLibrary\n" " rename tclInit {}\n" " if {[info exists tcl_library]} {\n" " set scripts {{set tcl_library}}\n" " } else {\n" " set scripts {}\n" " if {[info exists env(TCL_LIBRARY)] && ($env(TCL_LIBRARY) ne {})} {\n" " lappend scripts {set env(TCL_LIBRARY)}\n" " lappend scripts {\n" "if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail] == 0} continue\n" "if {$tail eq [info tclversion]} continue\n" "file join [file dirname $env(TCL_LIBRARY)] tcl[info tclversion]}\n" " }\n" " if {[info exists tclDefaultLibrary]} {\n" " lappend scripts {set tclDefaultLibrary}\n" " } else {\n" " lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n" " }\n" " lappend scripts {\n" "set parentDir [file dirname [file dirname [info nameofexecutable]]]\n" "set grandParentDir [file dirname $parentDir]\n" "file join $parentDir lib tcl[info tclversion]} \\\n" " {file join $grandParentDir lib tcl[info tclversion]} \\\n" " {file join $parentDir library} \\\n" " {file join $grandParentDir library} \\\n" " {file join $grandParentDir tcl[info patchlevel] library} \\\n" " {\n" "file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n" " if {[info exists tcl_libPath]\n" " && [catch {llength $tcl_libPath} len] == 0} {\n" " for {set i 0} {$i < $len} {incr i} {\n" " lappend scripts [list lindex \\$tcl_libPath $i]\n" " }\n" " }\n" " }\n" " set dirs {}\n" " set errors {}\n" " foreach script $scripts {\n" " lappend dirs [eval $script]\n" " set tcl_library [lindex $dirs end]\n" " set tclfile [file join $tcl_library init.tcl]\n" " if {[file exists $tclfile]} {\n" " if {[catch {uplevel #0 [list source $tclfile]} msg opts]} {\n" " append errors \"$tclfile: $msg\n\"\n" " append errors \"[dict get $opts -errorinfo]\n\"\n" " continue\n" " }\n" " unset -nocomplain tclDefaultLibrary\n" " return\n" " }\n" " }\n" " unset -nocomplain tclDefaultLibrary\n" " set msg \"Can't find a usable init.tcl in the following directories: \n\"\n" " append msg \" $dirs\n\n\"\n" " append msg \"$errors\n\n\"\n" " append msg \"This probably means that Tcl wasn't installed properly.\n\"\n" " error $msg\n" " }\n" "}\n" "tclInit"); } /* *--------------------------------------------------------------------------- * * TclInterpInit -- * * Initializes the invoking interpreter for using the master, slave and * safe interp facilities. This is called from inside * Tcl_CreateInterp(). * * Results: * Always returns TCL_OK for backwards compatibility. * * Side effects: * Adds the "interp" command to an interpreter and initializes the * interpInfoPtr field of the invoking interpreter. * *--------------------------------------------------------------------------- */ int TclInterpInit(interp) Tcl_Interp *interp; /* Interpreter to initialize. */ { InterpInfo *interpInfoPtr; Master *masterPtr; Slave *slavePtr; interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo)); ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr; masterPtr = &interpInfoPtr->master; Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS); masterPtr->targetsPtr = NULL; |
︙ | ︙ | |||
523 524 525 526 527 528 529 | } /* *--------------------------------------------------------------------------- * * InterpInfoDeleteProc -- * | | | | < | | 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 | } /* *--------------------------------------------------------------------------- * * InterpInfoDeleteProc -- * * Invoked when an interpreter is being deleted. It releases all storage * used by the master/slave/safe interpreter facilities. * * Results: * None. * * Side effects: * Cleans up storage. Sets the interpInfoPtr field of the interp to NULL. * *--------------------------------------------------------------------------- */ static void InterpInfoDeleteProc(clientData, interp) ClientData clientData; /* Ignored. */ Tcl_Interp *interp; /* Interp being deleted. All commands for * slave interps should already be deleted. */ { InterpInfo *interpInfoPtr; Slave *slavePtr; Master *masterPtr; Target *targetPtr; |
︙ | ︙ | |||
561 562 563 564 565 566 567 | if (masterPtr->slaveTable.numEntries != 0) { Tcl_Panic("InterpInfoDeleteProc: still exist commands"); } Tcl_DeleteHashTable(&masterPtr->slaveTable); /* * Tell any interps that have aliases to this interp that they should | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | if (masterPtr->slaveTable.numEntries != 0) { Tcl_Panic("InterpInfoDeleteProc: still exist commands"); } Tcl_DeleteHashTable(&masterPtr->slaveTable); /* * Tell any interps that have aliases to this interp that they should * delete those aliases. If the other interp was already dead, it would * have removed the target record already. */ for (targetPtr = masterPtr->targetsPtr; targetPtr != NULL; ) { Target *tmpPtr = targetPtr->nextPtr; Tcl_DeleteCommandFromToken(targetPtr->slaveInterp, targetPtr->slaveCmd); targetPtr = tmpPtr; } slavePtr = &interpInfoPtr->slave; if (slavePtr->interpCmd != NULL) { /* * Tcl_DeleteInterp() was called on this interpreter, rather "interp * delete" or the equivalent deletion of the command in the master. * First ensure that the cleanup callback doesn't try to delete the * interp again. */ slavePtr->slaveInterp = NULL; Tcl_DeleteCommandFromToken(slavePtr->masterInterp, slavePtr->interpCmd); } /* * There shouldn't be any aliases left. */ if (slavePtr->aliasTable.numEntries != 0) { Tcl_Panic("InterpInfoDeleteProc: still exist aliases"); } Tcl_DeleteHashTable(&slavePtr->aliasTable); ckfree((char *) interpInfoPtr); } /* *---------------------------------------------------------------------- * * Tcl_InterpObjCmd -- * * This procedure is invoked to process the "interp" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_InterpObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Unused. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int index; static CONST char *options[] = { "alias", "aliases", "bgerror", "create", "delete", "eval", "exists", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit","slaves", "share", "target", "transfer", NULL }; enum option { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CREATE, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum option) index) { case OPT_ALIAS: { Tcl_Interp *slaveInterp, *masterInterp; if (objc < 4) { aliasArgs: Tcl_WrongNumArgs(interp, 2, objv, "slavePath slaveCmd ?masterPath masterCmd? ?args ..?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); if (slaveInterp == (Tcl_Interp *) NULL) { return TCL_ERROR; } if (objc == 4) { return AliasDescribe(interp, slaveInterp, objv[3]); } if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) { return AliasDelete(interp, slaveInterp, objv[3]); } if (objc > 5) { masterInterp = GetInterp(interp, objv[4]); if (masterInterp == (Tcl_Interp *) NULL) { return TCL_ERROR; } if (Tcl_GetString(objv[5])[0] == '\0') { if (objc == 6) { return AliasDelete(interp, slaveInterp, objv[3]); } } else { return AliasCreate(interp, slaveInterp, masterInterp, objv[3], objv[5], objc - 6, objv + 6); } } goto aliasArgs; } case OPT_ALIASES: { Tcl_Interp *slaveInterp; slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } return AliasList(interp, slaveInterp); } case OPT_BGERROR: { Tcl_Interp *slaveInterp; if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); if (slaveInterp == NULL) { return TCL_ERROR; } return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); } case OPT_CREATE: { int i, last, safe; Tcl_Obj *slavePtr; char buf[16 + TCL_INTEGER_SPACE]; static CONST char *options[] = { "-safe", "--", NULL }; enum option { OPT_SAFE, OPT_LAST }; safe = Tcl_IsSafe(interp); /* * Weird historical rules: "-safe" is accepted at the end, too. */ slavePtr = NULL; last = 0; for (i = 2; i < objc; i++) { if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_SAFE) { safe = 1; continue; } i++; last = 1; } if (slavePtr != NULL) { Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); return TCL_ERROR; } if (i < objc) { slavePtr = objv[i]; } } buf[0] = '\0'; if (slavePtr == NULL) { /* * Create an anonymous interpreter -- we choose its name and the * name of the command. We check that the command name that we use * for the interpreter does not collide with an existing command * in the master interpreter. */ for (i = 0; ; i++) { Tcl_CmdInfo cmdInfo; sprintf(buf, "interp%d", i); if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { break; } } slavePtr = Tcl_NewStringObj(buf, -1); } if (SlaveCreate(interp, slavePtr, safe) == NULL) { if (buf[0] != '\0') { Tcl_DecrRefCount(slavePtr); } return TCL_ERROR; } Tcl_SetObjResult(interp, slavePtr); return TCL_OK; } case OPT_DELETE: { int i; InterpInfo *iiPtr; Tcl_Interp *slaveInterp; for (i = 2; i < objc; i++) { slaveInterp = GetInterp(interp, objv[i]); if (slaveInterp == NULL) { return TCL_ERROR; } else if (slaveInterp == interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot delete the current interpreter", -1)); return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, iiPtr->slave.interpCmd); } return TCL_OK; } case OPT_EVAL: { Tcl_Interp *slaveInterp; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); if (slaveInterp == NULL) { return TCL_ERROR; } return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); } case OPT_EXISTS: { int exists; Tcl_Interp *slaveInterp; exists = 1; slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { if (objc > 3) { return TCL_ERROR; } Tcl_ResetResult(interp); exists = 0; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); return TCL_OK; } case OPT_EXPOSE: { Tcl_Interp *slaveInterp; if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); if (slaveInterp == NULL) { return TCL_ERROR; } return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); } case OPT_HIDE: { Tcl_Interp *slaveInterp; /* A slave. */ if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); if (slaveInterp == (Tcl_Interp *) NULL) { return TCL_ERROR; } return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); } case OPT_HIDDEN: { Tcl_Interp *slaveInterp; /* A slave. */ slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } return SlaveHidden(interp, slaveInterp); } case OPT_ISSAFE: { Tcl_Interp *slaveInterp; slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); return TCL_OK; } case OPT_INVOKEHID: { int i, index; CONST char *namespaceName; Tcl_Interp *slaveInterp; static CONST char *hiddenOptions[] = { "-global", "-namespace", "--", NULL }; enum hiddenOption { OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST }; namespaceName = NULL; for (i = 3; i < objc; i++) { if (Tcl_GetString(objv[i])[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_GLOBAL) { namespaceName = "::"; } else if (index == OPT_NAMESPACE) { if (++i == objc) { /* There must be more arguments. */ break; } else { namespaceName = Tcl_GetString(objv[i]); } } else { i++; break; } } if (objc - i < 1) { Tcl_WrongNumArgs(interp, 2, objv, "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); if (slaveInterp == (Tcl_Interp *) NULL) { return TCL_ERROR; } return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, objv + i); } case OPT_LIMIT: { Tcl_Interp *slaveInterp; static CONST char *limitTypes[] = { "commands", "time", NULL }; enum LimitTypes { LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME }; int limitType; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); if (slaveInterp == NULL) { return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0, &limitType) != TCL_OK) { return TCL_ERROR; } switch ((enum LimitTypes) limitType) { case LIMIT_TYPE_COMMANDS: return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv); case LIMIT_TYPE_TIME: return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); } } case OPT_MARKTRUSTED: { Tcl_Interp *slaveInterp; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "path"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); if (slaveInterp == NULL) { return TCL_ERROR; } return SlaveMarkTrusted(interp, slaveInterp); } case OPT_RECLIMIT: { Tcl_Interp *slaveInterp; if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); if (slaveInterp == NULL) { return TCL_ERROR; } return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); } case OPT_SLAVES: { Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_Obj *resultPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch hashSearch; char *string; slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; resultPtr = Tcl_NewObj(); hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj(string, -1)); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } case OPT_SHARE: { Tcl_Interp *slaveInterp; /* A slave. */ Tcl_Interp *masterInterp; /* Its master. */ Tcl_Channel chan; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); return TCL_ERROR; } masterInterp = GetInterp(interp, objv[2]); if (masterInterp == NULL) { return TCL_ERROR; } chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL); if (chan == NULL) { TclTransferResult(masterInterp, TCL_OK, interp); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[4]); if (slaveInterp == NULL) { return TCL_ERROR; } Tcl_RegisterChannel(slaveInterp, chan); return TCL_OK; } case OPT_TARGET: { Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; char *aliasName; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path alias"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); if (slaveInterp == NULL) { return TCL_ERROR; } aliasName = Tcl_GetString(objv[3]); iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"", Tcl_GetString(objv[2]), "\" not found", (char *) NULL); return TCL_ERROR; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "target interpreter for alias \"", aliasName, "\" in path \"", Tcl_GetString(objv[2]), "\" is not my descendant", (char *) NULL); return TCL_ERROR; } return TCL_OK; } case OPT_TRANSFER: { Tcl_Interp *slaveInterp; /* A slave. */ Tcl_Interp *masterInterp; /* Its master. */ Tcl_Channel chan; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); return TCL_ERROR; } masterInterp = GetInterp(interp, objv[2]); if (masterInterp == NULL) { return TCL_ERROR; } chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL); if (chan == NULL) { TclTransferResult(masterInterp, TCL_OK, interp); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[4]); if (slaveInterp == NULL) { return TCL_ERROR; } Tcl_RegisterChannel(slaveInterp, chan); if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { TclTransferResult(masterInterp, TCL_OK, interp); return TCL_ERROR; } return TCL_OK; } } return TCL_OK; } /* *--------------------------------------------------------------------------- * * GetInterp2 -- * * Helper function for Tcl_InterpObjCmd() to convert the interp name * potentially specified on the command line to an Tcl_Interp. * * Results: * The return value is the interp specified on the command line, or the * interp argument itself if no interp was specified on the command line. * If the interp could not be found or the wrong number of arguments was * specified on the command line, the return value is NULL and an error * message is left in the interp's result. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static Tcl_Interp * GetInterp2(interp, objc, objv) Tcl_Interp *interp; /* Default interp if no interp was specified * on the command line. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { |
︙ | ︙ | |||
1160 1161 1162 1163 1164 1165 1166 | 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; | | | | | | 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 | 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); for (i = 0; i < argc; i++) { objv[i] = Tcl_NewStringObj(argv[i], -1); Tcl_IncrRefCount(objv[i]); } slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); Tcl_IncrRefCount(slaveObjPtr); targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, |
︙ | ︙ | |||
1236 1237 1238 1239 1240 1241 1242 | *---------------------------------------------------------------------- * * Tcl_GetAlias -- * * Gets information about an alias. * * Results: | | | | | | | | | | | 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 | *---------------------------------------------------------------------- * * Tcl_GetAlias -- * * Gets information about an alias. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int 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_AppendResult(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; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1308 1309 1310 1311 1312 1313 1314 | * None. * *---------------------------------------------------------------------- */ int Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | * None. * *---------------------------------------------------------------------- */ int Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, objvPtr) 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 *objcPtr; /* (Return) count of addnl args. */ Tcl_Obj ***objvPtr; /* (Return) additional args. */ { InterpInfo *iiPtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; int objc; Tcl_Obj **objv; iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == (Tcl_HashEntry *) NULL) { Tcl_AppendResult(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]); } if (objcPtr != (int *) NULL) { *objcPtr = objc - 1; } if (objvPtr != (Tcl_Obj ***) NULL) { *objvPtr = objv + 1; } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclPreventAliasLoop -- * * When defining an alias or renaming a command, prevent an alias loop * from being formed. * * Results: * A standard Tcl object result. * * Side effects: * If TCL_ERROR is returned, the function also stores an error message in * the interpreter's result object. * * NOTE: * This function is public internal (instead of being static to this * file) because it is also used from TclRenameCommand. * *---------------------------------------------------------------------- */ int TclPreventAliasLoop(interp, cmdInterp, cmd) Tcl_Interp *interp; /* Interp in which to report errors. */ Tcl_Interp *cmdInterp; /* Interp in which the command is * being defined. */ Tcl_Command cmd; /* Tcl command we are attempting to * define. */ { Command *cmdPtr = (Command *) cmd; Alias *aliasPtr, *nextAliasPtr; Tcl_Command aliasCmd; Command *aliasCmdPtr; /* * If we are not creating or renaming an alias, then it is always OK to * create or rename the command. */ if (cmdPtr->objProc != AliasObjCmd) { return TCL_OK; } /* * OK, we are dealing with an alias, so traverse the chain of aliases. 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. */ if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) { /* * The slave interpreter can be deleted while creating the alias. * [Bug #641195] */ Tcl_AppendResult(interp, "cannot define or rename alias \"", Tcl_GetCommandName(cmdInterp, cmd), "\": interpreter deleted", (char *) NULL); return TCL_ERROR; } 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) { Tcl_AppendResult(interp, "cannot define or rename alias \"", Tcl_GetCommandName(cmdInterp, cmd), "\": would create a loop", (char *) NULL); return TCL_ERROR; } /* * Otherwise, follow the chain one step further. See if the target * command is an alias - if so, follow the loop to its target command. * Otherwise we do not have a loop. */ if (aliasCmdPtr->objProc != AliasObjCmd) { return TCL_OK; } nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; } /* NOTREACHED */ } /* *---------------------------------------------------------------------- * * AliasCreate -- * * Helper function to do the work to actually create an alias. * * Results: * A standard Tcl result. * * Side effects: * An alias command is created and entered into the alias table for the * slave interpreter. * *---------------------------------------------------------------------- */ static int AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, objc, objv) |
︙ | ︙ | |||
1488 1489 1490 1491 1492 1493 1494 | Tcl_HashEntry *hPtr; Target *targetPtr; Slave *slavePtr; Master *masterPtr; Tcl_Obj **prefv; int new, i; | | | | 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 | Tcl_HashEntry *hPtr; Target *targetPtr; Slave *slavePtr; Master *masterPtr; Tcl_Obj **prefv; int new, i; aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) + objc * sizeof(Tcl_Obj *))); aliasPtr->token = namePtr; Tcl_IncrRefCount(aliasPtr->token); aliasPtr->targetInterp = masterInterp; aliasPtr->objc = objc + 1; prefv = &aliasPtr->objPtr; |
︙ | ︙ | |||
1514 1515 1516 1517 1518 1519 1520 | aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr, AliasObjCmdDeleteProc); if (TclPreventAliasLoop(interp, slaveInterp, aliasPtr->slaveCmd) != TCL_OK) { /* | | | | | 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 | 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->token); Tcl_DecrRefCount(targetNamePtr); 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); ckfree((char *) aliasPtr); |
︙ | ︙ | |||
1553 1554 1555 1556 1557 1558 1559 | * Make an entry in the alias table. If it already exists, retry. */ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; while (1) { Tcl_Obj *newToken; char *string; | | | | | | | | < | | | | | 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 | * Make an entry in the alias table. If it already exists, retry. */ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; while (1) { Tcl_Obj *newToken; char *string; string = Tcl_GetString(aliasPtr->token); hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new); if (new != 0) { break; } /* * The alias name cannot be used as unique token, it is already taken. * We can produce a unique token by prepending "::" repeatedly. This * algorithm is a stop-gap to try to maintain the command name as * token for most use cases, fearful of possible backwards compat * problems. A better algorithm would produce unique tokens that need * not be related to the command name. * * ATTENTION: the tests in interp.test and possibly safe.test depend * on the precise definition of these tokens. */ newToken = Tcl_NewStringObj("::",-1); Tcl_AppendObjToObj(newToken, aliasPtr->token); Tcl_DecrRefCount(aliasPtr->token); aliasPtr->token = newToken; Tcl_IncrRefCount(aliasPtr->token); } aliasPtr->aliasEntryPtr = hPtr; Tcl_SetHashValue(hPtr, (ClientData) aliasPtr); /* * Create the new command. We must do it after deleting any old command, * because the alias may be pointing at a renamed alias, as in: * * interp alias {} foo {} bar # Create an alias "foo" * rename foo zop # Now rename the alias * interp alias {} foo {} zop # Now recreate "foo"... |
︙ | ︙ | |||
1647 1648 1649 1650 1651 1652 1653 | * the original name (with which it was created) to find the alias to * delete it. */ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); if (hPtr == NULL) { | | | | | | | < | | | 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 | * the original name (with which it was created) to find the alias to * delete it. */ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); if (hPtr == NULL) { Tcl_AppendResult(interp, "alias \"", Tcl_GetString(namePtr), "\" not found", NULL); return TCL_ERROR; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); return TCL_OK; } /* *---------------------------------------------------------------------- * * AliasDescribe -- * * Sets the interpreter's result object to a Tcl list describing the * given alias in the given interpreter: its target command and the * additional arguments to prepend to any invocation of the alias. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int AliasDescribe(interp, slaveInterp, namePtr) 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; } |
︙ | ︙ | |||
1734 1735 1736 1737 1738 1739 1740 | Alias *aliasPtr; Slave *slavePtr; slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch); for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | Alias *aliasPtr; Slave *slavePtr; slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch); for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) { aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr); Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * AliasObjCmd -- * * This is the procedure that services invocations of aliases in a slave * interpreter. One such command exists for each alias. When invoked, * this procedure redirects the invocation to the target command in the * master interpreter as designated by the Alias record associated with * this command. * * Results: * A standard Tcl result. * * Side effects: * Causes forwarding of the invocation; all possible side effects may * occur as a result of invoking the command to which the invocation is * forwarded. * *---------------------------------------------------------------------- */ 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, i; Tcl_Obj **prefv, **cmdv; Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; aliasPtr = (Alias *) clientData; targetInterp = aliasPtr->targetInterp; /* * Append the arguments to the command prefix and invoke the command 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); for (i=0; i<cmdc; i++) { Tcl_IncrRefCount(cmdv[i]); } if (targetInterp != interp) { Tcl_Preserve((ClientData) targetInterp); result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE); TclTransferResult(targetInterp, result, interp); Tcl_Release((ClientData) targetInterp); } else { result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE); } for (i=0; i<cmdc; i++) { Tcl_DecrRefCount(cmdv[i]); } if (cmdv != cmdArr) { ckfree((char *) cmdv); } return result; #undef ALIAS_CMDV_PREALLOC } /* *---------------------------------------------------------------------- * * AliasObjCmdDeleteProc -- * * Is invoked when an alias command is deleted in a slave. Cleans up all * storage associated with this alias. * * Results: * None. * * Side effects: * Deletes the alias record and its entry in the alias table for the * interpreter. * *---------------------------------------------------------------------- */ 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->token); objv = &aliasPtr->objPtr; for (i = 0; i < aliasPtr->objc; i++) { Tcl_DecrRefCount(objv[i]); } Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr); |
︙ | ︙ | |||
1884 1885 1886 1887 1888 1889 1890 | } /* *---------------------------------------------------------------------- * * Tcl_CreateSlave -- * | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_CreateSlave -- * * Creates a slave interpreter. The slavePath argument denotes the name * of the new slave relative to the current interpreter; the slave is a * direct descendant of the one-before-last component of the path, * e.g. it is a descendant of the current interpreter if the slavePath * argument contains only one component. Optionally makes the slave * interpreter safe. * * Results: * Returns the interpreter structure created, or NULL if an error * occurred. * * Side effects: * Creates a new interpreter and a new interpreter object command in the * interpreter indicated by the slavePath argument. * *---------------------------------------------------------------------- */ Tcl_Interp * Tcl_CreateSlave(interp, slavePath, isSafe) Tcl_Interp *interp; /* Interpreter to start search at. */ |
︙ | ︙ | |||
1926 1927 1928 1929 1930 1931 1932 | *---------------------------------------------------------------------- * * Tcl_GetSlave -- * * Finds a slave interpreter by its path name. * * Results: | | < | 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 | *---------------------------------------------------------------------- * * Tcl_GetSlave -- * * Finds a slave interpreter by its path name. * * Results: * Returns a Tcl_Interp * for the named interpreter or NULL if not found. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1973 1974 1975 1976 1977 1978 1979 | Tcl_Interp * Tcl_GetMaster(interp) Tcl_Interp *interp; /* Get the master of this interpreter. */ { Slave *slavePtr; /* Slave record of this interpreter. */ if (interp == (Tcl_Interp *) NULL) { | | | | | < | | | | | | < | | | | < | | | | | | | | | | | | | | | | | | | 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 | Tcl_Interp * Tcl_GetMaster(interp) Tcl_Interp *interp; /* Get the master of this interpreter. */ { Slave *slavePtr; /* Slave record of this interpreter. */ if (interp == (Tcl_Interp *) NULL) { return NULL; } slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; return slavePtr->masterInterp; } /* *---------------------------------------------------------------------- * * Tcl_GetInterpPath -- * * Sets the result of the asking interpreter to a proper Tcl list * containing the names of interpreters between the asking and target * interpreters. The target interpreter must be either the same as the * asking interpreter or one of its slaves (including recursively). * * Results: * TCL_OK if the target interpreter is the same as, or a descendant of, * the asking interpreter; TCL_ERROR else. This way one can distinguish * between the case where the asking and target interps are the same (an * empty list is the result, and TCL_OK is returned) and when the target * is not a descendant of the asking interpreter (in which case the Tcl * result is an error message and the function returns TCL_ERROR). * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetInterpPath(askingInterp, targetInterp) Tcl_Interp *askingInterp; /* Interpreter to start search from. */ Tcl_Interp *targetInterp; /* Interpreter to find. */ { InterpInfo *iiPtr; if (targetInterp == askingInterp) { return TCL_OK; } if (targetInterp == NULL) { return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) { return TCL_ERROR; } Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&iiPtr->master.slaveTable, iiPtr->slave.slaveEntryPtr)); return TCL_OK; } /* *---------------------------------------------------------------------- * * GetInterp -- * * Helper function to find a slave interpreter given a pathname. * * Results: * Returns the slave interpreter known by that name in the calling * interpreter, or NULL if no interpreter known by that name exists. * * Side effects: * Assigns to the pointer variable passed in, if not NULL. * *---------------------------------------------------------------------- */ static Tcl_Interp * GetInterp(interp, pathPtr) Tcl_Interp *interp; /* Interp. to start search from. */ Tcl_Obj *pathPtr; /* List object containing name of interp. to * be found. */ { Tcl_HashEntry *hPtr; /* Search element. */ Slave *slavePtr; /* Interim slave record. */ Tcl_Obj **objv; int objc, i; Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ InterpInfo *masterInfoPtr; if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } searchInterp = interp; for (i = 0; i < objc; i++) { masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable, Tcl_GetString(objv[i])); if (hPtr == NULL) { searchInterp = NULL; break; } slavePtr = (Slave *) Tcl_GetHashValue(hPtr); searchInterp = slavePtr->slaveInterp; if (searchInterp == NULL) { break; } } if (searchInterp == NULL) { Tcl_AppendResult(interp, "could not find interpreter \"", Tcl_GetString(pathPtr), "\"", (char *) NULL); } return searchInterp; } /* *---------------------------------------------------------------------- * * SlaveBgerror -- * * Helper function to set/query the background error handling command * prefix of an interp * * Results: * A standard Tcl result. * * Side effects: * When (objc == 1), slaveInterp will be set to a new background handler * of objv[0]. * *---------------------------------------------------------------------- */ static int SlaveBgerror(interp, slaveInterp, objc, objv) Tcl_Interp *interp; /* Interp for error return. */ Tcl_Interp *slaveInterp; /* Interp in which limit is set/queried. */ int objc; /* Set or Query. */ Tcl_Obj *CONST objv[]; /* Argument strings. */ { if (objc) { int length; if (TCL_ERROR == Tcl_ListObjLength(NULL, objv[0], &length) || (length < 1)) { Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1", (char *) NULL); return TCL_ERROR; } TclSetBgErrorHandler(interp, objv[0]); } Tcl_SetObjResult(interp, TclGetBgErrorHandler(interp)); return TCL_OK; } /* *---------------------------------------------------------------------- * * SlaveCreate -- * * Helper function to do the actual work of creating a slave interp and * new object command. Also optionally makes the new slave interpreter * "safe". * * Results: * Returns the new Tcl_Interp * if successful or NULL if not. If failed, * the result of the invoking interpreter contains an error message. * * Side effects: * Creates a new slave interpreter and a new object command. |
︙ | ︙ | |||
2156 2157 2158 2159 2160 2161 2162 | Tcl_Interp *masterInterp, *slaveInterp; Slave *slavePtr; InterpInfo *masterInfoPtr; Tcl_HashEntry *hPtr; char *path; int new, objc; Tcl_Obj **objv; | < < | | | | | > | | | | | | | > | | > > | | > > | | | | | < | | | 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 | Tcl_Interp *masterInterp, *slaveInterp; Slave *slavePtr; InterpInfo *masterInfoPtr; Tcl_HashEntry *hPtr; char *path; int new, objc; Tcl_Obj **objv; if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } if (objc < 2) { masterInterp = interp; path = Tcl_GetString(pathPtr); } else { Tcl_Obj *objPtr; objPtr = Tcl_NewListObj(objc - 1, objv); masterInterp = GetInterp(interp, objPtr); Tcl_DecrRefCount(objPtr); if (masterInterp == NULL) { return NULL; } path = Tcl_GetString(objv[objc - 1]); } if (safe == 0) { safe = Tcl_IsSafe(masterInterp); } masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo; hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new); if (new == 0) { Tcl_AppendResult(interp, "interpreter named \"", path, "\" already exists, cannot create", (char *) NULL); return NULL; } slaveInterp = Tcl_CreateInterp(); slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, (ClientData) slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); /* * Inherit the recursion limit. */ ((Interp *) slaveInterp)->maxNestingDepth = ((Interp *) masterInterp)->maxNestingDepth; if (safe) { if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { goto error; } } else { if (Tcl_Init(slaveInterp) == TCL_ERROR) { goto error; } /* * This will create the "memory" command in slave interpreters if we * compiled with TCL_MEM_DEBUG, otherwise it does nothing. */ Tcl_InitMemory(slaveInterp); } /* * Inherit the TIP#143 limits. */ InheritLimitsFromMaster(slaveInterp, masterInterp); if (safe) { Tcl_Obj* clockObj = Tcl_NewStringObj("clock", -1); int status; Tcl_IncrRefCount(clockObj); status = AliasCreate(interp, slaveInterp, masterInterp, clockObj, clockObj, 0, (Tcl_Obj *CONST *) NULL); Tcl_DecrRefCount(clockObj); if (status != TCL_OK) { goto error2; } } return slaveInterp; error: TclTransferResult(slaveInterp, TCL_ERROR, interp); error2: Tcl_DeleteInterp(slaveInterp); return NULL; } /* *---------------------------------------------------------------------- * * SlaveObjCmd -- * * Command to manipulate an interpreter, e.g. to send commands to it to * be evaluated. One such command exists for each slave interpreter. * * Results: * A standard Tcl result. * * Side effects: * See user documentation for details. * |
︙ | ︙ | |||
2283 2284 2285 2286 2287 2288 2289 | "invokehidden", "limit", "marktrusted", "recursionlimit", NULL }; enum options { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT }; | | | | | | | | | | | | | | | | | | | < | < | | | | | | < | | | | | | < | | | | | | < | | | | | | < | | | | | | < | | | | | | < | | | | | | < | < | | | | | > | | | | | | | | | | | | | | | < | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | < | | | 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 | "invokehidden", "limit", "marktrusted", "recursionlimit", NULL }; enum options { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT }; slaveInterp = (Tcl_Interp *) clientData; if (slaveInterp == NULL) { Tcl_Panic("SlaveObjCmd: interpreter has been deleted"); } if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { case OPT_ALIAS: if (objc > 2) { if (objc == 3) { return AliasDescribe(interp, slaveInterp, objv[2]); } if (Tcl_GetString(objv[3])[0] == '\0') { if (objc == 4) { return AliasDelete(interp, slaveInterp, objv[2]); } } else { return AliasCreate(interp, slaveInterp, interp, objv[2], objv[3], objc - 4, objv + 4); } } Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?args..?"); return TCL_ERROR; case OPT_ALIASES: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); return TCL_ERROR; } return AliasList(interp, slaveInterp); case OPT_BGERROR: if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?"); return TCL_ERROR; } return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); case OPT_EVAL: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); return TCL_ERROR; } return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); case OPT_EXPOSE: if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); return TCL_ERROR; } return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); case OPT_HIDE: if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); return TCL_ERROR; } return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); case OPT_HIDDEN: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } return SlaveHidden(interp, slaveInterp); case OPT_ISSAFE: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); return TCL_OK; case OPT_INVOKEHIDDEN: { int i, index; CONST char *namespaceName; static CONST char *hiddenOptions[] = { "-global", "-namespace", "--", NULL }; enum hiddenOption { OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST }; namespaceName = NULL; for (i = 2; i < objc; i++) { if (Tcl_GetString(objv[i])[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_GLOBAL) { namespaceName = "::"; } else if (index == OPT_NAMESPACE) { if (++i == objc) { /* There must be more arguments. */ break; } else { namespaceName = Tcl_GetString(objv[i]); } } else { i++; break; } } if (objc - i < 1) { Tcl_WrongNumArgs(interp, 2, objv, "?-namespace ns? ?-global? ?--? cmd ?arg ..?"); return TCL_ERROR; } return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, objv + i); } case OPT_LIMIT: { static CONST char *limitTypes[] = { "commands", "time", NULL }; enum LimitTypes { LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME }; int limitType; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0, &limitType) != TCL_OK) { return TCL_ERROR; } switch ((enum LimitTypes) limitType) { case LIMIT_TYPE_COMMANDS: return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv); case LIMIT_TYPE_TIME: return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); } } case OPT_MARKTRUSTED: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } return SlaveMarkTrusted(interp, slaveInterp); case OPT_RECLIMIT: if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?"); return TCL_ERROR; } return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * SlaveObjCmdDeleteProc -- * * Invoked when an object command for a slave interpreter is deleted; * cleans up all state associated with the slave interpreter and destroys * the slave interpreter. * * Results: * None. * * Side effects: * Cleans up all state associated with the slave interpreter and destroys * the slave interpreter. * *---------------------------------------------------------------------- */ static void SlaveObjCmdDeleteProc(clientData) ClientData clientData; /* The SlaveRecord for the command. */ |
︙ | ︙ | |||
2489 2490 2491 2492 2493 2494 2495 | /* * Unlink the slave from its master interpreter. */ Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr); /* | | | | | 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 | /* * Unlink the slave from its master interpreter. */ Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr); /* * Set to NULL so that when the InterpInfo is cleaned up in the slave it * does not try to delete the command causing all sorts of grief. See * SlaveRecordDeleteProc(). */ slavePtr->interpCmd = NULL; if (slavePtr->slaveInterp != NULL) { Tcl_DeleteInterp(slavePtr->slaveInterp); } |
︙ | ︙ | |||
2527 2528 2529 2530 2531 2532 2533 | Tcl_Interp *slaveInterp; /* The slave interpreter in which command * will be evaluated. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result; Tcl_Obj *objPtr; | | | 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 | Tcl_Interp *slaveInterp; /* The slave interpreter in which command * will be evaluated. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result; Tcl_Obj *objPtr; Tcl_Preserve((ClientData) slaveInterp); Tcl_AllowExceptions(slaveInterp); if (objc == 1) { result = Tcl_EvalObjEx(slaveInterp, objv[0], 0); } else { objPtr = Tcl_ConcatObj(objc, objv); |
︙ | ︙ | |||
2556 2557 2558 2559 2560 2561 2562 | * * Helper function to expose a command in a slave interpreter. * * Results: * A standard Tcl result. * * Side effects: | | | | | 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 | * * Helper function to expose a command in a slave interpreter. * * Results: * A standard Tcl result. * * Side effects: * After this call scripts in the slave will be able to invoke the newly * exposed command. * *---------------------------------------------------------------------- */ static int SlaveExpose(interp, slaveInterp, objc, objv) Tcl_Interp *interp; /* Interp for error return. */ Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument strings. */ { char *name; if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot expose commands", -1)); return TCL_ERROR; } |
︙ | ︙ | |||
2598 2599 2600 2601 2602 2603 2604 | * * Helper function to set/query the Recursion limit of an interp * * Results: * A standard Tcl result. * * Side effects: | | | | 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 | * * Helper function to set/query the Recursion limit of an interp * * Results: * A standard Tcl result. * * Side effects: * When (objc == 1), slaveInterp will be set to a new recursion limit of * objv[0]. * *---------------------------------------------------------------------- */ static int SlaveRecursionLimit(interp, slaveInterp, objc, objv) Tcl_Interp *interp; /* Interp for error return. */ |
︙ | ︙ | |||
2637 2638 2639 2640 2641 2642 2643 | iPtr = (Interp *) slaveInterp; if (interp == slaveInterp && iPtr->numLevels > limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); return TCL_ERROR; } Tcl_SetObjResult(interp, objv[0]); | | | | | | | < | 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 | iPtr = (Interp *) slaveInterp; if (interp == slaveInterp && iPtr->numLevels > limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); return TCL_ERROR; } Tcl_SetObjResult(interp, objv[0]); return TCL_OK; } else { limit = Tcl_SetRecursionLimit(slaveInterp, 0); Tcl_SetObjResult(interp, Tcl_NewIntObj(limit)); return TCL_OK; } } /* *---------------------------------------------------------------------- * * SlaveHide -- * * Helper function to hide a command in a slave interpreter. * * Results: * A standard Tcl result. * * Side effects: * After this call scripts in the slave will no longer be able to invoke * the named command. * *---------------------------------------------------------------------- */ static int SlaveHide(interp, slaveInterp, objc, objv) Tcl_Interp *interp; /* Interp for error return. */ Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument strings. */ { char *name; if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot hide commands", -1)); return TCL_ERROR; } name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]); if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]), name) != TCL_OK) { TclTransferResult(slaveInterp, TCL_ERROR, interp); return TCL_ERROR; } return TCL_OK; } /* |
︙ | ︙ | |||
2713 2714 2715 2716 2717 2718 2719 | Tcl_Interp *interp; /* Interp for data return. */ Tcl_Interp *slaveInterp; /* Interp whose hidden commands to query. */ { Tcl_Obj *listObjPtr = Tcl_NewObj(); /* Local object pointer. */ Tcl_HashTable *hTblPtr; /* For local searches. */ Tcl_HashEntry *hPtr; /* For local searches. */ Tcl_HashSearch hSearch; /* For local searches. */ | | | | < | 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 | Tcl_Interp *interp; /* Interp for data return. */ Tcl_Interp *slaveInterp; /* Interp whose hidden commands to query. */ { Tcl_Obj *listObjPtr = Tcl_NewObj(); /* Local object pointer. */ Tcl_HashTable *hTblPtr; /* For local searches. */ Tcl_HashEntry *hPtr; /* For local searches. */ Tcl_HashSearch hSearch; /* For local searches. */ hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr; if (hTblPtr != (Tcl_HashTable *) NULL) { for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != (Tcl_HashEntry *) NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { Tcl_ListObjAppendElement(NULL, listObjPtr, Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); } } Tcl_SetObjResult(interp, listObjPtr); return TCL_OK; } |
︙ | ︙ | |||
2747 2748 2749 2750 2751 2752 2753 | * *---------------------------------------------------------------------- */ static int SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc, objv) Tcl_Interp *interp; /* Interp for error return. */ | | | | | | | | | | | | | 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 | * *---------------------------------------------------------------------- */ static int SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc, objv) Tcl_Interp *interp; /* Interp for error return. */ Tcl_Interp *slaveInterp; /* The slave interpreter in which command will * be invoked. */ CONST char *namespaceName; /* The namespace to use, if any. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result; if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "not allowed to invoke hidden commands from safe interpreter", -1)); return TCL_ERROR; } Tcl_Preserve((ClientData) slaveInterp); Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); } else { Namespace *nsPtr, *dummy1, *dummy2; CONST char *tail; result = TclGetNamespaceForQualName(slaveInterp, namespaceName, (Namespace *) NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if (result == TCL_OK) { result = TclObjInvokeNamespace(slaveInterp, objc, objv, (Tcl_Namespace *)nsPtr, TCL_INVOKE_HIDDEN); } } TclTransferResult(slaveInterp, result, interp); Tcl_Release((ClientData) slaveInterp); return result; } /* *---------------------------------------------------------------------- * * SlaveMarkTrusted -- * * Helper function to mark a slave interpreter as trusted (unsafe). * * Results: * A standard Tcl result. * * Side effects: * After this call the hard-wired security checks in the core no longer * prevent the slave from performing certain operations. * *---------------------------------------------------------------------- */ static int SlaveMarkTrusted(interp, slaveInterp) Tcl_Interp *interp; /* Interp for error return. */ Tcl_Interp *slaveInterp; /* The slave interpreter which will be marked * trusted. */ { if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot mark trusted", -1)); return TCL_ERROR; } |
︙ | ︙ | |||
2843 2844 2845 2846 2847 2848 2849 | int Tcl_IsSafe(interp) Tcl_Interp *interp; /* Is this interpreter "safe" ? */ { Interp *iPtr; if (interp == (Tcl_Interp *) NULL) { | | | | | | | < | | | | | | | | | | | < | | | | | | | 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 | int Tcl_IsSafe(interp) Tcl_Interp *interp; /* Is this interpreter "safe" ? */ { Interp *iPtr; if (interp == (Tcl_Interp *) NULL) { return 0; } iPtr = (Interp *) interp; return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ; } /* *---------------------------------------------------------------------- * * Tcl_MakeSafe -- * * Makes its argument interpreter contain only functionality that is * defined to be part of Safe Tcl. Unsafe commands are hidden, the env * array is unset, and the standard channels are removed. * * Results: * None. * * Side effects: * Hides commands in its argument interpreter, and removes settings and * channels. * *---------------------------------------------------------------------- */ int Tcl_MakeSafe(interp) Tcl_Interp *interp; /* Interpreter to be made safe. */ { Tcl_Channel chan; /* Channel to remove from safe interpreter. */ Interp *iPtr = (Interp *) interp; TclHideUnsafeCommands(interp); iPtr->flags |= SAFE_INTERP; /* * Unsetting variables : (which should not have been set in the first * place, but...) */ /* * No env array in a safe slave. */ Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); /* * Remove unsafe parts of tcl_platform */ Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY); Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY); Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY); Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY); /* * Unset path informations variables (the only one remaining is [info * nameofexecutable]) */ Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY); Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY); /* * Remove the standard channels from the interpreter; safe interpreters do * not ordinarily have access to stdin, stdout and stderr. * * NOTE: These channels are not added to the interpreter by the * Tcl_CreateInterp call, but may be added later, by another I/O * operation. We want to ensure that the interpreter does not have these * channels even if it is being made safe after being used for some time.. */ chan = Tcl_GetStdChannel(TCL_STDIN); if (chan != (Tcl_Channel) NULL) { Tcl_UnregisterChannel(interp, chan); } chan = Tcl_GetStdChannel(TCL_STDOUT); if (chan != (Tcl_Channel) NULL) { Tcl_UnregisterChannel(interp, chan); } chan = Tcl_GetStdChannel(TCL_STDERR); if (chan != (Tcl_Channel) NULL) { Tcl_UnregisterChannel(interp, chan); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LimitExceeded -- * * Tests whether any limit has been exceeded in the given interpreter * (i.e. whether the interpreter is currently unable to process further * scripts). * * Results: * A boolean value. * * Side effects: * None. * |
︙ | ︙ | |||
2969 2970 2971 2972 2973 2974 2975 | } /* *---------------------------------------------------------------------- * * Tcl_LimitReady -- * | | | | | 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 | } /* *---------------------------------------------------------------------- * * Tcl_LimitReady -- * * Find out whether any limit has been set on the interpreter, and if so * check whether the granularity of that limit is such that the full * limit check should be carried out. * * Results: * A boolean value that indicates whether to call Tcl_LimitCheck. * * Side effects: * Increments the limit granularity counter. * |
︙ | ︙ | |||
2993 2994 2995 2996 2997 2998 2999 | register Interp *iPtr = (Interp *) interp; if (iPtr->limit.active != 0) { register int ticker = ++iPtr->limit.granularityTicker; if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) && ((iPtr->limit.cmdGranularity == 1) || | | | | | | | | | | | | | | 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 | register Interp *iPtr = (Interp *) interp; if (iPtr->limit.active != 0) { register int ticker = ++iPtr->limit.granularityTicker; if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) && ((iPtr->limit.cmdGranularity == 1) || (ticker % iPtr->limit.cmdGranularity == 0))) { return 1; } if ((iPtr->limit.active & TCL_LIMIT_TIME) && ((iPtr->limit.timeGranularity == 1) || (ticker % iPtr->limit.timeGranularity == 0))) { return 1; } } return 0; } /* *---------------------------------------------------------------------- * * Tcl_LimitCheck -- * * Check all currently set limits in the interpreter (where permitted by * granularity). If a limit is exceeded, call its callbacks and, if the * limit is still exceeded after the callbacks have run, make the * interpreter generate an error that cannot be caught within the limited * interpreter. * * Results: * A Tcl result value (TCL_OK if no limit is exceeded, and TCL_ERROR if a * limit has been exceeded). * * Side effects: * May invoke system calls. May invoke other interpreters. May be * reentrant. May put the interpreter into a state where it can no longer * execute commands without outside intervention. * *---------------------------------------------------------------------- */ int Tcl_LimitCheck(interp) Tcl_Interp *interp; |
︙ | ︙ | |||
3059 3060 3061 3062 3063 3064 3065 | return TCL_ERROR; } Tcl_Release(interp); } if ((iPtr->limit.active & TCL_LIMIT_TIME) && ((iPtr->limit.timeGranularity == 1) || | | | | 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 | return TCL_ERROR; } Tcl_Release(interp); } if ((iPtr->limit.active & TCL_LIMIT_TIME) && ((iPtr->limit.timeGranularity == 1) || (ticker % iPtr->limit.timeGranularity == 0))) { Tcl_Time now; Tcl_GetTime(&now); if (iPtr->limit.time.sec < now.sec || (iPtr->limit.time.sec == now.sec && iPtr->limit.time.usec < now.usec)) { iPtr->limit.exceeded |= TCL_LIMIT_TIME; Tcl_Preserve(interp); RunLimitHandlers(iPtr->limit.timeHandlers, interp); if (iPtr->limit.time.sec > now.sec || (iPtr->limit.time.sec == now.sec && iPtr->limit.time.usec >= now.usec)) { iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "time limit exceeded", NULL); Tcl_Release(interp); |
︙ | ︙ | |||
3091 3092 3093 3094 3095 3096 3097 | } /* *---------------------------------------------------------------------- * * RunLimitHandlers -- * | | | | | | > | | | | | | | | | | > | 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 | } /* *---------------------------------------------------------------------- * * RunLimitHandlers -- * * Invoke all the limit handlers in a list (for a particular limit). * Note that no particular limit handler callback will be invoked * reentrantly. * * Results: * None. * * Side effects: * Depends on the limit handlers. * *---------------------------------------------------------------------- */ static void RunLimitHandlers(handlerPtr, interp) LimitHandler *handlerPtr; Tcl_Interp *interp; { LimitHandler *nextPtr; for (; handlerPtr!=NULL ; handlerPtr=nextPtr) { if (handlerPtr->flags & (LIMIT_HANDLER_DELETED|LIMIT_HANDLER_ACTIVE)) { /* * Reentrant call or something seriously strange in the delete * code. */ nextPtr = handlerPtr->nextPtr; continue; } /* * Set the ACTIVE flag while running the limit handler itself so we * cannot reentrantly call this handler and know to use the alternate * method of deletion if necessary. */ handlerPtr->flags |= LIMIT_HANDLER_ACTIVE; (handlerPtr->handlerProc)(handlerPtr->clientData, interp); handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE; /* * Rediscover this value; it might have changed during the processing * of a limit handler. We have to record it here because we might * delete the structure below, and reading a value out of a deleted * structure is unsafe (even if actually legal with some * malloc()/free() implementations.) */ nextPtr = handlerPtr->nextPtr; /* * If we deleted the current handler while we were executing it, we * will have spliced it out of the list and set the * LIMIT_HANDLER_DELETED flag. */ if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { if (handlerPtr->deleteProc != NULL) { (handlerPtr->deleteProc)(handlerPtr->clientData); } ckfree((char *) handlerPtr); } } |
︙ | ︙ | |||
3239 3240 3241 3242 3243 3244 3245 | * * Remove a callback handler for a particular resource limit. * * Results: * None. * * Side effects: | | | | | | 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 | * * Remove a callback handler for a particular resource limit. * * Results: * None. * * Side effects: * The handler is spliced out of the internal linked list for the limit, * and if not currently being invoked, deleted. Otherwise it is just * marked for deletion and removed when the limit handler has finished * executing. * *---------------------------------------------------------------------- */ void Tcl_LimitRemoveHandler(interp, type, handlerProc, clientData) Tcl_Interp *interp; |
︙ | ︙ | |||
3276 3277 3278 3279 3280 3281 3282 | for (; handlerPtr!=NULL ; handlerPtr=handlerPtr->nextPtr) { if ((handlerPtr->handlerProc != handlerProc) || (handlerPtr->clientData != clientData)) { continue; } /* | | | | 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 | for (; handlerPtr!=NULL ; handlerPtr=handlerPtr->nextPtr) { if ((handlerPtr->handlerProc != handlerProc) || (handlerPtr->clientData != clientData)) { continue; } /* * We've found the handler to delete; mark it as doomed if not already * so marked (which shouldn't actually happen). */ if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { return; } handlerPtr->flags |= LIMIT_HANDLER_DELETED; |
︙ | ︙ | |||
3306 3307 3308 3309 3310 3311 3312 | handlerPtr->prevPtr->nextPtr = handlerPtr->nextPtr; } if (handlerPtr->nextPtr != NULL) { handlerPtr->nextPtr->prevPtr = handlerPtr->prevPtr; } /* | | | | | | | 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 | handlerPtr->prevPtr->nextPtr = handlerPtr->nextPtr; } if (handlerPtr->nextPtr != NULL) { handlerPtr->nextPtr->prevPtr = handlerPtr->prevPtr; } /* * If nothing is currently executing the handler, delete its client * data and the overall handler structure now. Otherwise it will all * go away when the handler returns. */ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { (handlerPtr->deleteProc)(handlerPtr->clientData); } ckfree((char *) handlerPtr); } return; } } /* *---------------------------------------------------------------------- * * TclLimitRemoveAllHandlers -- * * Remove all limit callback handlers for an interpreter. This is invoked * as part of deleting the interpreter. * * Results: * None. * * Side effects: * Limit handlers are deleted or marked for deletion (as with * Tcl_LimitRemoveHandler). |
︙ | ︙ | |||
3366 3367 3368 3369 3370 3371 3372 | continue; } handlerPtr->flags |= LIMIT_HANDLER_DELETED; handlerPtr->prevPtr = NULL; handlerPtr->nextPtr = NULL; /* | | | | | 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 | continue; } handlerPtr->flags |= LIMIT_HANDLER_DELETED; handlerPtr->prevPtr = NULL; handlerPtr->nextPtr = NULL; /* * If nothing is currently executing the handler, delete its client * data and the overall handler structure now. Otherwise it will all * go away when the handler returns. */ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { (handlerPtr->deleteProc)(handlerPtr->clientData); } ckfree((char *) handlerPtr); |
︙ | ︙ | |||
3399 3400 3401 3402 3403 3404 3405 | continue; } handlerPtr->flags |= LIMIT_HANDLER_DELETED; handlerPtr->prevPtr = NULL; handlerPtr->nextPtr = NULL; /* | | | | > > > > > > > > > > | < | 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 | continue; } handlerPtr->flags |= LIMIT_HANDLER_DELETED; handlerPtr->prevPtr = NULL; handlerPtr->nextPtr = NULL; /* * If nothing is currently executing the handler, delete its client * data and the overall handler structure now. Otherwise it will all * go away when the handler returns. */ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { (handlerPtr->deleteProc)(handlerPtr->clientData); } ckfree((char *) handlerPtr); } } /* * Delete the timer callback that is used to trap limits that occur in * [vwait]s... */ if (iPtr->limit.timeEvent != NULL) { Tcl_DeleteTimerHandler(iPtr->limit.timeEvent); iPtr->limit.timeEvent = NULL; } } /* *---------------------------------------------------------------------- * * Tcl_LimitTypeEnabled -- * * Check whether a particular limit has been enabled for an interpreter. * * Results: * A boolean value. * * Side effects: * None. * |
︙ | ︙ | |||
3445 3446 3447 3448 3449 3450 3451 | } /* *---------------------------------------------------------------------- * * Tcl_LimitTypeExceeded -- * | | < | | | 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 | } /* *---------------------------------------------------------------------- * * Tcl_LimitTypeExceeded -- * * Check whether a particular limit has been exceeded for an interpreter. * * Results: * A boolean value (note that Tcl_LimitExceeded will always return * non-zero when this function returns non-zero). * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
3479 3480 3481 3482 3483 3484 3485 | * * Enable a particular limit for an interpreter. * * Results: * None. * * Side effects: | | | | | 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 | * * Enable a particular limit for an interpreter. * * Results: * None. * * Side effects: * The limit is turned on and will be checked in future at an interval * determined by the frequency of calling of Tcl_LimitReady and the * granularity of the limit in question. * *---------------------------------------------------------------------- */ void Tcl_LimitTypeSet(interp, type) Tcl_Interp *interp; |
︙ | ︙ | |||
3507 3508 3509 3510 3511 3512 3513 | * * Disable a particular limit for an interpreter. * * Results: * None. * * Side effects: | | | | | | 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 | * * Disable a particular limit for an interpreter. * * Results: * None. * * Side effects: * The limit is disabled. If the limit was exceeded when this function * was called, the limit will no longer be exceeded afterwards and the * interpreter will be free to execute further scripts (assuming it isn't * also deleted, of course). * *---------------------------------------------------------------------- */ void Tcl_LimitTypeReset(interp, type) Tcl_Interp *interp; |
︙ | ︙ | |||
3537 3538 3539 3540 3541 3542 3543 | * * Set the command limit for an interpreter. * * Results: * None. * * Side effects: | | | | < | | | 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 | * * Set the command limit for an interpreter. * * Results: * None. * * Side effects: * Also resets whether the command limit was exceeded. This might permit * a small amount of further execution in the interpreter even if the * limit itself is theoretically exceeded. * *---------------------------------------------------------------------- */ void Tcl_LimitSetCommands(interp, commandLimit) Tcl_Interp *interp; int commandLimit; { Interp *iPtr = (Interp *) interp; iPtr->limit.cmdCount = commandLimit; iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; } /* *---------------------------------------------------------------------- * * Tcl_LimitGetCommands -- * * Get the number of commands that may be executed in the interpreter * before the command-limit is reached. * * Results: * An upper bound on the number of commands. * * Side effects: * None. * |
︙ | ︙ | |||
3587 3588 3589 3590 3591 3592 3593 | } /* *---------------------------------------------------------------------- * * Tcl_LimitSetTime -- * | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_LimitSetTime -- * * Set the time limit for an interpreter by copying it from the value * pointed to by the timeLimitPtr argument. * * Results: * None. * * Side effects: * Also resets whether the time limit was exceeded. This might permit a * small amount of further execution in the interpreter even if the limit * itself is theoretically exceeded. * *---------------------------------------------------------------------- */ void Tcl_LimitSetTime(interp, timeLimitPtr) Tcl_Interp *interp; Tcl_Time *timeLimitPtr; { Interp *iPtr = (Interp *) interp; Tcl_Time nextMoment; memcpy(&iPtr->limit.time, timeLimitPtr, sizeof(Tcl_Time)); if (iPtr->limit.timeEvent != NULL) { Tcl_DeleteTimerHandler(iPtr->limit.timeEvent); } nextMoment.sec = timeLimitPtr->sec; nextMoment.usec = timeLimitPtr->usec+10; if (nextMoment.usec >= 1000000) { nextMoment.sec++; nextMoment.usec -= 1000000; } iPtr->limit.timeEvent = TclCreateAbsoluteTimerHandler(&nextMoment, TimeLimitCallback, (ClientData) interp); iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; } /* *---------------------------------------------------------------------- * * TimeLimitCallback -- * * Callback that allows time limits to be enforced even when doing a * blocking wait for events. * * Results: * None. * * Side effects: * May put the interpreter into a state where it can no longer execute * commands. May make callbacks into other interpreters. * *---------------------------------------------------------------------- */ static void TimeLimitCallback(clientData) ClientData clientData; { Tcl_Interp *interp = (Tcl_Interp *) clientData; Tcl_Preserve((ClientData) interp); ((Interp *)interp)->limit.timeEvent = NULL; if (Tcl_LimitCheck(interp) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (while waiting for event)"); Tcl_BackgroundError(interp); } Tcl_Release((ClientData) interp); } /* *---------------------------------------------------------------------- * * Tcl_LimitGetTime -- * * Get the current time limit. * * Results: * The time limit (by it being copied into the variable pointed to by the * timeLimitPtr). * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
3644 3645 3646 3647 3648 3649 3650 | } /* *---------------------------------------------------------------------- * * Tcl_LimitSetGranularity -- * | | | | 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 | } /* *---------------------------------------------------------------------- * * Tcl_LimitSetGranularity -- * * Set the granularity divisor (which must be positive) for a particular * limit. * * Results: * None. * * Side effects: * The granularity is updated. * |
︙ | ︙ | |||
3709 3710 3711 3712 3713 3714 3715 | case TCL_LIMIT_COMMANDS: return iPtr->limit.cmdGranularity; case TCL_LIMIT_TIME: return iPtr->limit.timeGranularity; } Tcl_Panic("unknown type of resource limit"); return -1; /* NOT REACHED */ | | | | < | | | 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 | case TCL_LIMIT_COMMANDS: return iPtr->limit.cmdGranularity; case TCL_LIMIT_TIME: return iPtr->limit.timeGranularity; } Tcl_Panic("unknown type of resource limit"); return -1; /* NOT REACHED */ } /* *---------------------------------------------------------------------- * * DeleteScriptLimitCallback -- * * Callback for when a script limit (a limit callback implemented as a * Tcl script in a master interpreter, as set up from Tcl) is deleted. * * Results: * None. * * Side effects: * The reference to the script callback from the controlling interpreter * is removed. * *---------------------------------------------------------------------- */ static void DeleteScriptLimitCallback(clientData) ClientData clientData; |
︙ | ︙ | |||
3747 3748 3749 3750 3751 3752 3753 | } /* *---------------------------------------------------------------------- * * CallScriptLimitCallback -- * | | | | | | 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 | } /* *---------------------------------------------------------------------- * * CallScriptLimitCallback -- * * Invoke a script limit callback. Used to implement limit callbacks set * at the Tcl level on child interpreters. * * Results: * None. * * Side effects: * Depends on the callback script. Errors are reported as background * errors. * *---------------------------------------------------------------------- */ static void CallScriptLimitCallback(clientData, interp) ClientData clientData; |
︙ | ︙ | |||
3786 3787 3788 3789 3790 3791 3792 | } /* *---------------------------------------------------------------------- * * SetScriptLimitCallback -- * | | | | < | | | | | 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 | } /* *---------------------------------------------------------------------- * * SetScriptLimitCallback -- * * Install (or remove, if scriptObj is NULL) a limit callback script that * is called when the target interpreter exceeds the type of limit * specified. Each interpreter may only have one callback set on another * interpreter through this mechanism (though as many interpreters may be * limited as the programmer chooses overall). * * Results: * None. * * Side effects: * A limit callback implemented as an invokation of a Tcl script in * another interpreter is either installed or removed. * *---------------------------------------------------------------------- */ static void SetScriptLimitCallback(interp, type, targetInterp, scriptObj) Tcl_Interp *interp; |
︙ | ︙ | |||
3857 3858 3859 3860 3861 3862 3863 | } /* *---------------------------------------------------------------------- * * TclRemoveScriptLimitCallbacks -- * | | | | | < | 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 | } /* *---------------------------------------------------------------------- * * TclRemoveScriptLimitCallbacks -- * * Remove all script-implemented limit callbacks that make calls back * into the given interpreter. This invoked as part of deleting an * interpreter. * * Results: * None. * * Side effects: * The script limit callbacks are removed or marked for later removal. * *---------------------------------------------------------------------- */ void TclRemoveScriptLimitCallbacks(interp) Tcl_Interp *interp; |
︙ | ︙ | |||
3896 3897 3898 3899 3900 3901 3902 | } /* *---------------------------------------------------------------------- * * TclInitLimitSupport -- * | | | | < | 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 | } /* *---------------------------------------------------------------------- * * TclInitLimitSupport -- * * Initialise all the parts of the interpreter relating to resource limit * management. This allows an interpreter to both have limits set upon * itself and set limits upon other interpreters. * * Results: * None. * * Side effects: * The resource limit subsystem is initialised for the interpreter. * |
︙ | ︙ | |||
3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 | iPtr->limit.granularityTicker = 0; iPtr->limit.exceeded = 0; iPtr->limit.cmdCount = 0; iPtr->limit.cmdHandlers = NULL; iPtr->limit.cmdGranularity = 1; memset(&iPtr->limit.time, 0, sizeof(Tcl_Time)); iPtr->limit.timeHandlers = NULL; iPtr->limit.timeGranularity = 10; Tcl_InitHashTable(&iPtr->limit.callbacks, sizeof(struct ScriptLimitCallbackKey)/sizeof(int)); } /* *---------------------------------------------------------------------- * * InheritLimitsFromMaster -- * | > | | | | | | | 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 | iPtr->limit.granularityTicker = 0; iPtr->limit.exceeded = 0; iPtr->limit.cmdCount = 0; iPtr->limit.cmdHandlers = NULL; iPtr->limit.cmdGranularity = 1; memset(&iPtr->limit.time, 0, sizeof(Tcl_Time)); iPtr->limit.timeHandlers = NULL; iPtr->limit.timeEvent = NULL; iPtr->limit.timeGranularity = 10; Tcl_InitHashTable(&iPtr->limit.callbacks, sizeof(struct ScriptLimitCallbackKey)/sizeof(int)); } /* *---------------------------------------------------------------------- * * InheritLimitsFromMaster -- * * Derive the interpreter limit configuration for a slave interpreter * from the limit config for the master. * * Results: * None. * * Side effects: * The slave interpreter limits are set so that if the master has a * limit, it may not exceed it by handing off work to slave interpreters. * Note that this does not transfer limit callbacks from the master to * the slave. * *---------------------------------------------------------------------- */ static void InheritLimitsFromMaster(slaveInterp, masterInterp) Tcl_Interp *slaveInterp, *masterInterp; |
︙ | ︙ | |||
4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 | Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), limitCBPtr->scriptObj); } else { goto putEmptyCommandInDict; } } else { Tcl_Obj *empty; putEmptyCommandInDict: TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, | > | 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 | Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), limitCBPtr->scriptObj); } else { goto putEmptyCommandInDict; } } else { Tcl_Obj *empty; putEmptyCommandInDict: TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, |
︙ | ︙ | |||
4147 4148 4149 4150 4151 4152 4153 | } /* *---------------------------------------------------------------------- * * SlaveTimeLimitCmd -- * | | | < | 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 | } /* *---------------------------------------------------------------------- * * SlaveTimeLimitCmd -- * * Implementation of the [interp limit $i time] and [$i limit time] * subcommands. See the interp manual page for a full description. * * Results: * A standard Tcl result. * * Side effects: * Depends on the arguments. * |
︙ | ︙ | |||
4338 4339 4340 4341 4342 4343 4344 | limitMoment.sec = tmp; break; } } if (milliObj != NULL || secObj != NULL) { if (milliObj != NULL) { /* | | | < > | | < > > > > > > > > > | 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 | limitMoment.sec = tmp; break; } } if (milliObj != NULL || secObj != NULL) { if (milliObj != NULL) { /* * Setting -milliseconds but clearing -seconds, or resetting * -milliseconds but not resetting -seconds? Bad voodoo! */ if (secObj != NULL && secLen == 0 && milliLen > 0) { Tcl_AppendResult(interp, "may only set -milliseconds ", "if -seconds is not also being reset", NULL); return TCL_ERROR; } if (milliLen == 0 && (secObj == NULL || secLen > 0)) { Tcl_AppendResult(interp, "may only reset -milliseconds ", "if -seconds is also being reset", NULL); return TCL_ERROR; } } if (milliLen > 0 || secLen > 0) { /* * Force usec to be in range [0..1000000), possibly * incrementing sec in the process. This makes it much easier * for people to write scripts that do small time increments. */ limitMoment.sec += limitMoment.usec / 1000000; limitMoment.usec %= 1000000; Tcl_LimitSetTime(slaveInterp, &limitMoment); Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_TIME); } else { Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_TIME); } } if (scriptObj != NULL) { SetScriptLimitCallback(interp, TCL_LIMIT_TIME, slaveInterp, (scriptLen > 0 ? scriptObj : NULL)); } if (granObj != NULL) { Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran); } return TCL_OK; } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclLink.c.
|
| | | | | | < | | | | | | | | | | > > > | > > > > > > | | | | | | < | < | | | | | | < | | | | | | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | /* * tclLink.c -- * * This file implements linked variables (a C variable that is tied to a * Tcl variable). The idea of linked variables was first suggested by * Andreas Stolcke and this implementation is based heavily on a * prototype implementation provided by him. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclLink.c,v 1.8.6.5 2005/09/09 18:48:40 dgp Exp $ */ #include "tclInt.h" /* * For each linked variable there is a data structure of the following type, * which describes the link and is the clientData for the trace set on the Tcl * variable. */ typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ Tcl_Obj *varName; /* Name of variable (must be global). This is * needed during trace callbacks, since the * actual variable may be aliased at that time * via upvar. */ char *addr; /* Location of C variable. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { char c; unsigned char uc; int i; unsigned int ui; short s; unsigned short us; long l; unsigned long ul; Tcl_WideInt w; Tcl_WideUInt uw; float f; double d; } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ int flags; /* Miscellaneous one-bit values; see below for * definitions. */ } Link; /* * Definitions for flag bits: * LINK_READ_ONLY - 1 means errors should be generated if Tcl * script attempts to write variable. * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar is * in progress for this variable, so trace * callbacks on the variable should be ignored. */ #define LINK_READ_ONLY 1 #define LINK_BEING_UPDATED 2 /* * Forward references to procedures defined later in this file: */ static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); /* *---------------------------------------------------------------------- * * Tcl_LinkVar -- * * Link a C variable to a Tcl variable so that changes to either one * causes the other to change. * * Results: * The return value is TCL_OK if everything went well or TCL_ERROR if an * error occurred (the interp's result is also set after errors). * * Side effects: * The value at *addr is linked to the Tcl variable "varName", using * "type" to convert between string values for Tcl and binary values for * *addr. * *---------------------------------------------------------------------- */ 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; Link *linkPtr; int code; linkPtr = (Link *) ckalloc(sizeof(Link)); linkPtr->interp = interp; |
︙ | ︙ | |||
135 136 137 138 139 140 141 | * * Destroy the link between a Tcl variable and a C variable. * * Results: * None. * * Side effects: | | | | | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 | * * Destroy the link between a Tcl variable and a C variable. * * Results: * None. * * Side effects: * If "varName" was previously linked to a C variable, the link is broken * to make the variable independent. If there was no previous link for * "varName" then nothing happens. * *---------------------------------------------------------------------- */ 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) { |
︙ | ︙ | |||
166 167 168 169 170 171 172 | } /* *---------------------------------------------------------------------- * * Tcl_UpdateLinkedVar -- * | | | | | | | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 | } /* *---------------------------------------------------------------------- * * Tcl_UpdateLinkedVar -- * * This procedure is invoked after a linked variable has been changed by * C code. It updates the Tcl variable so that traces on the variable * will trigger. * * Results: * None. * * Side effects: * The Tcl variable "varName" is updated from its C value, causing traces * on the variable to trigger. * *---------------------------------------------------------------------- */ void Tcl_UpdateLinkedVar(interp, varName) Tcl_Interp *interp; /* Interpreter containing variable. */ |
︙ | ︙ | |||
205 206 207 208 209 210 211 | } /* *---------------------------------------------------------------------- * * LinkTraceProc -- * | | | | | | | | | | | > > > | | | | | < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | < < < < < | < | < | < | < | | > > | > > > | | > > > > > > | > > > | > > > > | > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < | | | | | | 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 | } /* *---------------------------------------------------------------------- * * LinkTraceProc -- * * This procedure is invoked when a linked Tcl variable is read, written, * or unset from Tcl. It's responsible for keeping the C variable in sync * with the Tcl variable. * * Results: * If all goes well, NULL is returned; otherwise an error message is * returned. * * Side effects: * The C variable may be updated to make it consistent with the Tcl * variable, or the Tcl variable may be overwritten to reject a * modification. * *---------------------------------------------------------------------- */ 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; Tcl_Obj *valueObj; int valueInt; Tcl_WideInt valueWide; double valueDouble; /* * If the variable is being unset, then just re-create it (with a trace) * unless the whole interpreter is going away. */ if (flags & TCL_TRACE_UNSETS) { if (flags & TCL_INTERP_DESTROYED) { Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName), TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES |TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); } return NULL; } /* * If we were invoked because of a call to Tcl_UpdateLinkedVar, then don't * do anything at all. In particular, we don't want to get upset that the * variable is being modified, even if it is supposed to be read-only. */ if (linkPtr->flags & LINK_BEING_UPDATED) { return NULL; } /* * For read accesses, update the Tcl variable if the C variable has * changed since the last time we updated the Tcl variable. */ if (flags & TCL_TRACE_READS) { switch (linkPtr->type) { case TCL_LINK_INT: case TCL_LINK_BOOLEAN: changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i; break; case TCL_LINK_DOUBLE: changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d; break; case TCL_LINK_WIDE_INT: changed = *(Tcl_WideInt *)(linkPtr->addr) != linkPtr->lastValue.w; break; case TCL_LINK_WIDE_UINT: changed = *(Tcl_WideUInt *)(linkPtr->addr) != linkPtr->lastValue.uw; break; case TCL_LINK_CHAR: changed = *(char *)(linkPtr->addr) != linkPtr->lastValue.c; break; case TCL_LINK_UCHAR: changed = *(unsigned char *)(linkPtr->addr) != linkPtr->lastValue.uc; break; case TCL_LINK_SHORT: changed = *(short *)(linkPtr->addr) != linkPtr->lastValue.s; break; case TCL_LINK_USHORT: changed = *(unsigned short *)(linkPtr->addr) != linkPtr->lastValue.us; break; case TCL_LINK_UINT: changed = *(unsigned int *)(linkPtr->addr) != linkPtr->lastValue.ui; break; case TCL_LINK_LONG: changed = *(long *)(linkPtr->addr) != linkPtr->lastValue.l; break; case TCL_LINK_ULONG: changed = *(unsigned long *)(linkPtr->addr) != linkPtr->lastValue.ul; break; case TCL_LINK_FLOAT: changed = *(float *)(linkPtr->addr) != linkPtr->lastValue.f; break; case TCL_LINK_STRING: changed = 1; break; default: return "internal error: bad linked variable type"; } if (changed) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); } return NULL; } /* * For writes, first make sure that the variable is writable. Then convert * the Tcl value to C if possible. If the variable isn't writable or can't * be converted, then restore the varaible's old value and return an * error. Another tricky thing: we have to save and restore the interp's * result, since the variable access could occur when the result has been * partially set. */ if (linkPtr->flags & LINK_READ_ONLY) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "linked variable is read-only"; } valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY); if (valueObj == NULL) { /* * This shouldn't ever happen. */ return "internal error: linked variable couldn't be read"; } switch (linkPtr->type) { case TCL_LINK_INT: if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have integer value"; } *(int *)(linkPtr->addr) = linkPtr->lastValue.i; break; case TCL_LINK_WIDE_INT: if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have integer value"; } *(Tcl_WideInt *)(linkPtr->addr) = linkPtr->lastValue.w; break; case TCL_LINK_DOUBLE: if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { #ifdef ACCEPT_NAN if (valueObj->typePtr != &tclDoubleType) { #endif Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have real value"; #ifdef ACCEPT_NAN } linkPtr->lastValue.d = valueObj->internalRep.doubleValue; #endif } *(double *)(linkPtr->addr) = linkPtr->lastValue.d; break; case TCL_LINK_BOOLEAN: if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have boolean value"; } *(int *)(linkPtr->addr) = linkPtr->lastValue.i; break; case TCL_LINK_CHAR: if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have char value"; } linkPtr->lastValue.c = (char)valueInt; *(char *)(linkPtr->addr) = linkPtr->lastValue.c; break; case TCL_LINK_UCHAR: if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK || valueInt < 0 || valueInt > UCHAR_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have unsigned char value"; } linkPtr->lastValue.uc = (unsigned char) valueInt; *(unsigned char *)(linkPtr->addr) = linkPtr->lastValue.uc; break; case TCL_LINK_SHORT: if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK || valueInt < SHRT_MIN || valueInt > SHRT_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have short value"; } linkPtr->lastValue.s = (short)valueInt; *(short *)(linkPtr->addr) = linkPtr->lastValue.s; break; case TCL_LINK_USHORT: if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK || valueInt < 0 || valueInt > USHRT_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have unsigned short value"; } linkPtr->lastValue.us = (unsigned short)valueInt; *(unsigned short *)(linkPtr->addr) = linkPtr->lastValue.us; break; case TCL_LINK_UINT: if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK || valueWide < 0 || valueWide > UINT_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have unsigned int value"; } linkPtr->lastValue.ui = (unsigned int)valueWide; *(unsigned int *)(linkPtr->addr) = linkPtr->lastValue.ui; break; case TCL_LINK_LONG: if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK || valueWide < LONG_MIN || valueWide > LONG_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have long value"; } linkPtr->lastValue.l = (long)valueWide; *(long *)(linkPtr->addr) = linkPtr->lastValue.l; break; case TCL_LINK_ULONG: if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK || valueWide < 0 || valueWide > ULONG_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have unsigned long value"; } linkPtr->lastValue.ul = (unsigned long)valueWide; *(unsigned long *)(linkPtr->addr) = linkPtr->lastValue.ul; break; case TCL_LINK_WIDE_UINT: /* * FIXME: represent as a bignum. */ if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have unsigned wide int value"; } linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide; *(Tcl_WideUInt *)(linkPtr->addr) = linkPtr->lastValue.uw; break; case TCL_LINK_FLOAT: if (Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK || valueDouble < FLT_MIN || valueDouble > FLT_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have float value"; } linkPtr->lastValue.f = (float)valueDouble; *(float *)(linkPtr->addr) = linkPtr->lastValue.f; break; case TCL_LINK_STRING: value = Tcl_GetStringFromObj(valueObj, &valueLength); valueLength++; pp = (char **)(linkPtr->addr); if (*pp != NULL) { ckfree(*pp); } *pp = (char *) ckalloc((unsigned) valueLength); memcpy(*pp, value, (unsigned) valueLength); break; default: return "internal error: bad linked variable type"; } return NULL; } /* *---------------------------------------------------------------------- * * ObjValue -- * * Converts the value of a C variable to a Tcl_Obj* for use in a Tcl * variable to which it is linked. * * Results: * The return value is a pointer to a Tcl_Obj that represents the value * of the C variable given by linkPtr. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 | return Tcl_NewWideIntObj(linkPtr->lastValue.w); case TCL_LINK_DOUBLE: linkPtr->lastValue.d = *(double *)(linkPtr->addr); return Tcl_NewDoubleObj(linkPtr->lastValue.d); case TCL_LINK_BOOLEAN: linkPtr->lastValue.i = *(int *)(linkPtr->addr); return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0); case TCL_LINK_STRING: p = *(char **)(linkPtr->addr); if (p == NULL) { return Tcl_NewStringObj("NULL", 4); } return Tcl_NewStringObj(p, -1); /* | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > | 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 | return Tcl_NewWideIntObj(linkPtr->lastValue.w); case TCL_LINK_DOUBLE: linkPtr->lastValue.d = *(double *)(linkPtr->addr); return Tcl_NewDoubleObj(linkPtr->lastValue.d); case TCL_LINK_BOOLEAN: linkPtr->lastValue.i = *(int *)(linkPtr->addr); return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0); case TCL_LINK_CHAR: linkPtr->lastValue.c = *(char *)(linkPtr->addr); return Tcl_NewIntObj(linkPtr->lastValue.c); case TCL_LINK_UCHAR: linkPtr->lastValue.uc = *(unsigned char *)(linkPtr->addr); return Tcl_NewIntObj(linkPtr->lastValue.uc); case TCL_LINK_SHORT: linkPtr->lastValue.s = *(short *)(linkPtr->addr); return Tcl_NewIntObj(linkPtr->lastValue.s); case TCL_LINK_USHORT: linkPtr->lastValue.us = *(unsigned short *)(linkPtr->addr); return Tcl_NewIntObj(linkPtr->lastValue.us); case TCL_LINK_UINT: linkPtr->lastValue.ui = *(unsigned int *)(linkPtr->addr); return Tcl_NewWideIntObj(linkPtr->lastValue.ui); case TCL_LINK_LONG: linkPtr->lastValue.l = *(long *)(linkPtr->addr); return Tcl_NewWideIntObj(linkPtr->lastValue.l); case TCL_LINK_ULONG: linkPtr->lastValue.ul = *(unsigned long *)(linkPtr->addr); return Tcl_NewWideIntObj(linkPtr->lastValue.ul); case TCL_LINK_FLOAT: linkPtr->lastValue.f = *(float *)(linkPtr->addr); return Tcl_NewDoubleObj(linkPtr->lastValue.f); case TCL_LINK_WIDE_UINT: linkPtr->lastValue.uw = *(Tcl_WideUInt *)(linkPtr->addr); /* * FIXME: represent as a bignum. */ return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); case TCL_LINK_STRING: p = *(char **)(linkPtr->addr); if (p == NULL) { return Tcl_NewStringObj("NULL", 4); } return Tcl_NewStringObj(p, -1); /* * This code only gets executed if the link type is unknown (shouldn't * ever happen). */ default: return Tcl_NewStringObj("??", 2); } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclListObj.c.
|
| | | < | | | | > | < | | < | | | | | | | | | < | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | /* * tclListObj.c -- * * This file contains functions that implement the Tcl list object type. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclListObj.c,v 1.20.2.4 2005/09/09 18:48:40 dgp Exp $ */ #include "tclInt.h" /* * Prototypes for functions defined later in this file: */ static List * NewListIntRep(int objc, Tcl_Obj *CONST objv[]); static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeListInternalRep(Tcl_Obj *listPtr); static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfList(Tcl_Obj *listPtr); /* * The structure below defines the list Tcl object type by means of functions * that can be invoked by generic object code. * * The internal representation of a list object is a two-pointer * representation. The first pointer designates a List structure that contains * an array of pointers to the element objects, together with integers that * represent the current element count and the allocated size of the array. * The second pointer is normally NULL; during execution of functions in this * file that operate on nested sublists, it is occasionally used as working * storage to avoid an auxiliary stack. */ Tcl_ObjType tclListType = { "list", /* name */ FreeListInternalRep, /* freeIntRepProc */ DupListInternalRep, /* dupIntRepProc */ UpdateStringOfList, /* updateStringProc */ NULL /* setFromAnyProc */ }; /* *---------------------------------------------------------------------- * * NewListIntRep -- * * If objc>0 and objv!=NULL, this function creates a list internal rep * with objc elements given in the array objv. * If objc>0 and objv==NULL it creates the list internal rep of a list * with 0 elements, where enough space has been preallocated to store * objc elements. * If objc<=0, it returns NULL. * * Results: * A new List struct is returned. If objc<=0 or if the allocation fails * for lack of memory, NULL is returned. The list returned has refCount * 0. * * Side effects: * The ref counts of the elements in objv are incremented since the * resulting list now refers to them. * *---------------------------------------------------------------------- */ static List* NewListIntRep(objc, objv) int objc; Tcl_Obj *CONST objv[]; { Tcl_Obj **elemPtrs; List *listRepPtr; int i; if (objc <= 0) { return NULL; } /* * First check to see if we'd overflow and try to allocate an object * larger than our memory allocator allows. Note that this is actually a * fairly small value when you're on a serious 64-bit machine, but that * requires API changes to fix. */ if (objc > INT_MAX/sizeof(Tcl_Obj *)) { return NULL; } listRepPtr = (List *) attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))); if (listRepPtr == NULL) { return NULL; } listRepPtr->canonicalFlag = 0; listRepPtr->refCount = 0; listRepPtr->maxElemCount = objc; if (objv) { listRepPtr->elemCount = objc; elemPtrs = &listRepPtr->elements; for (i = 0; i < objc; i++) { elemPtrs[i] = objv[i]; Tcl_IncrRefCount(elemPtrs[i]); } } else { listRepPtr->elemCount = 0; } return listRepPtr; } /* *---------------------------------------------------------------------- * * Tcl_NewListObj -- * * This function is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new list object from an * (objc,objv) array: that is, each of the objc elements of the array * referenced by objv is inserted as an element into a new Tcl object. * * When TCL_MEM_DEBUG is defined, this function just returns the result * of calling the debugging version Tcl_DbNewListObj. * * Results: * A new list object is returned that is initialized from the object * pointers in objv. If objc is less than or equal to zero, an empty * object is returned. The new object's string representation is left * NULL. The resulting new list object has ref count 0. * * Side effects: * The ref counts of the elements in objv are incremented since the * resulting list now refers to them. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
89 90 91 92 93 94 95 | #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewListObj(objc, objv) int objc; /* Count of objects referenced by objv. */ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ { | < < | < > | | | | > > > | | | | | < > | < < > > | | | > | | | | | | | | | | | | < | < | | | | > > > | | | | | < > | < < > > | | | > | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | < | < | | < < < < < < | < | < < > | > | | | | | | | | | | | | | | > > > > > > > > > | | | | | | | | | < | | | | | < < < | | | | | | | | | | | | | | | > > > > > > > > | < | | > | | > > > > > > > > | | > > > | > | | > > | > | | > > | | > | | > | | | | | | | | | | | | > > > > > > > > | | | | | | | | | > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > | | | | | > > | | | > > > > | > | | | | | | | < < < < < < < < < < < < < < < | | > > > > | > > > | > > > > | > > > > > | > > | | > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | > > > > | | < | | | | | < < > | < > | > | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < < < > | | | | | | | | > | < < < | < < < | < < < < < < | < < < < < < < < < | < < < < < < < < < | < < < | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < < < < | < < | < < < < < < < < < < < < < < | < < < < | < < < | < < < | < < | | < < | < | < < < < < < < < < < < < | < < < < < < < < | | | | | < | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | 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 | #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewListObj(objc, objv) int objc; /* Count of objects referenced by objv. */ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ { List *listRepPtr; Tcl_Obj *listPtr; TclNewObj(listPtr); if (objc <= 0) { return listPtr; } /* * Create the internal rep. */ listRepPtr = NewListIntRep(objc, objv); if (!listRepPtr) { Tcl_Panic("Not enough memory to create the list\n"); } /* * Now create the object. */ Tcl_InvalidateStringRep(listPtr); listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; listPtr->internalRep.twoPtrValue.ptr2 = NULL; listPtr->typePtr = &tclListType; listRepPtr->refCount++; return listPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_DbNewListObj -- * * This function is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same * as the Tcl_NewListObj function above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] * command will report the correct file name and line number when * reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this function just returns the * result of calling Tcl_NewListObj. * * Results: * A new list object is returned that is initialized from the object * pointers in objv. If objc is less than or equal to zero, an empty * object is returned. The new object's string representation is left * NULL. The new list object has ref count 0. * * Side effects: * The ref counts of the elements in objv are incremented since the * resulting list now refers to them. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewListObj(objc, objv, file, line) int objc; /* Count of objects referenced by objv. */ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ CONST char *file; /* The name of the source file calling this * function; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ { Tcl_Obj *listPtr; List *listRepPtr; TclDbNewObj(listPtr, file, line); if (objc <= 0) { return listPtr; } /* * Create the internal rep. */ listRepPtr = NewListIntRep(objc, objv); if (!listRepPtr) { Tcl_Panic("Not enough memory to create the list\n"); } /* * Now create the object. */ Tcl_InvalidateStringRep(listPtr); listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; listPtr->internalRep.twoPtrValue.ptr2 = NULL; listPtr->typePtr = &tclListType; listRepPtr->refCount++; return listPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewListObj(objc, objv, file, line) int objc; /* Count of objects referenced by objv. */ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ CONST char *file; /* The name of the source file calling this * function; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ { return Tcl_NewListObj(objc, objv); } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetListObj -- * * Modify an object to be a list containing each of the objc elements of * the object array referenced by objv. * * Results: * None. * * Side effects: * The object is made a list object and is initialized from the object * pointers in objv. If objc is less than or equal to zero, an empty * object is returned. The new object's string representation is left * NULL. The ref counts of the elements in objv are incremented since the * list now refers to them. The object's old string and internal * representations are freed and its type is set NULL. * *---------------------------------------------------------------------- */ void Tcl_SetListObj(objPtr, objc, objv) Tcl_Obj *objPtr; /* Object whose internal rep to init. */ int objc; /* Count of objects referenced by objv. */ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ { List *listRepPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetListObj called with shared object"); } /* * Free any old string rep and any internal rep for the old type. */ TclFreeIntRep(objPtr); objPtr->typePtr = NULL; Tcl_InvalidateStringRep(objPtr); /* * Set the object's type to "list" and initialize the internal rep. * However, if there are no elements to put in the list, just give the * object an empty string rep and a NULL type. */ if (objc > 0) { listRepPtr = NewListIntRep(objc, objv); if (!listRepPtr) { Tcl_Panic("Cannot allocate enough memory for Tcl_SetListObj"); } objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclListType; listRepPtr->refCount++; } else { objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; } } /* *---------------------------------------------------------------------- * * Tcl_ListObjGetElements -- * * This function returns an (objc,objv) array of the elements in a list * object. * * Results: * The return value is normally TCL_OK; in this case *objcPtr is set to * the count of list elements and *objvPtr is set to a pointer to an * array of (*objcPtr) pointers to each list element. If listPtr does not * refer to a list object and the object can not be converted to one, * TCL_ERROR is returned and an error message will be left in the * interpreter's result if interp is not NULL. * * The objects referenced by the returned array should be treated as * readonly and their ref counts are _not_ incremented; the caller must * do that if it holds on to a reference. Furthermore, the pointer and * length returned by this function may change as soon as any function is * called on the list object; be careful about retaining the pointer in a * local data structure. * * Side effects: * The possible conversion of the object referenced by listPtr * to a list object. * *---------------------------------------------------------------------- */ int Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) Tcl_Interp *interp; /* Used to report errors if not NULL. */ register Tcl_Obj *listPtr; /* List object for which an element array is * to be returned. */ int *objcPtr; /* Where to store the count of objects * referenced by objv. */ Tcl_Obj ***objvPtr; /* Where to store the pointer to an array of * pointers to the list's objects. */ { register List *listRepPtr; if (listPtr->typePtr != &tclListType) { int result, length; (void) Tcl_GetStringFromObj(listPtr, &length); if (!length) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendList -- * * This function appends the objects in the list referenced by * elemListPtr to the list object referenced by listPtr. If listPtr is * not already a list object, an attempt will be made to convert it to * one. * * Results: * The return value is normally TCL_OK. If listPtr or elemListPtr do not * refer to list objects and they can not be converted to one, TCL_ERROR * is returned and an error message is left in the interpreter's result * if interp is not NULL. * * Side effects: * The reference counts of the elements in elemListPtr are incremented * since the list now refers to them. listPtr and elemListPtr are * converted, if necessary, to list objects. Also, appending the new * elements may cause listObj's array of element pointers to grow. * listPtr's old string representation, if any, is invalidated. * *---------------------------------------------------------------------- */ int Tcl_ListObjAppendList(interp, listPtr, elemListPtr) Tcl_Interp *interp; /* Used to report errors if not NULL. */ register Tcl_Obj *listPtr; /* List object to append elements to. */ Tcl_Obj *elemListPtr; /* List obj with elements to append. */ { int listLen, objc, result; Tcl_Obj **objv; if (Tcl_IsShared(listPtr)) { Tcl_Panic("Tcl_ListObjAppendList called with shared object"); } result = Tcl_ListObjLength(interp, listPtr, &listLen); if (result != TCL_OK) { return result; } result = Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv); if (result != TCL_OK) { return result; } /* * Insert objc new elements starting after the lists's last element. * Delete zero existing elements. */ return Tcl_ListObjReplace(interp, listPtr, listLen, 0, objc, objv); } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendElement -- * * This function is a special purpose version of Tcl_ListObjAppendList: * it appends a single object referenced by objPtr to the list object * referenced by listPtr. If listPtr is not already a list object, an * attempt will be made to convert it to one. * * Results: * The return value is normally TCL_OK; in this case objPtr is added to * the end of listPtr's list. If listPtr does not refer to a list object * and the object can not be converted to one, TCL_ERROR is returned and * an error message will be left in the interpreter's result if interp is * not NULL. * * Side effects: * The ref count of objPtr is incremented since the list now refers to * it. listPtr will be converted, if necessary, to a list object. Also, * appending the new element may cause listObj's array of element * pointers to grow. listPtr's old string representation, if any, is * invalidated. * *---------------------------------------------------------------------- */ int Tcl_ListObjAppendElement(interp, listPtr, objPtr) Tcl_Interp *interp; /* Used to report errors if not NULL. */ Tcl_Obj *listPtr; /* List object to append objPtr to. */ Tcl_Obj *objPtr; /* Object to append to listPtr's list. */ { register List *listRepPtr; register Tcl_Obj **elemPtrs; int numElems, numRequired, newMax, newSize, i; if (Tcl_IsShared(listPtr)) { Tcl_Panic("Tcl_ListObjAppendElement called with shared object"); } if (listPtr->typePtr != &tclListType) { int result, length; (void) Tcl_GetStringFromObj(listPtr, &length); if (!length) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; /* * If there is no room in the current array of element pointers, allocate * a new, larger array and copy the pointers to it. If the List struct is * shared, allocate a new one. */ if (numRequired > listRepPtr->maxElemCount){ newMax = (2 * numRequired); newSize = sizeof(List)+((newMax-1)*sizeof(Tcl_Obj*)); } else { newMax = listRepPtr->maxElemCount; newSize = 0; } if (listRepPtr->refCount > 1) { List *oldListRepPtr = listRepPtr; Tcl_Obj **oldElems; listRepPtr = NewListIntRep(newMax, NULL); if (!listRepPtr) { Tcl_Panic("Not enough memory to allocate list"); } oldElems = &oldListRepPtr->elements; elemPtrs = &listRepPtr->elements; for (i=0; i<numElems; i++) { elemPtrs[i] = oldElems[i]; Tcl_IncrRefCount(elemPtrs[i]); } listRepPtr->elemCount = numElems; listRepPtr->refCount++; oldListRepPtr->refCount--; listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; } else if (newSize) { listRepPtr = (List *) ckrealloc((char *)listRepPtr, newSize); listRepPtr->maxElemCount = newMax; listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; } /* * Add objPtr to the end of listPtr's array of element pointers. Increment * the ref count for the (now shared) objPtr. */ elemPtrs = &listRepPtr->elements; elemPtrs[numElems] = objPtr; Tcl_IncrRefCount(objPtr); listRepPtr->elemCount++; /* * Invalidate any old string representation since the list's internal * representation has changed. */ Tcl_InvalidateStringRep(listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * * This function returns a pointer to the index'th object from the list * referenced by listPtr. The first element has index 0. If index is * negative or greater than or equal to the number of elements in the * list, a NULL is returned. If listPtr is not a list object, an attempt * will be made to convert it to a list. * * Results: * The return value is normally TCL_OK; in this case objPtrPtr is set to * the Tcl_Obj pointer for the index'th list element or NULL if index is * out of range. This object should be treated as readonly and its ref * count is _not_ incremented; the caller must do that if it holds on to * the reference. If listPtr does not refer to a list and can't be * converted to one, TCL_ERROR is returned and an error message is left * in the interpreter's result if interp is not NULL. * * Side effects: * listPtr will be converted, if necessary, to a list object. * *---------------------------------------------------------------------- */ int Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr) Tcl_Interp *interp; /* Used to report errors if not NULL. */ register Tcl_Obj *listPtr; /* List object to index into. */ register int index; /* Index of element to return. */ Tcl_Obj **objPtrPtr; /* The resulting Tcl_Obj* is stored here. */ { register List *listRepPtr; if (listPtr->typePtr != &tclListType) { int result, length; (void) Tcl_GetStringFromObj(listPtr, &length); if (!length) { *objPtrPtr = NULL; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { *objPtrPtr = (&listRepPtr->elements)[index]; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ListObjLength -- * * This function returns the number of elements in a list object. If the * object is not already a list object, an attempt will be made to * convert it to one. * * Results: * The return value is normally TCL_OK; in this case *intPtr will be set * to the integer count of list elements. If listPtr does not refer to a * list object and the object can not be converted to one, TCL_ERROR is * returned and an error message will be left in the interpreter's result * if interp is not NULL. * * Side effects: * The possible conversion of the argument object to a list object. * *---------------------------------------------------------------------- */ int Tcl_ListObjLength(interp, listPtr, intPtr) Tcl_Interp *interp; /* Used to report errors if not NULL. */ register Tcl_Obj *listPtr; /* List object whose #elements to return. */ register int *intPtr; /* The resulting int is stored here. */ { register List *listRepPtr; if (listPtr->typePtr != &tclListType) { int result, length; (void) Tcl_GetStringFromObj(listPtr, &length); if (!length) { *intPtr = 0; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; *intPtr = listRepPtr->elemCount; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ListObjReplace -- * * This function replaces zero or more elements of the list referenced by * listPtr with the objects from an (objc,objv) array. The objc elements * of the array referenced by objv replace the count elements in listPtr * starting at first. * * If the argument first is zero or negative, it refers to the first * element. If first is greater than or equal to the number of elements * in the list, then no elements are deleted; the new elements are * appended to the list. Count gives the number of elements to replace. * If count is zero or negative then no elements are deleted; the new * elements are simply inserted before first. * * The argument objv refers to an array of objc pointers to the new * elements to be added to listPtr in place of those that were deleted. * If objv is NULL, no new elements are added. If listPtr is not a list * object, an attempt will be made to convert it to one. * * Results: * The return value is normally TCL_OK. If listPtr does not refer to a * list object and can not be converted to one, TCL_ERROR is returned and * an error message will be left in the interpreter's result if interp is * not NULL. * * Side effects: * The ref counts of the objc elements in objv are incremented since the * resulting list now refers to them. Similarly, the ref counts for * replaced objects are decremented. listPtr is converted, if necessary, * to a list object. listPtr's old string representation, if any, is * freed. * *---------------------------------------------------------------------- */ int Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *listPtr; /* List object whose elements to replace. */ int first; /* Index of first element to replace. */ int count; /* Number of elements to replace. */ int objc; /* Number of objects to insert. */ Tcl_Obj *CONST objv[]; /* An array of objc pointers to Tcl objects to * insert. */ { List *listRepPtr; register Tcl_Obj **elemPtrs; Tcl_Obj *victimPtr; int numElems, numRequired, numAfterLast; int start, shift, newMax, i, j, result; int isShared; if (Tcl_IsShared(listPtr)) { Tcl_Panic("Tcl_ListObjReplace called with shared object"); } if (listPtr->typePtr != &tclListType) { int length; (void) Tcl_GetStringFromObj(listPtr, &length); if (!length) { if (objc) { Tcl_SetListObj(listPtr, objc, NULL); } else { return TCL_OK; } } else { result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } } listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; if (first < 0) { first = 0; } if (first >= numElems) { first = numElems; /* So we'll insert after last element. */ } if (count < 0) { count = 0; } else if (numElems < first+count) { count = numElems - first; } isShared = (listRepPtr->refCount > 1); numRequired = (numElems - count + objc); if ((numRequired <= listRepPtr->maxElemCount) && !isShared) { /* * Can use the current List struct. First "delete" count elements * starting at first. */ for (j = first; j < first + count; j++) { victimPtr = elemPtrs[j]; TclDecrRefCount(victimPtr); } /* * Shift the elements after the last one removed to their new * locations. */ start = (first + count); numAfterLast = (numElems - start); shift = (objc - count); /* numNewElems - numDeleted */ if ((numAfterLast > 0) && (shift != 0)) { Tcl_Obj **src, **dst; src = elemPtrs + start; dst = src + shift; memmove((VOID*) dst, (VOID*) src, (size_t) (numAfterLast * sizeof(Tcl_Obj*))); } } else { /* * Cannot use the current List struct - it is shared, too small, or * both. Allocate a new struct and insert elements into it. */ List *oldListRepPtr = listRepPtr; Tcl_Obj **oldPtrs = elemPtrs; if (numRequired > listRepPtr->maxElemCount){ newMax = (2 * numRequired); } else { newMax = listRepPtr->maxElemCount; } listRepPtr = NewListIntRep(newMax, NULL); if (!listRepPtr) { Tcl_Panic("Not enough memory to allocate list"); } listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; listRepPtr->refCount++; elemPtrs = &listRepPtr->elements; if (isShared) { /* * The old struct will remain in place; need new refCounts for the * new List struct references. Copy over only the surviving * elements. */ for (i=0; i < first; i++) { elemPtrs[i] = oldPtrs[i]; Tcl_IncrRefCount(elemPtrs[i]); } for (i= first + count, j = first + objc; j < numRequired; i++, j++) { elemPtrs[j] = oldPtrs[i]; Tcl_IncrRefCount(elemPtrs[j]); } oldListRepPtr->refCount--; } else { /* * The old struct will be removed; use its inherited refCounts. */ if (first > 0) { memcpy((VOID *) elemPtrs, (VOID *) oldPtrs, (size_t) (first * sizeof(Tcl_Obj *))); } /* * "Delete" count elements starting at first. */ for (j = first; j < first + count; j++) { victimPtr = oldPtrs[j]; TclDecrRefCount(victimPtr); } /* * Copy the elements after the last one removed, shifted to their * new locations. */ start = (first + count); numAfterLast = (numElems - start); if (numAfterLast > 0) { memcpy((VOID *) &(elemPtrs[first + objc]), (VOID *) &(oldPtrs[start]), (size_t) (numAfterLast * sizeof(Tcl_Obj *))); } ckfree((char *) oldListRepPtr); } } /* * Insert the new elements into elemPtrs before "first". */ for (i=0,j=first ; i<objc ; i++,j++) { elemPtrs[j] = objv[i]; Tcl_IncrRefCount(objv[i]); } /* * Update the count of elements. */ listRepPtr->elemCount = numRequired; /* * Invalidate and free any old string representation since it no longer * reflects the list's internal representation. */ Tcl_InvalidateStringRep(listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclLsetList -- * * Core of the 'lset' command when objc == 4. Objv[2] may be either a * scalar index or a list of indices. * * Results: * Returns the new value of the list variable, or NULL if an error * occurs. * * Side effects: * Surgery is performed on the list value to produce the result. * * On entry, the reference count of the variable value does not reflect * any references held on the stack. The first action of this function is * to determine whether the object is shared, and to duplicate it if it * is. The reference count of the duplicate is incremented. At this * point, the reference count will be 1 for either case, so that the * object will appear to be unshared. * * If an error occurs, and the object has been duplicated, the reference * count on the duplicate is decremented so that it is now 0: this * dismisses any memory that was allocated by this function. * * If no error occurs, the reference count of the original object is * incremented if the object has not been duplicated, and nothing is done * to a reference count of the duplicate. Now the reference count of an * unduplicated object is 2 (the returned pointer, plus the one stored in * the variable). The reference count of a duplicate object is 1, * reflecting that the returned pointer is the only active reference. * The caller is expected to store the returned value back in the * variable and decrement its reference count. (INST_STORE_* does exactly * this.) * * Tcl_LsetFlat and related functions maintain a linked list of Tcl_Obj's * whose string representations must be spoilt by threading via 'ptr2' of * the two-pointer internal representation. On entry to Tcl_LsetList, the * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any * Tcl_Obj that has been modified is set to NULL. * *---------------------------------------------------------------------- */ Tcl_Obj* TclLsetList(interp, listPtr, indexArgPtr, valuePtr) Tcl_Interp* interp; /* Tcl interpreter */ Tcl_Obj* listPtr; /* Pointer to the list being modified */ Tcl_Obj* indexArgPtr; /* Index or index-list arg to 'lset' */ Tcl_Obj* valuePtr; /* Value arg to 'lset' */ { int indexCount; /* Number of indices in the index list */ Tcl_Obj** indices; /* Vector of indices in the index list*/ Tcl_Obj* retValuePtr; /* Pointer to the list to be returned */ int index; /* Current index in the list - discarded */ int i; List *indexListRepPtr; /* * Determine whether the index arg designates a list or a single index. * We have to be careful about the order of the checks to avoid repeated * shimmering; see TIP #22 and #23 for details. */ if (indexArgPtr->typePtr != &tclListType && TclGetIntForIndex(NULL, indexArgPtr, 0, &index) == TCL_OK) { /* * indexArgPtr designates a single index. */ return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); } else if (Tcl_ListObjGetElements(NULL, indexArgPtr, &indexCount, &indices) != TCL_OK) { /* * indexArgPtr designates something that is neither an index nor a * well formed list. Report the error via TclLsetFlat. */ return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); } /* * At this point, we know that argPtr designates a well formed list, and * the 'else if' above has parsed it into indexCount and indices. * Increase the reference count of the internal rep of indexArgPtr, in * order to insure the validity of pointers even if indexArgPtr shimmers * to another type. */ if (indexCount) { indexListRepPtr = (List *) indexArgPtr->internalRep.twoPtrValue.ptr1; indexListRepPtr->refCount++; } else { indexListRepPtr = NULL; /* avoid compiler warning*/ } /* * Let TclLsetFlat handle the actual lset'ting. */ retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr); /* * If we are the only users of indexListRepPtr, we free it before * returning. */ if (indexCount) { if (--indexListRepPtr->refCount <= 0) { for (i=0; i<indexCount; i++) { Tcl_DecrRefCount(indices[i]); } ckfree((char *) indexListRepPtr); } } return retValuePtr; } /* *---------------------------------------------------------------------- * * TclLsetFlat -- * * Core of the 'lset' command when objc>=5. Objv[2], ... , objv[objc-2] * contain scalar indices. * * Results: * Returns the new value of the list variable, or NULL if an error * occurs. * * Side effects: * Surgery is performed on the list value to produce the result. * * On entry, the reference count of the variable value does not reflect * any references held on the stack. The first action of this function is * to determine whether the object is shared, and to duplicate it if it * is. The reference count of the duplicate is incremented. At this * point, the reference count will be 1 for either case, so that the * object will appear to be unshared. * * If an error occurs, and the object has been duplicated, the reference * count on the duplicate is decremented so that it is now 0: this * dismisses any memory that was allocated by this function. * * If no error occurs, the reference count of the original object is * incremented if the object has not been duplicated, and nothing is done * to a reference count of the duplicate. Now the reference count of an * unduplicated object is 2 (the returned pointer, plus the one stored in * the variable). The reference count of a duplicate object is 1, * reflecting that the returned pointer is the only active reference. * The caller is expected to store the returned value back in the * variable and decrement its reference count. (INST_STORE_* does exactly * this.) * * Tcl_LsetList and related functions maintain a linked list of Tcl_Obj's * whose string representations must be spoilt by threading via 'ptr2' of * the two-pointer internal representation. On entry to Tcl_LsetList, the * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any * Tcl_Obj that has been modified is set to NULL. * *---------------------------------------------------------------------- */ Tcl_Obj* TclLsetFlat(interp, listPtr, indexCount, indexArray, valuePtr) Tcl_Interp* interp; /* Tcl interpreter */ Tcl_Obj* listPtr; /* Pointer to the list being modified */ int indexCount; /* Number of index args */ Tcl_Obj *CONST indexArray[]; /* Index args */ Tcl_Obj* valuePtr; /* Value arg to 'lset' */ { int duplicated; /* Flag == 1 if the obj has been duplicated, 0 * otherwise */ Tcl_Obj* retValuePtr; /* Pointer to the list to be returned */ int elemCount; /* Length of one sublist being changed */ Tcl_Obj** elemPtrs; /* Pointers to the elements of a sublist */ Tcl_Obj* subListPtr; /* Pointer to the current sublist */ int index; /* Index of the element to replace in the * current sublist */ Tcl_Obj* chainPtr; /* Pointer to the enclosing list of the * current sublist. */ int result; /* Status return from library calls */ int i; /* * If there are no indices, then simply return the new value, counting the * returned pointer as a reference. */ if (indexCount == 0) { Tcl_IncrRefCount(valuePtr); return valuePtr; } |
︙ | ︙ | |||
1228 1229 1230 1231 1232 1233 1234 | * invalidated if the operation succeeds. */ retValuePtr = listPtr; chainPtr = NULL; /* | | > > > > > > | 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 | * invalidated if the operation succeeds. */ retValuePtr = listPtr; chainPtr = NULL; /* * Handle each index arg by diving into the appropriate sublist. */ for (i=0 ; ; i++) { /* * Take the sublist apart. */ result = Tcl_ListObjGetElements(interp, listPtr, &elemCount, &elemPtrs); if (result != TCL_OK) { break; } if (elemCount == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); result = TCL_ERROR; break; } listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr; /* * Determine the index of the requested element. */ |
︙ | ︙ | |||
1280 1281 1282 1283 1284 1285 1286 | */ subListPtr = elemPtrs[index]; if (Tcl_IsShared(subListPtr)) { subListPtr = Tcl_DuplicateObj(subListPtr); result = TclListObjSetElement(interp, listPtr, index, subListPtr); if (result != TCL_OK) { | | | | | | > | | | | 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 | */ subListPtr = elemPtrs[index]; if (Tcl_IsShared(subListPtr)) { subListPtr = Tcl_DuplicateObj(subListPtr); result = TclListObjSetElement(interp, listPtr, index, subListPtr); if (result != TCL_OK) { /* * We actually shouldn't be able to get here. If we do, it * would result in leaking subListPtr, but everything's been * validated already; the error exit from TclListObjSetElement * should never happen. */ break; } } /* * Chain the current sublist onto the linked list of Tcl_Obj's whose * string reps must be spoilt. */ chainPtr = listPtr; listPtr = subListPtr; } /* Store the result in the list element */ |
︙ | ︙ | |||
1341 1342 1343 1344 1345 1346 1347 | *---------------------------------------------------------------------- * * TclListObjSetElement -- * * Set a single element of a list to a specified value * * Results: | < | | | | < | | | < | | | | | | | | | | | > > | > > > > > > > > > > < > > | > > > > > > > > > > > > > > > > > > > > > > > | > > | > > | > | | | > | | | | < | > | | | < < < < < | < < < < < < < < < < < < < < < < < < < < | < < < | | < | 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 | *---------------------------------------------------------------------- * * TclListObjSetElement -- * * Set a single element of a list to a specified value * * Results: * The return value is normally TCL_OK. If listPtr does not refer to a * list object and cannot be converted to one, TCL_ERROR is returned and * an error message will be left in the interpreter result if interp is * not NULL. Similarly, if index designates an element outside the range * [0..listLength-1], where listLength is the count of elements in the * list object designated by listPtr, TCL_ERROR is returned and an error * message is left in the interpreter result. * * Side effects: * Tcl_Panic if listPtr designates a shared object. Otherwise, attempts * to convert it to a list with a non-shared internal rep. Decrements the * ref count of the object at the specified index within the list, * replaces with the object designated by valuePtr, and increments the * ref count of the replacement object. * * It is the caller's responsibility to invalidate the string * representation of the object. * *---------------------------------------------------------------------- */ int TclListObjSetElement(interp, listPtr, index, valuePtr) Tcl_Interp* interp; /* Tcl interpreter; used for error reporting * if not NULL */ Tcl_Obj* listPtr; /* List object in which element should be * stored */ int index; /* Index of element to store */ Tcl_Obj* valuePtr; /* Tcl object to store in the designated list * element */ { int result; /* Return value from this function */ List* listRepPtr; /* Internal representation of the list being * modified */ Tcl_Obj** elemPtrs; /* Pointers to elements of the list */ int elemCount; /* Number of elements in the list */ int i; /* * Ensure that the listPtr parameter designates an unshared list. */ if (Tcl_IsShared(listPtr)) { Tcl_Panic("Tcl_ListObjSetElement called with shared object"); } if (listPtr->typePtr != &tclListType) { int length; (void) Tcl_GetStringFromObj(listPtr, &length); if (!length) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); return TCL_ERROR; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } listRepPtr = (List*) listPtr->internalRep.twoPtrValue.ptr1; elemCount = listRepPtr->elemCount; elemPtrs = &listRepPtr->elements; /* * Ensure that the index is in bounds. */ if (index<0 || index>=elemCount) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); return TCL_ERROR; } } /* * If the internal rep is shared, replace it with an unshared copy. */ if (listRepPtr->refCount > 1) { List *oldListRepPtr = listRepPtr; Tcl_Obj **oldElemPtrs = elemPtrs; listRepPtr = NewListIntRep(listRepPtr->maxElemCount, NULL); listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag; elemPtrs = &listRepPtr->elements; for (i=0; i < elemCount; i++) { elemPtrs[i] = oldElemPtrs[i]; Tcl_IncrRefCount(elemPtrs[i]); } listRepPtr->refCount++; listRepPtr->elemCount = elemCount; listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; oldListRepPtr->refCount--; } /* * Add a reference to the new list element. */ Tcl_IncrRefCount(valuePtr); /* * Remove a reference from the old list element. */ Tcl_DecrRefCount(elemPtrs[index]); /* * Stash the new object in the list. */ elemPtrs[index] = valuePtr; return TCL_OK; } /* *---------------------------------------------------------------------- * * FreeListInternalRep -- * * Deallocate the storage associated with a list object's internal * representation. * * Results: * None. * * Side effects: * Frees listPtr's List* internal representation and sets listPtr's * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all * element objects, which may free them. * *---------------------------------------------------------------------- */ static void FreeListInternalRep(listPtr) Tcl_Obj *listPtr; /* List object with internal rep to free. */ { register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; register Tcl_Obj **elemPtrs = &listRepPtr->elements; register Tcl_Obj *objPtr; int numElems = listRepPtr->elemCount; int i; if (--listRepPtr->refCount <= 0) { for (i = 0; i < numElems; i++) { objPtr = elemPtrs[i]; Tcl_DecrRefCount(objPtr); } ckfree((char *) listRepPtr); } listPtr->internalRep.twoPtrValue.ptr1 = NULL; listPtr->internalRep.twoPtrValue.ptr2 = NULL; } /* *---------------------------------------------------------------------- * * DupListInternalRep -- * * Initialize the internal representation of a list Tcl_Obj to share the * internal representation of an existing list object. * * Results: * None. * * Side effects: * The reference count of the List internal rep is incremented. * *---------------------------------------------------------------------- */ static void DupListInternalRep(srcPtr, copyPtr) Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { List *listRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1; listRepPtr->refCount++; copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; copyPtr->typePtr = &tclListType; } /* *---------------------------------------------------------------------- * * SetListFromAny -- * * Attempt to generate a list internal form for the Tcl object "objPtr". * * Results: * The return value is TCL_OK or TCL_ERROR. If an error occurs during * conversion, an error message is left in the interpreter's result * unless "interp" is NULL. * * Side effects: |
︙ | ︙ | |||
1561 1562 1563 1564 1565 1566 1567 | * Get the string representation. Make it up-to-date if necessary. */ string = Tcl_GetStringFromObj(objPtr, &length); /* * Parse the string into separate string objects, and create a List | | | | | < | | | | > > > > > > | | | | | | | < < | < | | > | | | | | | | > | | > | > > > > > > > > | | > > > > > > > > > > > > > > > > | 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 | * Get the string representation. Make it up-to-date if necessary. */ string = Tcl_GetStringFromObj(objPtr, &length); /* * Parse the string into separate string objects, and create a List * structure that points to the element string objects. We use a modified * version of Tcl_SplitList's implementation to avoid one malloc and a * string copy for each list element. First, estimate the number of * elements by counting the number of space characters in the list. */ limit = (string + length); estCount = 1; for (p = string; p < limit; p++) { if (isspace(UCHAR(*p))) { /* INTL: ISO space. */ estCount++; } } /* * Allocate a new List structure with enough room for "estCount" elements. * Each element is a pointer to a Tcl_Obj with the appropriate string rep. * The initial "estCount" elements are set using the corresponding "argv" * strings. */ listRepPtr = NewListIntRep(estCount, NULL); if (!listRepPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "Not enough memory to allocate the list internal rep", -1)); return TCL_ERROR; } elemPtrs = &listRepPtr->elements; for (p = string, lenRemain = length, i = 0; lenRemain > 0; p = nextElem, lenRemain = (limit - nextElem), i++) { result = TclFindElement(interp, p, lenRemain, &elemStart, &nextElem, &elemSize, &hasBrace); if (result != TCL_OK) { for (j = 0; j < i; j++) { elemPtr = elemPtrs[j]; Tcl_DecrRefCount(elemPtr); } ckfree((char *) listRepPtr); return result; } if (elemStart >= limit) { break; } if (i > estCount) { Tcl_Panic("SetListFromAny: bad size estimate for list"); } /* * Allocate a Tcl object for the element and initialize it from the * "elemSize" bytes starting at "elemStart". */ s = ckalloc((unsigned) elemSize + 1); if (hasBrace) { memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize); s[elemSize] = 0; } else { elemSize = TclCopyAndCollapse(elemSize, elemStart, s); } TclNewObj(elemPtr); elemPtr->bytes = s; elemPtr->length = elemSize; elemPtrs[i] = elemPtr; Tcl_IncrRefCount(elemPtr); /* since list now holds ref to it */ } listRepPtr->elemCount = i; /* * 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. */ listRepPtr->refCount++; TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclListType; return TCL_OK; } /* *---------------------------------------------------------------------- * * UpdateStringOfList -- * * Update the string representation for a list object. Note: This * function does not invalidate an existing old string rep so storage * will be lost if this has not already been done. * * Results: * None. * * Side effects: * The object's string is set to a valid string that results from the * list-to-string conversion. This string will be empty if the list has * no elements. The list internal representation should not be NULL and * we assume it is not NULL. * *---------------------------------------------------------------------- */ static void UpdateStringOfList(listPtr) Tcl_Obj *listPtr; /* List object with string rep to update. */ { # define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr; List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; int numElems = listRepPtr->elemCount; register int i; char *elem, *dst; int length; Tcl_Obj **elemPtrs; /* * Convert each element of the list to string form and then convert it to * proper list element form, adding it to the result buffer. */ /* * Pass 1: estimate space, gather flags. */ if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); } listPtr->length = 1; elemPtrs = &listRepPtr->elements; for (i = 0; i < numElems; i++) { elem = Tcl_GetStringFromObj(elemPtrs[i], &length); listPtr->length += Tcl_ScanCountedElement(elem, length, &flagPtr[i]) + 1; /* * Check for continued sanity. [Bug 1267380] */ if (listPtr->length < 1) { Tcl_Panic("string representation size exceeds sane bounds"); } } /* * Pass 2: copy into string rep buffer. */ listPtr->bytes = ckalloc((unsigned) listPtr->length); dst = listPtr->bytes; for (i = 0; i < numElems; i++) { elem = Tcl_GetStringFromObj(elemPtrs[i], &length); dst += Tcl_ConvertCountedElement(elem, length, dst, flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH)); *dst = ' '; dst++; } if (flagPtr != localFlags) { ckfree((char *) flagPtr); } if (dst == listPtr->bytes) { *dst = 0; } else { dst--; *dst = 0; } listPtr->length = dst - listPtr->bytes; /* * Mark the list as being canonical; although it has a string rep, it is * one we derived through proper "canonical" quoting and so it's known to * be free from nasties relating to [concat] and [eval]. */ listRepPtr->canonicalFlag = 1; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclLiteral.c.
|
| | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | /* * tclLiteral.c -- * * Implementation of the global and ByteCode-local literal tables used to * manage the Tcl objects created for literal values during compilation * of Tcl scripts. This implementation borrows heavily from the more * general hashtable implementation of Tcl hash tables that appears in * tclHash.c. * * Copyright (c) 1997-1998 Sun Microsystems, Inc. * Copyright (c) 2004 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: tclLiteral.c,v 1.20.2.3 2005/08/02 18:16:00 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * When there are this many entries per bucket, on average, rebuild a * literal's hash table to make it larger. */ #define REBUILD_MULTIPLIER 3 /* * Procedure prototypes for static procedures in this file: */ |
︙ | ︙ | |||
47 48 49 50 51 52 53 | * This procedure is called to initialize the fields of a literal table * structure for either an interpreter or a compilation's CompileEnv * structure. * * Results: * None. * | | | > | | | | | | | > | > | | | < | | | | | | < | | | | | | | | | < > | | | | | | < | | | | | | | | | | | | < | | | < | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | > > | < | | | | | < | | > > > > > > > > > > > > | | > | | < | | | < | | > > > > > > | | > | | > | | | | < | > | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | 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 | * This procedure is called to initialize the fields of a literal table * structure for either an interpreter or a compilation's CompileEnv * structure. * * Results: * None. * * Side effects: * The literal table is made ready for use. * *---------------------------------------------------------------------- */ void TclInitLiteralTable(tablePtr) register LiteralTable *tablePtr; /* Pointer to table structure, which is * supplied by the caller. */ { #if (TCL_SMALL_HASH_TABLE != 4) Tcl_Panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n", TCL_SMALL_HASH_TABLE); #endif tablePtr->buckets = tablePtr->staticBuckets; tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0; tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0; tablePtr->numBuckets = TCL_SMALL_HASH_TABLE; tablePtr->numEntries = 0; tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER; tablePtr->mask = 3; } /* *---------------------------------------------------------------------- * * TclCleanupLiteralTable -- * * This procedure frees the internal representation of every literal in a * literal table. It is called prior to deleting an interp, so that * variable refs will be cleaned up properly. * * Results: * None. * * Side effects: * Each literal in the table has its internal representation freed. * *---------------------------------------------------------------------- */ void TclCleanupLiteralTable( interp, tablePtr ) Tcl_Interp* interp; /* Interpreter containing literals to * purge. */ LiteralTable* tablePtr; /* Points to the literal table being * cleaned. */ { int i; LiteralEntry* entryPtr; /* Pointer to the current entry in the hash * table of literals. */ LiteralEntry* nextPtr; /* Pointer to the next entry in the bucket. */ Tcl_Obj* objPtr; /* Pointer to a literal object whose internal * rep is being freed. */ Tcl_ObjType* typePtr; /* Pointer to the object's type. */ int didOne; /* Flag for whether we've removed a literal in * the current bucket. */ #ifdef TCL_COMPILE_DEBUG TclVerifyGlobalLiteralTable( (Interp*) interp ); #endif /* TCL_COMPILE_DEBUG */ for (i=0 ; i<tablePtr->numBuckets ; i++) { /* * It is tempting simply to walk each hash bucket once and delete the * internal representations of each literal in turn. It's also wrong. * The problem is that freeing a literal's internal representation can * delete other literals to which it refers, making nextPtr invalid. * So each time we free an internal rep, we start its bucket over * again. */ do { didOne = 0; entryPtr = tablePtr->buckets[i]; while (entryPtr != NULL) { objPtr = entryPtr->objPtr; nextPtr = entryPtr->nextPtr; typePtr = objPtr->typePtr; if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { if (objPtr->bytes == NULL) { Tcl_Panic( "literal without a string rep" ); } objPtr->typePtr = NULL; typePtr->freeIntRepProc(objPtr); didOne = 1; } else { entryPtr = nextPtr; } } } while (didOne); } } /* *---------------------------------------------------------------------- * * TclDeleteLiteralTable -- * * This procedure frees up everything associated with a literal table * except for the table's structure itself. It is called when the * interpreter is deleted. * * Results: * None. * * Side effects: * Each literal in the table is released: i.e., its reference count in * the global literal table is decremented and, if it becomes zero, the * literal is freed. In addition, the table's bucket array is freed. * *---------------------------------------------------------------------- */ void TclDeleteLiteralTable(interp, tablePtr) Tcl_Interp *interp; /* Interpreter containing shared literals * referenced by the table to delete. */ LiteralTable *tablePtr; /* Points to the literal table to delete. */ { LiteralEntry *entryPtr, *nextPtr; Tcl_Obj *objPtr; int i; /* * Release remaining literals in the table. Note that releasing a literal * might release other literals, modifying the table, so we restart the * search from the bucket chain we last found an entry. */ #ifdef TCL_COMPILE_DEBUG TclVerifyGlobalLiteralTable((Interp *) interp); #endif /*TCL_COMPILE_DEBUG*/ /* * We used to call TclReleaseLiteral for each literal in the table, which * is rather inefficient as it causes one lookup-by-hash for each * reference to the literal. We now rely at interp-deletion on each * bytecode object to release its references to the literal Tcl_Obj * without requiring that it updates the global table itself, and deal * here only with the table. */ for (i = 0; i < tablePtr->numBuckets; i++) { entryPtr = tablePtr->buckets[i]; while (entryPtr != NULL) { objPtr = entryPtr->objPtr; TclDecrRefCount(objPtr); nextPtr = entryPtr->nextPtr; ckfree((char *) entryPtr); entryPtr = nextPtr; } } /* * Free up the table's bucket array if it was dynamically allocated. */ if (tablePtr->buckets != tablePtr->staticBuckets) { ckfree((char *) tablePtr->buckets); } } /* *---------------------------------------------------------------------- * * TclRegisterLiteral -- * * Find, or if necessary create, an object in a CompileEnv literal array * that has a string representation matching the argument string. * * Results: * The index in the CompileEnv's literal array that references a shared * literal matching the string. The object is created if necessary. * * Side effects: * To maximize sharing, we look up the string in the interpreter's global * literal table. If not found, we create a new shared literal in the * global table. We then add a reference to the shared literal in the * CompileEnv's literal array. * * If LITERAL_ON_HEAP is set in flags, this procedure is given ownership * of the string: if an object is created then its string representation * is set directly from string, otherwise the string is freed. Typically, * a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated * buffer holding the result of backslash substitutions. * *---------------------------------------------------------------------- */ int TclRegisterLiteral(envPtr, bytes, length, flags) CompileEnv *envPtr; /* Points to the CompileEnv in whose object * array an object is found or created. */ register char *bytes; /* Points to string for which to find or * create an object in CompileEnv's object * array. */ int length; /* Number of bytes in the string. If < 0, the * string consists of all bytes up to the * first null character. */ int flags; /* If LITERAL_ON_HEAP then the caller already * malloc'd bytes and ownership is passed to * this procedure. If LITERAL_NS_SCOPE then * the literal shouldnot be shared accross * namespaces. */ { Interp *iPtr = envPtr->iPtr; LiteralTable *globalTablePtr = &(iPtr->literalTable); LiteralTable *localTablePtr = &(envPtr->localLitTable); register LiteralEntry *globalPtr, *localPtr; register Tcl_Obj *objPtr; unsigned int hash; int localHash, globalHash, objIndex; Namespace *nsPtr; if (length < 0) { length = (bytes ? strlen(bytes) : 0); } hash = HashString(bytes, length); /* * Is the literal already in the CompileEnv's local literal array? If so, * just return its index. */ localHash = (hash & localTablePtr->mask); for (localPtr = localTablePtr->buckets[localHash]; localPtr != NULL; localPtr = localPtr->nextPtr) { objPtr = localPtr->objPtr; if ((objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { if (flags & LITERAL_ON_HEAP) { ckfree(bytes); } objIndex = (localPtr - envPtr->literalArrayPtr); #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(envPtr); #endif /*TCL_COMPILE_DEBUG*/ return objIndex; } } /* * The literal is new to this CompileEnv. Should it be shared accross * namespaces? If it is a fully qualified name, the namespace * specification is not needed to avoid sharing. */ if ((flags & LITERAL_NS_SCOPE) && iPtr->varFramePtr && ((length <2) || (bytes[0] != ':') || (bytes[1] != ':'))) { nsPtr = iPtr->varFramePtr->nsPtr; } else { nsPtr = NULL; } /* * Is it in the interpreter's global literal table? */ globalHash = (hash & globalTablePtr->mask); for (globalPtr = globalTablePtr->buckets[globalHash]; globalPtr != NULL; globalPtr = globalPtr->nextPtr) { objPtr = globalPtr->objPtr; if ((globalPtr->nsPtr == nsPtr) && (objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { /* * A global literal was found. Add an entry to the CompileEnv's * local literal array. */ if (flags & LITERAL_ON_HEAP) { ckfree(bytes); } objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash); #ifdef TCL_COMPILE_DEBUG if (globalPtr->refCount < 1) { Tcl_Panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d", (length>60? 60 : length), bytes, globalPtr->refCount); } TclVerifyLocalLiteralTable(envPtr); #endif /*TCL_COMPILE_DEBUG*/ return objIndex; } } /* * The literal is new to the interpreter. Add it to the global literal * table then add an entry to the CompileEnv's local literal array. * Convert the object to an integer object if possible. */ TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); if (flags & LITERAL_ON_HEAP) { objPtr->bytes = bytes; objPtr->length = length; } else { TclInitStringRep(objPtr, bytes, length); } #if 0 if (TclLooksLikeInt(bytes, length)) { /* * From here we use the objPtr, because it is NULL terminated */ long n; char buf[TCL_INTEGER_SPACE]; if (TclGetLong((Tcl_Interp *) NULL, objPtr->bytes, &n) == TCL_OK) { TclFormatInt(buf, n); if (strcmp(objPtr->bytes, buf) == 0) { objPtr->internalRep.longValue = n; objPtr->typePtr = &tclIntType; } } } #endif #ifdef TCL_COMPILE_DEBUG if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be", (length>60? 60 : length), bytes); } #endif globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry)); globalPtr->objPtr = objPtr; globalPtr->refCount = 0; globalPtr->nsPtr = nsPtr; globalPtr->nextPtr = globalTablePtr->buckets[globalHash]; globalTablePtr->buckets[globalHash] = globalPtr; globalTablePtr->numEntries++; /* * If the global literal table has exceeded a decent size, rebuild it with * more buckets. */ if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) { RebuildLiteralTable(globalTablePtr); } objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash); #ifdef TCL_COMPILE_DEBUG TclVerifyGlobalLiteralTable(iPtr); TclVerifyLocalLiteralTable(envPtr); { LiteralEntry *entryPtr; int found, i; found = 0; for (i=0 ; i<globalTablePtr->numBuckets ; i++) { for (entryPtr=globalTablePtr->buckets[i]; entryPtr!=NULL ; entryPtr=entryPtr->nextPtr) { if ((entryPtr == globalPtr) && (entryPtr->objPtr == objPtr)) { found = 1; } } } if (!found) { Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" wasn't global", (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ #ifdef TCL_COMPILE_STATS iPtr->stats.numLiteralsCreated++; iPtr->stats.totalLitStringBytes += (double) (length + 1); iPtr->stats.currentLitStringBytes += (double) (length + 1); iPtr->stats.literalCount[TclLog2(length)]++; #endif /*TCL_COMPILE_STATS*/ return objIndex; } /* *---------------------------------------------------------------------- * * TclLookupLiteralEntry -- * * Finds the LiteralEntry that corresponds to a literal Tcl object * holding a literal. * * Results: * Returns the matching LiteralEntry if found, otherwise NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ LiteralEntry * TclLookupLiteralEntry(interp, objPtr) Tcl_Interp *interp; /* Interpreter for which objPtr was created to * hold a literal. */ register Tcl_Obj *objPtr; /* Points to a Tcl object holding a literal * that was previously created by a call to * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr = &(iPtr->literalTable); register LiteralEntry *entryPtr; char *bytes; int length, globalHash; bytes = Tcl_GetStringFromObj(objPtr, &length); globalHash = (HashString(bytes, length) & globalTablePtr->mask); for (entryPtr = globalTablePtr->buckets[globalHash]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { return entryPtr; } } return NULL; } /* *---------------------------------------------------------------------- * * TclHideLiteral -- * * Remove a literal entry from the literal hash tables, leaving it in the * literal array so existing references continue to function. This makes * it possible to turn a shared literal into a private literal that * cannot be shared. * * Results: * None. * * Side effects: * Removes the literal from the local hash table and decrements the * global hash entry's reference count. * *---------------------------------------------------------------------- */ void TclHideLiteral(interp, envPtr, index) Tcl_Interp *interp; /* Interpreter for which objPtr was created to * hold a literal. */ register CompileEnv *envPtr;/* Points to CompileEnv whose literal array * contains the entry being hidden. */ int index; /* The index of the entry in the literal * array. */ { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &(envPtr->localLitTable); int localHash, length; char *bytes; Tcl_Obj *newObjPtr; lPtr = &(envPtr->literalArrayPtr[index]); /* * To avoid unwanted sharing we need to copy the object and remove it from * the local and global literal tables. It still has a slot in the * literal array so it can be referred to by byte codes, but it will not * be matched by literal searches. */ newObjPtr = Tcl_DuplicateObj(lPtr->objPtr); Tcl_IncrRefCount(newObjPtr); TclReleaseLiteral(interp, lPtr->objPtr); lPtr->objPtr = newObjPtr; bytes = Tcl_GetStringFromObj(newObjPtr, &length); localHash = (HashString(bytes, length) & localTablePtr->mask); nextPtrPtr = &localTablePtr->buckets[localHash]; for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) { if (entryPtr == lPtr) { *nextPtrPtr = lPtr->nextPtr; lPtr->nextPtr = NULL; localTablePtr->numEntries--; break; } nextPtrPtr = &entryPtr->nextPtr; } } /* *---------------------------------------------------------------------- * * TclAddLiteralObj -- * * Add a single literal object to the literal array. This function does * not add the literal to the local or global literal tables. The caller * is expected to add the entry to whatever tables are appropriate. * * Results: * The index in the CompileEnv's literal array that references the * literal. Stores the pointer to the new literal entry in the location * referenced by the localPtrPtr argument. * * Side effects: * Expands the literal array if necessary. Increments the refcount on the * literal object. * *---------------------------------------------------------------------- */ int TclAddLiteralObj(envPtr, objPtr, litPtrPtr) register CompileEnv *envPtr;/* Points to CompileEnv in whose literal array * the object is to be inserted. */ Tcl_Obj *objPtr; /* The object to insert into the array. */ LiteralEntry **litPtrPtr; /* The location where the pointer to the new * literal entry should be stored. May be * NULL. */ { register LiteralEntry *lPtr; int objIndex; if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) { ExpandLocalLiteralArray(envPtr); } |
︙ | ︙ | |||
586 587 588 589 590 591 592 | * * Results: * The index in the CompileEnv's literal array that references the * literal. * * Side effects: * Increments the ref count of the global LiteralEntry since the | | | | | | | | | | 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 | * * Results: * The index in the CompileEnv's literal array that references the * literal. * * Side effects: * Increments the ref count of the global LiteralEntry since the * CompileEnv now refers to the literal. Expands the literal array if * necessary. May rebuild the hash bucket array of the CompileEnv's * literal array if it becomes too large. * *---------------------------------------------------------------------- */ static int AddLocalLiteralEntry(envPtr, globalPtr, localHash) register CompileEnv *envPtr;/* Points to CompileEnv in whose literal array * the object is to be inserted. */ LiteralEntry *globalPtr; /* Points to the global LiteralEntry for the * literal to add to the CompileEnv. */ int localHash; /* Hash value for the literal's string. */ { register LiteralTable *localTablePtr = &(envPtr->localLitTable); LiteralEntry *localPtr; int objIndex; objIndex = TclAddLiteralObj(envPtr, globalPtr->objPtr, &localPtr); /* * Add the literal to the local table. */ localPtr->nextPtr = localTablePtr->buckets[localHash]; |
︙ | ︙ | |||
631 632 633 634 635 636 637 638 | } #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(envPtr); { char *bytes; int length, found, i; found = 0; | > | | | > | > | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | < | | | < | < | | | | | | | | | | | | | | > | | | < < < | | | 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 | } #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(envPtr); { char *bytes; int length, found, i; found = 0; for (i=0 ; i<localTablePtr->numBuckets ; i++) { for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ; localPtr=localPtr->nextPtr) { if (localPtr->objPtr == globalPtr->objPtr) { found = 1; } } } if (!found) { bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); Tcl_Panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally", (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ return objIndex; } /* *---------------------------------------------------------------------- * * ExpandLocalLiteralArray -- * * Procedure that uses malloc to allocate more storage for a CompileEnv's * local literal array. * * Results: * None. * * Side effects: * The literal array in *envPtr is reallocated to a new array of double * the size, and if envPtr->mallocedLiteralArray is non-zero the old * array is freed. Entries are copied from the old array to the new one. * The local literal table is updated to refer to the new entries. * *---------------------------------------------------------------------- */ static void ExpandLocalLiteralArray(envPtr) register CompileEnv *envPtr;/* Points to the CompileEnv whose object array * must be enlarged. */ { /* * The current allocated local literal entries are stored between elements * 0 and (envPtr->literalArrayNext - 1) [inclusive]. */ LiteralTable *localTablePtr = &(envPtr->localLitTable); int currElems = envPtr->literalArrayNext; size_t currBytes = (currElems * sizeof(LiteralEntry)); register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; register LiteralEntry *newArrayPtr = (LiteralEntry *) ckalloc((unsigned) (2 * currBytes)); int i; /* * Copy from the old literal array to the new, then update the local * literal table's bucket array. */ memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes); for (i=0 ; i<currElems ; i++) { if (currArrayPtr[i].nextPtr == NULL) { newArrayPtr[i].nextPtr = NULL; } else { newArrayPtr[i].nextPtr = newArrayPtr + (currArrayPtr[i].nextPtr - currArrayPtr); } } for (i=0 ; i<localTablePtr->numBuckets ; i++) { if (localTablePtr->buckets[i] != NULL) { localTablePtr->buckets[i] = newArrayPtr + (localTablePtr->buckets[i] - currArrayPtr); } } /* * Free the old literal array if needed, and mark the new literal array as * malloced. */ if (envPtr->mallocedLiteralArray) { ckfree((char *) currArrayPtr); } envPtr->literalArrayPtr = newArrayPtr; envPtr->literalArrayEnd = (2 * currElems); envPtr->mallocedLiteralArray = 1; } /* *---------------------------------------------------------------------- * * TclReleaseLiteral -- * * This procedure releases a reference to one of the shared Tcl objects * that hold literals. It is called to release the literals referenced by * a ByteCode that is being destroyed, and it is also called by * TclDeleteLiteralTable. * * Results: * None. * * Side effects: * The reference count for the global LiteralTable entry that corresponds * to the literal is decremented. If no other reference to a global * literal object remains, it is freed. * *---------------------------------------------------------------------- */ void TclReleaseLiteral(interp, objPtr) Tcl_Interp *interp; /* Interpreter for which objPtr was created to * hold a literal. */ register Tcl_Obj *objPtr; /* Points to a literal object that was * previously created by a call to * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr = &(iPtr->literalTable); register LiteralEntry *entryPtr, *prevPtr; char *bytes; int length, index; bytes = Tcl_GetStringFromObj(objPtr, &length); index = (HashString(bytes, length) & globalTablePtr->mask); /* * Check to see if the object is in the global literal table and remove * this reference. The object may not be in the table if it is a hidden * local literal. */ for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index]; entryPtr != NULL; prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { entryPtr->refCount--; /* * If the literal is no longer being used by any ByteCode, delete * the entry then remove the reference corresponding to the global * literal table entry (decrement the ref count of the object). */ if (entryPtr->refCount == 0) { if (prevPtr == NULL) { globalTablePtr->buckets[index] = entryPtr->nextPtr; } else { prevPtr->nextPtr = entryPtr->nextPtr; } ckfree((char *) entryPtr); globalTablePtr->numEntries--; TclDecrRefCount(objPtr); #ifdef TCL_COMPILE_STATS iPtr->stats.currentLitStringBytes -= (double) (length + 1); #endif /*TCL_COMPILE_STATS*/ } break; } } /* * Remove the reference corresponding to the local literal table entry. */ Tcl_DecrRefCount(objPtr); } /* *---------------------------------------------------------------------- * * HashString -- * * Compute a one-word summary of a text string, which can be used to * generate a hash index. * * Results: * The return value is a one-word summary of the information in string. * * Side effects: * None. * *---------------------------------------------------------------------- */ static unsigned int HashString(bytes, length) register CONST char *bytes; /* String for which to compute hash value. */ int length; /* Number of bytes in the string. */ { register unsigned int result; register int i; /* * I tried a zillion different hash functions and asked many other people * for advice. Many people had their own favorite functions, all * different, but no-one had much idea why they were good ones. I chose * the one below (multiply by 9 and add new character) because of the * following reasons: * * 1. Multiplying by 10 is perfect for keys that are decimal strings, and * multiplying by 9 is just about as good. * 2. Times-9 is (shift-left-3) plus (old). This means that each * character's bits hang around in the low-order bits of the hash value * for ever, plus they spread fairly rapidly up to the high-order bits * to fill out the hash value. This seems works well both for decimal * and non-decimal strings. */ result = 0; for (i=0 ; i<length ; i++) { result += (result<<3) + bytes[i]; } return result; } /* *---------------------------------------------------------------------- * * RebuildLiteralTable -- * * This procedure is invoked when the ratio of entries to hash buckets * becomes too large in a local or global literal table. It allocates a * larger bucket array and moves the entries into the new buckets. * * Results: * None. * * Side effects: * Memory gets reallocated and entries get rehashed into new buckets. * *---------------------------------------------------------------------- */ static void RebuildLiteralTable(tablePtr) register LiteralTable *tablePtr; /* Local or global table to enlarge. */ { LiteralEntry **oldBuckets; register LiteralEntry **oldChainPtr, **newChainPtr; register LiteralEntry *entryPtr; LiteralEntry **bucketPtr; char *bytes; int oldSize, count, index, length; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; /* * Allocate and initialize the new bucket array, and set up hashing * constants for new array size. */ tablePtr->numBuckets *= 4; tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned) (tablePtr->numBuckets * sizeof(LiteralEntry *))); for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; count > 0; count--, newChainPtr++) { *newChainPtr = NULL; } tablePtr->rebuildSize *= 4; tablePtr->mask = (tablePtr->mask << 2) + 3; /* * Rehash all of the existing entries into the new bucket array. */ for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) { for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) { bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length); index = (HashString(bytes, length) & tablePtr->mask); *oldChainPtr = entryPtr->nextPtr; bucketPtr = &(tablePtr->buckets[index]); entryPtr->nextPtr = *bucketPtr; *bucketPtr = entryPtr; } } |
︙ | ︙ | |||
939 940 941 942 943 944 945 | #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- * * TclLiteralStats -- * | | | | | < | | | | 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 | #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- * * TclLiteralStats -- * * Return statistics describing the layout of the hash table in its hash * buckets. * * Results: * The return value is a malloc-ed string containing information about * tablePtr. It is the caller's responsibility to free this string. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * TclLiteralStats(tablePtr) LiteralTable *tablePtr; /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 int count[NUM_COUNTERS], overflow, i, j; double average, tmp; register LiteralEntry *entryPtr; char *result, *p; /* * Compute a histogram of bucket usage. For each bucket chain i, j is the * number of entries in the chain. */ for (i = 0; i < NUM_COUNTERS; i++) { count[i] = 0; } overflow = 0; average = 0.0; for (i = 0; i < tablePtr->numBuckets; i++) { j = 0; for (entryPtr = tablePtr->buckets[i]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { j++; } if (j < NUM_COUNTERS) { count[j]++; } else { overflow++; } |
︙ | ︙ | |||
1028 1029 1030 1031 1032 1033 1034 | * Tcl_Panic if problems are found. * *---------------------------------------------------------------------- */ void TclVerifyLocalLiteralTable(envPtr) | | | | | < | | | 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 | * Tcl_Panic if problems are found. * *---------------------------------------------------------------------- */ void TclVerifyLocalLiteralTable(envPtr) CompileEnv *envPtr; /* Points to CompileEnv whose literal table is * to be validated. */ { register LiteralTable *localTablePtr = &(envPtr->localLitTable); register LiteralEntry *localPtr; char *bytes; register int i; int length, count; count = 0; for (i = 0; i < localTablePtr->numBuckets; i++) { for (localPtr = localTablePtr->buckets[i]; localPtr != NULL; localPtr = localPtr->nextPtr) { count++; if (localPtr->refCount != -1) { bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d", (length>60? 60 : length), bytes, localPtr->refCount); } if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, localPtr->objPtr) == NULL) { bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global", (length>60? 60 : length), bytes); } if (localPtr->objPtr->bytes == NULL) { Tcl_Panic("TclVerifyLocalLiteralTable: literal has NULL string rep"); } } } if (count != localTablePtr->numEntries) { Tcl_Panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d", count, localTablePtr->numEntries); } } /* *---------------------------------------------------------------------- * * TclVerifyGlobalLiteralTable -- |
︙ | ︙ | |||
1083 1084 1085 1086 1087 1088 1089 | * Tcl_Panic if problems are found. * *---------------------------------------------------------------------- */ void TclVerifyGlobalLiteralTable(iPtr) | | | | | < | > > > > > > > > | 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 | * Tcl_Panic if problems are found. * *---------------------------------------------------------------------- */ void TclVerifyGlobalLiteralTable(iPtr) Interp *iPtr; /* Points to interpreter whose global literal * table is to be validated. */ { register LiteralTable *globalTablePtr = &(iPtr->literalTable); register LiteralEntry *globalPtr; char *bytes; register int i; int length, count; count = 0; for (i = 0; i < globalTablePtr->numBuckets; i++) { for (globalPtr = globalTablePtr->buckets[i]; globalPtr != NULL; globalPtr = globalPtr->nextPtr) { count++; if (globalPtr->refCount < 1) { bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); Tcl_Panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d", (length>60? 60 : length), bytes, globalPtr->refCount); } if (globalPtr->objPtr->bytes == NULL) { Tcl_Panic("TclVerifyGlobalLiteralTable: literal has NULL string rep"); } } } if (count != globalTablePtr->numEntries) { Tcl_Panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d", count, globalTablePtr->numEntries); } } #endif /*TCL_COMPILE_DEBUG*/ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclLoad.c.
|
| | | | | | | | | | | < | > | | | < | | | < | | | | | | | | | | | | | | | | | | | | | | | | < | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 | /* * 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.13.2.1 2005/08/02 18:16:01 dgp Exp $ */ #include "tclInt.h" /* * The following structure describes a package that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call * to TclGetLoadedPackages). All such packages are linked together into a * single list for the process. Packages are never unloaded, until the * application exits, when TclFinalizeLoad is called, and these structures are * freed. */ typedef struct LoadedPackage { char *fileName; /* Name of the file from which the 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. */ Tcl_PackageInitProc *safeInitProc; /* Initialization procedure to call to * incorporate this package into a safe * interpreter (one that will execute * untrusted scripts). NULL means the package * can't be used in unsafe interpreters. */ Tcl_PackageUnloadProc *unloadProc; /* Finalisation procedure to unload a package * from a trusted interpreter. NULL means that * the package cannot be unloaded. */ Tcl_PackageUnloadProc *safeUnloadProc; /* Finalisation procedure to unload a package * from a safe interpreter. NULL means that * the package cannot be unloaded. */ int interpRefCount; /* How many times the package has been loaded * in trusted interpreters. */ int safeInterpRefCount; /* How many times the package has been loaded * in safe interpreters. */ Tcl_FSUnloadFileProc *unLoadProcPtr; /* Procedure to use to unload this package. * If NULL, then we do not attempt to unload * the package. If fileName is NULL, then * this field is irrelevant. */ struct LoadedPackage *nextPtr; /* Next in list of all packages loaded into * this application process. NULL means end of * list. */ } LoadedPackage; /* * TCL_THREADS * There is a global list of packages that is anchored at firstPackagePtr. * Access to this list is governed by a mutex. */ static LoadedPackage *firstPackagePtr = NULL; /* First in list of all packages loaded into * this process. */ TCL_DECLARE_MUTEX(packageMutex) /* * The following structure represents a particular package that has been * incorporated into a particular interpreter (by calling its initialization * procedure). There is a list of these structures for each interpreter, with * an AssocData value (key "load") for the interpreter that points to the * first package (if any). */ typedef struct InterpPackage { LoadedPackage *pkgPtr; /* Points to detailed information about * package. */ struct InterpPackage *nextPtr; /* Next package in this interpreter, or NULL * for end of list. */ } InterpPackage; /* * Prototypes for procedures that are private to this file: */ static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); /* *---------------------------------------------------------------------- * * Tcl_LoadObjCmd -- * * This procedure is invoked to process the "load" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LoadObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; Tcl_DString pkgName, tmp, initName, safeInitName; Tcl_DString unloadName, safeUnloadName; Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc; InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch, offset; CONST char *symbols[4]; Tcl_PackageInitProc **procPtrs[4]; ClientData clientData; char *p, *fullFileName, *packageName; Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unLoadProcPtr = NULL; Tcl_UniChar ch; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } fullFileName = Tcl_GetString(objv[1]); Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); Tcl_DStringInit(&unloadName); Tcl_DStringInit(&safeUnloadName); Tcl_DStringInit(&tmp); |
︙ | ︙ | |||
178 179 180 181 182 183 184 | /* * Figure out which interpreter we're going to load the package into. */ target = interp; if (objc == 4) { | | | | | | | > | 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 | /* * Figure out which interpreter we're going to load the package into. */ target = interp; if (objc == 4) { char *slaveIntName = Tcl_GetString(objv[3]); target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { code = TCL_ERROR; goto done; } } /* * Scan through the packages that are currently loaded to see if the * package we want is already loaded. We'll use a loaded package if it * meets any of the following conditions: * - Its name and file match the once we're looking for. * - Its file matches, and we weren't given a name. * - Its name matches, the file name was specified as empty, and there is * only no statically loaded package with the same name. */ Tcl_MutexLock(&packageMutex); defaultPtr = NULL; for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { if (packageName == NULL) { namesMatch = 0; } else { |
︙ | ︙ | |||
227 228 229 230 231 232 233 | break; } if (namesMatch && (fullFileName[0] == 0)) { defaultPtr = pkgPtr; } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* | | < | | | | > > | | | | | | 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 | break; } if (namesMatch && (fullFileName[0] == 0)) { defaultPtr = pkgPtr; } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* * Can't have two different packages loaded from the same file. */ Tcl_AppendResult(interp, "file \"", fullFileName, "\" is already loaded for package \"", pkgPtr->packageName, "\"", (char *) NULL); code = TCL_ERROR; Tcl_MutexUnlock(&packageMutex); goto done; } } Tcl_MutexUnlock(&packageMutex); if (pkgPtr == NULL) { pkgPtr = defaultPtr; } /* * Scan through the list of packages already loaded in the target * interpreter. If the package we want is already loaded there, then * there's nothing for us to do. */ if (pkgPtr != NULL) { ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", (Tcl_InterpDeleteProc **) NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->pkgPtr == pkgPtr) { code = TCL_OK; goto done; } } } if (pkgPtr == NULL) { /* * The desired file isn't currently loaded, so load it. It's an error * if the desired package is a static one. */ if (fullFileName[0] == 0) { Tcl_AppendResult(interp, "package \"", packageName, "\" isn't loaded statically", (char *) NULL); code = TCL_ERROR; goto done; } /* * Figure out the module name if it wasn't provided explicitly. */ if (packageName != NULL) { Tcl_DStringAppend(&pkgName, packageName, -1); } else { int retc; /* * Threading note - this call used to be protected by a mutex. */ retc = TclGuessPackageName(fullFileName, &pkgName); if (!retc) { Tcl_Obj *splitPtr; Tcl_Obj *pkgGuessPtr; int pElements; char *pkgGuess; /* * The platform-specific code couldn't figure out the module * name. Make a guess by taking the last element of the file * name, stripping off any leading "lib", and then using all * of the alphabetic and underline characters that follow * that. */ splitPtr = Tcl_FSSplitPath(objv[1], &pElements); Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); pkgGuess = Tcl_GetString(pkgGuessPtr); if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') && (pkgGuess[2] == 'b')) { |
︙ | ︙ | |||
333 334 335 336 337 338 339 | } /* * Fix the capitalization in the package name so that the first * character is in caps (or title case) but the others are all * lower-case. */ | | | | | | | | | | | | | | | | | > | > | 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 | } /* * Fix the capitalization in the package name so that the first * character is in caps (or title case) but the others are all * lower-case. */ Tcl_DStringSetLength(&pkgName, Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); /* * Compute the names of the two initialization procedures, based on * the package name. */ Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&initName, "_Init", 5); Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&unloadName, "_Unload", 7); Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&safeUnloadName, "_SafeUnload", 11); /* * Call platform-specific code to load the package and find the two * initialization procedures. */ symbols[0] = Tcl_DStringValue(&initName); symbols[1] = Tcl_DStringValue(&safeInitName); symbols[2] = Tcl_DStringValue(&unloadName); symbols[3] = Tcl_DStringValue(&safeUnloadName); procPtrs[0] = &initProc; procPtrs[1] = &safeInitProc; procPtrs[2] = &unloadProc; procPtrs[3] = &safeUnloadProc; Tcl_MutexLock(&packageMutex); code = TclLoadFile(interp, objv[1], 4, symbols, procPtrs, &loadHandle, &clientData, &unLoadProcPtr); Tcl_MutexUnlock(&packageMutex); loadHandle = (Tcl_LoadHandle) clientData; if (code != TCL_OK) { goto done; } if (*procPtrs[0] /* initProc */ == NULL) { Tcl_AppendResult(interp, "couldn't find procedure ", Tcl_DStringValue(&initName), (char *) NULL); if (unLoadProcPtr != NULL) { (*unLoadProcPtr)(loadHandle); } code = TCL_ERROR; |
︙ | ︙ | |||
397 398 399 400 401 402 403 | pkgPtr->packageName = (char *) ckalloc((unsigned) (Tcl_DStringLength(&pkgName) + 1)); strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); pkgPtr->loadHandle = loadHandle; pkgPtr->unLoadProcPtr = unLoadProcPtr; pkgPtr->initProc = *procPtrs[0]; pkgPtr->safeInitProc = *procPtrs[1]; | | | | | > | | < | | < | | | | | > | | | | | | | > | | | | < | < | < < < < < | | < | < | | | | | | | 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 | pkgPtr->packageName = (char *) ckalloc((unsigned) (Tcl_DStringLength(&pkgName) + 1)); strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); pkgPtr->loadHandle = loadHandle; pkgPtr->unLoadProcPtr = unLoadProcPtr; pkgPtr->initProc = *procPtrs[0]; pkgPtr->safeInitProc = *procPtrs[1]; pkgPtr->unloadProc = (Tcl_PackageUnloadProc*) *procPtrs[2]; pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc*) *procPtrs[3]; pkgPtr->interpRefCount = 0; pkgPtr->safeInterpRefCount = 0; Tcl_MutexLock(&packageMutex); pkgPtr->nextPtr = firstPackagePtr; firstPackagePtr = pkgPtr; Tcl_MutexUnlock(&packageMutex); } /* * Invoke the package's initialization procedure (either the normal one or * the safe one, depending on whether or not the interpreter is safe). */ if (Tcl_IsSafe(target)) { if (pkgPtr->safeInitProc != NULL) { code = (*pkgPtr->safeInitProc)(target); } else { Tcl_AppendResult(interp, "can't use package in a safe interpreter: no ", pkgPtr->packageName, "_SafeInit procedure", (char *) NULL); code = TCL_ERROR; goto done; } } else { code = (*pkgPtr->initProc)(target); } /* * Record the fact that the package has been loaded in the target * interpreter. */ if (code == TCL_OK) { /* * Update the proper reference count. */ Tcl_MutexLock(&packageMutex); if (Tcl_IsSafe(target)) { ++pkgPtr->safeInterpRefCount; } else { ++pkgPtr->interpRefCount; } Tcl_MutexUnlock(&packageMutex); /* * Refetch ipFirstPtr: loading the package may have introduced * additional static packages at the head of the linked list! */ ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", (Tcl_InterpDeleteProc **) NULL); ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); ipPtr->pkgPtr = pkgPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, (ClientData) ipPtr); } else { TclTransferResult(target, code, interp); } done: Tcl_DStringFree(&pkgName); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); Tcl_DStringFree(&unloadName); Tcl_DStringFree(&safeUnloadName); Tcl_DStringFree(&tmp); return code; } /* *---------------------------------------------------------------------- * * Tcl_UnloadObjCmd -- * * This procedure is invoked to process the "unload" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_UnloadObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Interp *target; /* Which interpreter to unload from. */ LoadedPackage *pkgPtr, *defaultPtr; Tcl_DString pkgName, tmp; Tcl_PackageUnloadProc *unloadProc; InterpPackage *ipFirstPtr, *ipPtr; int i, index, code, complain = 1, keepLibrary = 0; int trustedRefCount = -1, safeRefCount = -1; char *fullFileName = "", *packageName; static CONST char *options[] = { "-nocomplain", "-keeplibrary", "--", NULL }; enum options { UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST }; for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { fullFileName = Tcl_GetString(objv[i]); if (fullFileName[0] == '-') { /* * It looks like the command contains an option so signal an * error */ return TCL_ERROR; } else { /* * This clearly isn't an option; assume it's the filename. We * must clear the error. */ Tcl_ResetResult(interp); break; } } switch (index) { case UNLOAD_NOCOMPLAIN: /* -nocomplain */ complain = 0; break; case UNLOAD_KEEPLIB: /* -keeplibrary */ keepLibrary = 1; break; case UNLOAD_LAST: /* -- */ i++; goto endOfForLoop; } } endOfForLoop: if ((objc-i < 1) || (objc-i > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { return TCL_ERROR; } fullFileName = Tcl_GetString(objv[i]); Tcl_DStringInit(&pkgName); Tcl_DStringInit(&tmp); packageName = NULL; if (objc - i >= 2) { packageName = Tcl_GetString(objv[i+1]); |
︙ | ︙ | |||
596 597 598 599 600 601 602 | if (target == NULL) { return TCL_ERROR; } } /* * Scan through the packages that are currently loaded to see if the | | | | | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 | if (target == NULL) { return TCL_ERROR; } } /* * Scan through the packages that are currently loaded to see if the * package we want is already loaded. We'll use a loaded package if it * meets any of the following conditions: * - Its name and file match the once we're looking for. * - Its file matches, and we weren't given a name. * - Its name matches, the file name was specified as empty, and there is * only no statically loaded package with the same name. */ Tcl_MutexLock(&packageMutex); defaultPtr = NULL; for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { int namesMatch, filesMatch; |
︙ | ︙ | |||
653 654 655 656 657 658 659 | "\" is loaded statically and cannot be unloaded", (char *) NULL); code = TCL_ERROR; goto done; } if (pkgPtr == NULL) { /* | | < | | > | | < | | 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 | "\" is loaded statically and cannot be unloaded", (char *) NULL); code = TCL_ERROR; goto done; } if (pkgPtr == NULL) { /* * The DLL pointed by the provided filename has never been loaded. */ Tcl_AppendResult(interp, "file \"", fullFileName, "\" has never been loaded", (char *) NULL); code = TCL_ERROR; goto done; } /* * Scan through the list of packages already loaded in the target * interpreter. If the package we want is already loaded there, then we * should proceed with unloading. */ code = TCL_ERROR; if (pkgPtr != NULL) { ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", (Tcl_InterpDeleteProc **) NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->pkgPtr == pkgPtr) { code = TCL_OK; break; } } } if (code != TCL_OK) { /* * The package has not been loaded in this interpreter. */ Tcl_AppendResult(interp, "file \"", fullFileName, "\" has never been loaded in this interpreter", (char *) NULL); code = TCL_ERROR; goto done; } /* * Ensure that the DLL can be unloaded. If it is a trusted interpreter, * pkgPtr->unloadProc must not be NULL for the DLL to be unloadable. If * the interpreter is a safe one, pkgPtr->safeUnloadProc must be non-NULL. */ if (Tcl_IsSafe(target)) { if (pkgPtr->safeUnloadProc == NULL) { Tcl_AppendResult(interp, "file \"", fullFileName, "\" cannot be unloaded under a safe interpreter", (char *) NULL); |
︙ | ︙ | |||
719 720 721 722 723 724 725 | goto done; } unloadProc = pkgPtr->unloadProc; } /* * We are ready to unload the package. First, evaluate the unload | | | | | | < | | 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 | goto done; } unloadProc = pkgPtr->unloadProc; } /* * We are ready to unload the package. First, evaluate the unload * procedure. If this fails, we cannot proceed with unload. Also, we must * specify the proper flag to pass to the unload callback. * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should * only remove itself from the interpreter; the library will be unloaded * in a future call of unload. In case the library will be unloaded just * after the callback returns, TCL_UNLOAD_DETACH_FROM_PROCESS is passed. */ code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; if (!keepLibrary) { Tcl_MutexLock(&packageMutex); trustedRefCount = pkgPtr->interpRefCount; safeRefCount = pkgPtr->safeInterpRefCount; |
︙ | ︙ | |||
752 753 754 755 756 757 758 | code = (*unloadProc)(target, code); if (code != TCL_OK) { TclTransferResult(target, code, interp); goto done; } /* | | | > | > > | > | | | | | 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 | code = (*unloadProc)(target, code); if (code != TCL_OK) { TclTransferResult(target, code, interp); goto done; } /* * The unload procedure executed fine. Examine the reference count to see * if we unload the DLL. */ Tcl_MutexLock(&packageMutex); if (Tcl_IsSafe(target)) { --pkgPtr->safeInterpRefCount; /* * Do not let counter get negative. */ if (pkgPtr->safeInterpRefCount < 0) { pkgPtr->safeInterpRefCount = 0; } } else { --pkgPtr->interpRefCount; /* * Do not let counter get negative. */ if (pkgPtr->interpRefCount < 0) { pkgPtr->interpRefCount = 0; } } trustedRefCount = pkgPtr->interpRefCount; safeRefCount = pkgPtr->safeInterpRefCount; Tcl_MutexUnlock(&packageMutex); code = TCL_OK; if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0 && !keepLibrary) { /* * Unload the shared library from the application memory... */ #if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) /* * Some Unix dlls are poorly behaved - registering things like 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) { Tcl_MutexLock(&packageMutex); |
︙ | ︙ | |||
818 819 820 821 822 823 824 | pkgPtr->nextPtr = defaultPtr->nextPtr; break; } } } /* | | < | 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 | pkgPtr->nextPtr = defaultPtr->nextPtr; break; } } } /* * Remove this library from the interpreter's library cache. */ ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", (Tcl_InterpDeleteProc **) NULL); ipPtr = ipFirstPtr; if (ipPtr->pkgPtr == defaultPtr) { ipFirstPtr = ipFirstPtr->nextPtr; |
︙ | ︙ | |||
859 860 861 862 863 864 865 | #else Tcl_AppendResult(interp, "file \"", fullFileName, "\" cannot be unloaded: unloading disabled", (char *) NULL); code = TCL_ERROR; #endif } | | | | | 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 | #else Tcl_AppendResult(interp, "file \"", fullFileName, "\" cannot be unloaded: unloading disabled", (char *) NULL); code = TCL_ERROR; #endif } done: Tcl_DStringFree(&pkgName); Tcl_DStringFree(&tmp); if (!complain && code!=TCL_OK) { code = TCL_OK; Tcl_ResetResult(interp); } if (code == TCL_OK) { #if 0 /* * Result of [unload] was not documented in TIP#100, so force to be * the empty string by commenting this out. DKF. */ Tcl_Obj *resultObjPtr, *objPtr[2]; /* * Our result is the two reference counts. */ |
︙ | ︙ | |||
904 905 906 907 908 909 910 | } /* *---------------------------------------------------------------------- * * Tcl_StaticPackage -- * | | | | | | | | | | | | | > | < | > | | < | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_StaticPackage -- * * This procedure is invoked to indicate that a particular package has * been linked statically with an application. * * Results: * None. * * Side effects: * Once this procedure completes, the package becomes loadable via the * "load" command with an empty file name. * *---------------------------------------------------------------------- */ void Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) Tcl_Interp *interp; /* If not NULL, it means that the package has * already been loaded into the given * interpreter by calling the appropriate init * proc. */ CONST char *pkgName; /* Name of package (must be properly * capitalized: first letter upper case, * others lower case). */ Tcl_PackageInitProc *initProc; /* Procedure to call to incorporate this * package into a trusted interpreter. */ Tcl_PackageInitProc *safeInitProc; /* Procedure to call to incorporate this * package into a safe interpreter (one that * will execute untrusted scripts). NULL means * the package can't be used in safe * interpreters. */ { LoadedPackage *pkgPtr; InterpPackage *ipPtr, *ipFirstPtr; /* * Check to see if someone else has already reported this package as * statically loaded in the process. */ Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { if ((pkgPtr->initProc == initProc) && (pkgPtr->safeInitProc == safeInitProc) && (strcmp(pkgPtr->packageName, pkgName) == 0)) { break; } } Tcl_MutexUnlock(&packageMutex); /* * If the package is not yet recorded as being loaded statically, add it * to the list now. */ if ( pkgPtr == NULL ) { pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); pkgPtr->fileName = (char *) ckalloc((unsigned) 1); pkgPtr->fileName[0] = 0; pkgPtr->packageName = (char *) ckalloc((unsigned) |
︙ | ︙ | |||
978 979 980 981 982 983 984 | firstPackagePtr = pkgPtr; Tcl_MutexUnlock(&packageMutex); } if (interp != NULL) { /* | | | | | | | < | | | < | | | | | | | | | | 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 | firstPackagePtr = pkgPtr; Tcl_MutexUnlock(&packageMutex); } if (interp != NULL) { /* * If we're loading the package into an interpreter, determine whether * it's already loaded. */ ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad", (Tcl_InterpDeleteProc **) NULL); for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) { if ( ipPtr->pkgPtr == pkgPtr ) { return; } } /* * Package isn't loade in the current interp yet. Mark it as now being * loaded. */ ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); ipPtr->pkgPtr = pkgPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, (ClientData) ipPtr); } } /* *---------------------------------------------------------------------- * * TclGetLoadedPackages -- * * This procedure returns information about all of the files that are * loaded (either in a particular intepreter, or for all interpreters). * * Results: * The return value is a standard Tcl completion code. If successful, a * list of lists is placed in the interp's result. Each sublist * corresponds to one loaded file; its first element is the name of the * file (or an empty string for something that's statically loaded) and * the second element is the name of the package in that file. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclGetLoadedPackages(interp, targetName) Tcl_Interp *interp; /* Interpreter in which to return information * or error message. */ char *targetName; /* Name of target interpreter or NULL. If * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ { Tcl_Interp *target; LoadedPackage *pkgPtr; InterpPackage *ipPtr; char *prefix; if (targetName == NULL) { /* * Return information about all of the available packages. */ prefix = "{"; Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { Tcl_AppendResult(interp, prefix, (char *) NULL); Tcl_AppendElement(interp, pkgPtr->fileName); Tcl_AppendElement(interp, pkgPtr->packageName); Tcl_AppendResult(interp, "}", (char *) NULL); prefix = " {"; } Tcl_MutexUnlock(&packageMutex); return TCL_OK; } /* * Return information about only the packages that are loaded in a given * interpreter. */ target = Tcl_GetSlave(interp, targetName); if (target == NULL) { return TCL_ERROR; } ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", |
︙ | ︙ | |||
1087 1088 1089 1090 1091 1092 1093 | } /* *---------------------------------------------------------------------- * * LoadCleanupProc -- * | | | | | | | 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 | } /* *---------------------------------------------------------------------- * * LoadCleanupProc -- * * This procedure is called to delete all of the InterpPackage structures * for an interpreter when the interpreter is deleted. It gets invoked * via the Tcl AssocData mechanism. * * Results: * None. * * Side effects: * Storage for all of the InterpPackage procedures for interp get * deleted. * *---------------------------------------------------------------------- */ static void LoadCleanupProc(clientData, interp) ClientData clientData; /* Pointer to first InterpPackage structure |
︙ | ︙ | |||
1122 1123 1124 1125 1126 1127 1128 | } /* *---------------------------------------------------------------------- * * TclFinalizeLoad -- * | | | | < | | | < > | | | | > | > > > > > > > > > | 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 | } /* *---------------------------------------------------------------------- * * TclFinalizeLoad -- * * This procedure is invoked just before the application exits. It frees * all of the LoadedPackage structures. * * Results: * None. * * Side effects: * Memory is freed. * *---------------------------------------------------------------------- */ void TclFinalizeLoad() { LoadedPackage *pkgPtr; /* * No synchronization here because there should just be one thread alive * at this point. Logically, packageMutex should be grabbed at this point, * but the Mutexes get finalized before the call to this routine. The * only subsystem left alive at this point is the memory allocator. */ while (firstPackagePtr != NULL) { pkgPtr = firstPackagePtr; firstPackagePtr = pkgPtr->nextPtr; #if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) /* * Some Unix dlls are poorly behaved - registering things like 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); } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to 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 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 | /* * tclMain.c -- * * Main program for Tcl shells and other Tcl-based applications. * * Copyright (c) 1988-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 2000 Ajuba Solutions. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclMain.c,v 1.30.2.3 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.h" #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLEXPORT /* * The default prompt used when the user has not overridden it. */ #define DEFAULT_PRIMARY_PROMPT "% " /* * Declarations for various library procedures and variables (don't want to * include tclPort.h here, because people might copy this file out of the Tcl * source directory to make their own modified versions). */ extern DLLIMPORT int isatty _ANSI_ARGS_((int fd)); static Tcl_Obj *tclStartupScriptPath = NULL; static Tcl_Obj *tclStartupScriptEncoding = NULL; static Tcl_MainLoopProc *mainLoopProc = NULL; /* * Structure definition for information used to keep the state of an * interactive command processor that reads lines from standard input and * writes prompts and results to standard output. */ typedef enum { PROMPT_NONE, /* Print no prompt */ PROMPT_START, /* Print prompt for command start */ PROMPT_CONTINUE /* Print prompt for command continuation */ } PromptType; typedef struct InteractiveState { Tcl_Channel input; /* The standard input channel from which lines * are read. */ int tty; /* Non-zero means standard input is a * terminal-like device. Zero means it's a * file. */ Tcl_Obj *commandPtr; /* Used to assemble lines of input into Tcl * commands. */ PromptType prompt; /* Next prompt to print */ Tcl_Interp *interp; /* Interpreter that evaluates interactive * commands. */ } InteractiveState; /* * Forward declarations for procedures defined later in this file. */ static void Prompt _ANSI_ARGS_((Tcl_Interp *interp, PromptType *promptPtr)); static void StdinProc _ANSI_ARGS_((ClientData clientData, int mask)); /* *---------------------------------------------------------------------- * * Tcl_SetStartupScript -- * * Sets the path and encoding of the startup script to be evaluated by * Tcl_Main, used to override the command line processing. * * Results: * None. * * Side effects: * *---------------------------------------------------------------------- */ void Tcl_SetStartupScript(path, encoding) Tcl_Obj *path; /* Filesystem path of startup script file */ CONST char *encoding; /* Encoding of the data in that file */ { Tcl_Obj *newEncoding = NULL; if (encoding != NULL) { newEncoding = Tcl_NewStringObj(encoding, -1); } |
︙ | ︙ | |||
102 103 104 105 106 107 108 | Tcl_DecrRefCount(tclStartupScriptEncoding); } tclStartupScriptEncoding = newEncoding; if (tclStartupScriptEncoding != NULL) { Tcl_IncrRefCount(tclStartupScriptEncoding); } } | < | | | | | | > > | | | | | | | | | > > | | | | > > | | | | | | | > > | < | | > > | | | | | | | | | | | | | | | | | | | | > | 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 | Tcl_DecrRefCount(tclStartupScriptEncoding); } tclStartupScriptEncoding = newEncoding; if (tclStartupScriptEncoding != NULL) { Tcl_IncrRefCount(tclStartupScriptEncoding); } } /* *---------------------------------------------------------------------- * * Tcl_GetStartupScript -- * * Gets the path and encoding of the startup script to be evaluated by * Tcl_Main. * * Results: * The path of the startup script; NULL if none has been set. * * Side effects: * If encodingPtr is not NULL, stores a (CONST char *) in it pointing to * the encoding name registered for the startup script. Tcl retains * ownership of the string, and may free it. Caller should make a copy * for long-term use. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_GetStartupScript(encodingPtr) CONST char **encodingPtr; /* When not NULL, points to storage for the * (CONST char *) that points to the * registered encoding name for the startup * script */ { if (encodingPtr != NULL) { if (tclStartupScriptEncoding == NULL) { *encodingPtr = NULL; } else { *encodingPtr = Tcl_GetString(tclStartupScriptEncoding); } } return tclStartupScriptPath; } /* *---------------------------------------------------------------------- * * TclSetStartupScriptPath -- * * Primes the startup script VFS path, used to override the command line * processing. * * Results: * None. * * Side effects: * This procedure initializes the VFS path of the Tcl script to run at * startup. * *---------------------------------------------------------------------- */ void TclSetStartupScriptPath(path) Tcl_Obj *path; { Tcl_SetStartupScript(path, NULL); } /* *---------------------------------------------------------------------- * * TclGetStartupScriptPath -- * * Gets the startup script VFS path, used to override the command line * processing. * * Results: * The startup script VFS path, NULL if none has been set. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Obj * TclGetStartupScriptPath() { return Tcl_GetStartupScript(NULL); } /* *---------------------------------------------------------------------- * * TclSetStartupScriptFileName -- * * Primes the startup script file name, used to override the command line * processing. * * Results: * None. * * Side effects: * This procedure initializes the file name of the Tcl script to run at * startup. * *---------------------------------------------------------------------- */ void TclSetStartupScriptFileName(fileName) CONST char *fileName; { Tcl_Obj *path = Tcl_NewStringObj(fileName,-1); Tcl_SetStartupScript(path, NULL); } /* *---------------------------------------------------------------------- * * TclGetStartupScriptFileName -- * * Gets the startup script file name, used to override the command line * processing. * * Results: * The startup script file name, NULL if none has been set. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * TclGetStartupScriptFileName() { Tcl_Obj *path = Tcl_GetStartupScript(NULL); if (path == NULL) { return NULL; } return Tcl_GetString(path); } /*---------------------------------------------------------------------- * * Tcl_SourceRCFile -- * * This procedure is typically invoked by Tcl_Main of Tk_Main procedure * to source an application specific rc file into the interpreter at * startup time. * * Results: * None. * * Side effects: * Depends on what's in the rc script. * *---------------------------------------------------------------------- */ void Tcl_SourceRCFile(interp) Tcl_Interp *interp; /* Interpreter to source rc file into. */ { Tcl_DString temp; CONST char *fileName; Tcl_Channel errChannel; fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); if (fileName != NULL) { Tcl_Channel c; CONST char *fullName; Tcl_DStringInit(&temp); fullName = Tcl_TranslateFileName(interp, fileName, &temp); if (fullName == NULL) { /* * Couldn't translate the file name (e.g. it referred to a bogus * user or there was no HOME environment variable). Just do * nothing. */ } else { /* * Test for the existence of the rc file before trying to read it. */ c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); if (c != (Tcl_Channel) NULL) { Tcl_Close(NULL, c); if (Tcl_EvalFile(interp, fullName) != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); |
︙ | ︙ | |||
299 300 301 302 303 304 305 | /*---------------------------------------------------------------------- * * Tcl_Main -- * * Main program for tclsh and most other Tcl-based applications. * * Results: | | | | | | | < | | < < < | < | | | | | < < < < < < < < < < < < | | | > > > > | | > > > > > | > > > | | 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 | /*---------------------------------------------------------------------- * * Tcl_Main -- * * Main program for tclsh and most other Tcl-based applications. * * Results: * None. This procedure never returns (it exits the process when it's * done). * * Side effects: * This procedure initializes the Tcl world and then starts interpreting * commands; almost anything could happen, depending on the script being * interpreted. * *---------------------------------------------------------------------- */ void Tcl_Main(argc, argv, appInitProc) int argc; /* Number of arguments. */ char **argv; /* Array of argument strings. */ Tcl_AppInitProc *appInitProc; /* Application-specific initialization * procedure to call after most initialization * but before starting to execute commands. */ { Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL; CONST char *encodingName = NULL; PromptType prompt = PROMPT_START; int code, length, tty, exitCode = 0; Tcl_Channel inChannel, outChannel, errChannel; Tcl_Interp *interp; Tcl_DString appName; Tcl_FindExecutable(argv[0]); interp = Tcl_CreateInterp(); Tcl_InitMemory(interp); /* * If the application has not already set a startup script, parse the * first few command line arguments to determine the script path and * encoding. */ if (NULL == Tcl_GetStartupScript(NULL)) { /* * Check whether first 3 args (argv[1] - argv[3]) look like * -encoding ENCODING FILENAME * or like * FILENAME */ if ((argc > 3) && (0 == strcmp("-encoding", argv[1])) && ('-' != argv[3][0])) { Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]); argc -= 3; argv += 3; } else if ((argc > 1) && ('-' != argv[1][0])) { Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL); argc--; argv++; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName); } else { CONST char *pathName = Tcl_GetStringFromObj(path, &length); Tcl_ExternalToUtfDString(NULL, pathName, length, &appName); path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1); Tcl_SetStartupScript(path, encodingName); } Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY); Tcl_DStringFree(&appName); argc--; argv++; Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { Tcl_DString ds; Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds); Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj( Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); Tcl_DStringFree(&ds); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. */ tty = isatty(0); Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. */ Tcl_Preserve((ClientData) interp); if ((*appInitProc)(interp) != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); |
︙ | ︙ | |||
420 421 422 423 424 425 426 | goto done; } if (Tcl_LimitExceeded(interp)) { goto done; } /* | | | < | 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 | goto done; } if (Tcl_LimitExceeded(interp)) { goto done; } /* * If a script file was specified then just source that file and quit. * Must fetch it again, as the appInitProc might have reset it. */ path = Tcl_GetStartupScript(&encodingName); if (path != NULL) { code = Tcl_FSEvalFileEx(interp, path, encodingName); if (code != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); |
︙ | ︙ | |||
448 449 450 451 452 453 454 | } Tcl_WriteChars(errChannel, "\n", 1); } exitCode = 1; } goto done; } | < | | | | | > | | < | | < | | | | 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 | } Tcl_WriteChars(errChannel, "\n", 1); } exitCode = 1; } goto done; } /* * We're running interactively. Source a user-specific startup file if the * application specified one and if the file exists. */ Tcl_SourceRCFile(interp); if (Tcl_LimitExceeded(interp)) { goto done; } /* * Process commands from stdin until there's an end-of-file. Note that we * need to fetch the standard channels again after every eval, since they * may have been changed. */ commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); /* * Get a new value for tty if anyone writes to ::tcl_interactive */ Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) { if (tty) { Prompt(interp, &prompt); if (Tcl_InterpDeleted(interp)) { break; } if (Tcl_LimitExceeded(interp)) { break; } inChannel = Tcl_GetStdChannel(TCL_STDIN); if (inChannel == (Tcl_Channel) NULL) { break; } } if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } length = Tcl_GetsObj(inChannel, commandPtr); if (length < 0) { if (Tcl_InputBlocked(inChannel)) { /* * This can only happen if stdin has been set to non-blocking. * In that case cycle back and try again. This sets up a tight * polling loop (since we have no event loop running). If this * causes bad CPU hogging, we might try toggling the blocking * on stdin instead. */ continue; } /* * Either EOF, or an error on stdin; we're done */ break; } if (!TclObjCommandComplete(commandPtr)) { |
︙ | ︙ | |||
555 556 557 558 559 560 561 | Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && outChannel) { Tcl_WriteObj(outChannel, resultPtr); Tcl_WriteChars(outChannel, "\n", 1); } Tcl_DecrRefCount(resultPtr); } | < > | | | | | | 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 | Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && outChannel) { Tcl_WriteObj(outChannel, resultPtr); Tcl_WriteChars(outChannel, "\n", 1); } Tcl_DecrRefCount(resultPtr); } if (mainLoopProc != NULL) { /* * If a main loop has been defined while running interactively, we * want to start a fileevent based prompt by establishing a * channel handler for stdin. */ InteractiveState *isPtr = NULL; if (inChannel) { if (tty) { Prompt(interp, &prompt); } isPtr = (InteractiveState *) ckalloc((int) sizeof(InteractiveState)); isPtr->input = inChannel; isPtr->tty = tty; isPtr->commandPtr = commandPtr; isPtr->prompt = prompt; isPtr->interp = interp; |
︙ | ︙ | |||
608 609 610 611 612 613 614 | inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); errChannel = Tcl_GetStdChannel(TCL_STDERR); } #ifdef TCL_MEM_DEBUG /* | | | | < | | | | | | < | | > | > | | | | | | | | | | | | | | | | | | < | | | | | > | | | | | < | 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 | inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); errChannel = Tcl_GetStdChannel(TCL_STDERR); } #ifdef TCL_MEM_DEBUG /* * This code here only for the (unsupported and deprecated) [checkmem] * command. */ if (tclMemDumpFileName != NULL) { mainLoopProc = NULL; Tcl_DeleteInterp(interp); } #endif } done: if ((exitCode == 0) && (mainLoopProc != NULL) && !Tcl_LimitExceeded(interp)) { /* * If everything has gone OK so far, call the main loop proc, if it * exists. Packages (like Tk) can set it to start processing events at * this point. */ (*mainLoopProc)(); mainLoopProc = NULL; } if (commandPtr != NULL) { Tcl_DecrRefCount(commandPtr); } /* * Rather than calling exit, invoke the "exit" command so that users can * replace "exit" with some other command to do additional cleanup on * exit. The Tcl_EvalObjEx call should never return. */ if (!Tcl_InterpDeleted(interp)) { if (!Tcl_LimitExceeded(interp)) { Tcl_Obj *cmd = Tcl_NewObj(); TclObjPrintf(NULL, cmd, "exit %d", exitCode); Tcl_IncrRefCount(cmd); Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(cmd); } /* * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual * is happening. Maybe interp has been deleted; maybe [exit] was * redefined, maybe we've blown up because of an exceeded limit. We * still want to cleanup and exit. */ if (!Tcl_InterpDeleted(interp)) { Tcl_DeleteInterp(interp); } } Tcl_SetStartupScript(NULL, NULL); /* * If we get here, the master interp has been deleted. Allow its * destruction with the last matching Tcl_Release. */ Tcl_Release((ClientData) interp); Tcl_Exit(exitCode); } /* *--------------------------------------------------------------- * * Tcl_SetMainLoop -- * * Sets an alternative main loop procedure. * * Results: * Returns the previously defined main loop procedure. * * Side effects: * This procedure will be called before Tcl exits, allowing for the * creation of an event loop. * *--------------------------------------------------------------- */ void Tcl_SetMainLoop(proc) Tcl_MainLoopProc *proc; { mainLoopProc = proc; } /* *---------------------------------------------------------------------- * * StdinProc -- * * This procedure is invoked by the event dispatcher whenever standard * input becomes readable. It grabs the next line of input characters, * adds them to a command being assembled, and executes the command if * it's complete. * * Results: * None. * * Side effects: * Could be almost arbitrary, depending on the command that's typed. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void StdinProc(clientData, mask) ClientData clientData; /* The state of interactive cmd line */ int mask; /* Not used. */ { InteractiveState *isPtr = (InteractiveState *) clientData; Tcl_Channel chan = isPtr->input; Tcl_Obj *commandPtr = isPtr->commandPtr; Tcl_Interp *interp = isPtr->interp; int code, length; if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } length = Tcl_GetsObj(chan, commandPtr); if (length < 0) { if (Tcl_InputBlocked(chan)) { return; } if (isPtr->tty) { /* * Would be better to find a way to exit the mainLoop? Or perhaps * evaluate [exit]? Leaving as is for now due to compatibility * concerns. */ Tcl_Exit(0); } Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) isPtr); return; } if (!TclObjCommandComplete(commandPtr)) { if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } Tcl_AppendToObj(commandPtr, "\n", 1); isPtr->prompt = PROMPT_CONTINUE; goto prompt; } isPtr->prompt = PROMPT_START; /* * Disable the stdin channel handler while evaluating the command; * otherwise if the command re-enters the event loop we might process * commands from stdin before the current command is finished. Among other * things, this will trash the text of the command being evaluated. */ Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) isPtr); code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(commandPtr); isPtr->commandPtr = commandPtr = Tcl_NewObj(); |
︙ | ︙ | |||
802 803 804 805 806 807 808 | Tcl_DecrRefCount(resultPtr); } /* * If a tty stdin is still around, output a prompt. */ | | | | | < | | | | > | | > | | | | > > > > > > > > > | 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 | Tcl_DecrRefCount(resultPtr); } /* * If a tty stdin is still around, output a prompt. */ prompt: if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) { Prompt(interp, &(isPtr->prompt)); isPtr->input = Tcl_GetStdChannel(TCL_STDIN); } } /* *---------------------------------------------------------------------- * * Prompt -- * * Issue a prompt on standard output, or invoke a script to issue the * prompt. * * Results: * None. * * Side effects: * A prompt gets output, and a Tcl script may be evaluated in interp. * *---------------------------------------------------------------------- */ static void Prompt(interp, promptPtr) Tcl_Interp *interp; /* Interpreter to use for prompting. */ PromptType *promptPtr; /* Points to type of prompt to print. Filled * with PROMPT_NONE after a prompt is * printed. */ { Tcl_Obj *promptCmdPtr; int code; Tcl_Channel outChannel, errChannel; if (*promptPtr == PROMPT_NONE) { return; } promptCmdPtr = Tcl_GetVar2Ex(interp, ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); if (Tcl_InterpDeleted(interp)) { return; } if (promptCmdPtr == NULL) { defaultPrompt: outChannel = Tcl_GetStdChannel(TCL_STDOUT); if ((*promptPtr == PROMPT_START) && (outChannel != (Tcl_Channel) NULL)) { Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT, strlen(DEFAULT_PRIMARY_PROMPT)); } } else { code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel != (Tcl_Channel) NULL) { Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); Tcl_WriteChars(errChannel, "\n", 1); } goto defaultPrompt; } } outChannel = Tcl_GetStdChannel(TCL_STDOUT); if (outChannel != (Tcl_Channel) NULL) { Tcl_Flush(outChannel); } *promptPtr = PROMPT_NONE; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclNamesp.c.
1 2 3 4 5 6 7 | /* * tclNamesp.c -- * * Contains support for namespaces, which provide a separate context of * commands and global variables. The global :: namespace is the * traditional Tcl "global" scope. Other namespaces are created as * children of the global namespace. These other namespaces contain | | | | | | | | | | < | | | < | | | | | | | | | | | | | < | | | | | | | | | > | | | | | > | | | | | | < < < | | | | | > > > > | < | < | | < | | | | | | | | < < < | < | | | < | < | | | < | < | | | < < < < < < < < < < < | | > > > > > > | | < | | | < | < | | > | | | | < | < | | < | < | | < < | < | | < | | | < | | | | | < | > > > | | | | | | | | | | | | 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 | /* * tclNamesp.c -- * * Contains support for namespaces, which provide a separate context of * commands and global variables. The global :: namespace is the * traditional Tcl "global" scope. Other namespaces are created as * children of the global namespace. These other namespaces contain * special-purpose commands and variables for packages. Also includes * the TIP#112 ensemble machinery. * * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2002-2005 Donal K. Fellows. * * Originally implemented by * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * [email protected] * * 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.66.2.10 2005/09/15 20:58:39 dgp Exp $ */ #include "tclInt.h" /* * Initial size of stack allocated space for tail list - used when resetting * shadowed command references in the functin: TclResetShadowedCmdRefs. */ #define NUM_TRAIL_ELEMS 5 /* * Thread-local storage used to avoid having a global lock on data that is not * limited to a single interpreter. */ typedef struct ThreadSpecificData { long numNsCreated; /* Count of the number of namespaces created * within the thread. This value is used as a * unique id for each namespace. Cannot be * per-interp because the nsId is used to * distinguish objects which can be passed * around between interps in the same thread, * but does not need to be global because * object internal reps are always per-thread * anyway. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * This structure contains a cached pointer to a namespace that is the result * of resolving the namespace's name in some other namespace. It is the * internal representation for a nsName object. It contains the pointer along * with some information that is used to check the cached pointer's validity. */ typedef struct ResolvedNsName { Namespace *nsPtr; /* A cached namespace pointer. */ long nsId; /* nsPtr's unique namespace id. Used to verify * that nsPtr is still valid (e.g., it's * possible that the namespace was deleted and * a new one created at the same address). */ Namespace *refNsPtr; /* Points to the namespace containing the * reference (not the namespace that contains * the referenced namespace). */ int refCount; /* Reference count: 1 for each nsName object * that has a pointer to this ResolvedNsName * structure as its internal rep. This * structure can be freed when refCount * becomes zero. */ } ResolvedNsName; /* * The client data for an ensemble command. This consists of the table of * commands that are actually exported by the namespace, and an epoch counter * that, combined with the exportLookupEpoch field of the namespace structure, * defines whether the table contains valid data or will need to be recomputed * next time the ensemble command is called. */ typedef struct EnsembleConfig { Namespace *nsPtr; /* The namspace backing this ensemble up. */ Tcl_Command token; /* The token for the command that provides * ensemble support for the namespace, or NULL * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ int epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same * number of entries as there are entries in * the subcommandTable hash. */ Tcl_HashTable subcommandTable; /* Hash table of ensemble subcommand names, * which are its keys so this also provides * the storage management for those subcommand * names. The contents of the entry values are * object version the prefix lists to use when * substituting for the command/subcommand to * build the ensemble implementation command. * Has to be stored here as well as in * subcommandDict because that field is NULL * when we are deriving the ensemble from the * namespace exports list. FUTURE WORK: use * object hash table here. */ struct EnsembleConfig *next;/* The next ensemble in the linked list of * ensembles associated with a namespace. If * this field points to this ensemble, the * structure has already been unlinked from * all lists, and cannot be found by scanning * the list from the namespace's ensemble * field. */ int flags; /* ORed combo of ENS_DEAD and * TCL_ENSEMBLE_PREFIX. */ /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */ Tcl_Obj *subcommandDict; /* Dictionary providing mapping from * subcommands to their implementing command * prefixes, or NULL if we are to build the * map automatically from the namespace * exports. */ Tcl_Obj *subcmdList; /* List of commands that this ensemble * actually provides, and whose implementation * will be built using the subcommandDict (if * present and defined) and by simple mapping * to the namespace otherwise. If NULL, * indicates that we are using the (dynamic) * list of currently exported commands. */ Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when * no match is found (according to the rule * defined by flag bit TCL_ENSEMBLE_PREFIX) or * NULL to use the default error-generating * behaviour. The script execution gets all * the arguments to the ensemble command * (including objv[0]) and will have the * results passed directly back to the caller * (including the error code) unless the code * is TCL_CONTINUE in which case the * subcommand will be reparsed by the ensemble * core, presumably because the ensemble * itself has been updated. */ } EnsembleConfig; #define ENS_DEAD 0x1 /* Flag value to say that the ensemble is dead * and on its way out. */ /* * The data cached in a subcommand's Tcl_Obj rep. This structure is not shared * between Tcl_Objs referring to the same subcommand, even where one is a * duplicate of another. */ typedef struct EnsembleCmdRep { Namespace *nsPtr; /* The namespace backing the ensemble which * this is a subcommand of. */ int epoch; /* Used to confirm when the data in this * really structure matches up with the * ensemble. */ Tcl_Command token; /* Reference to the comamnd for which this * structure is a cache of the resolution. */ char *fullSubcmdName; /* The full (local) name of the subcommand, * allocated with ckalloc(). */ Tcl_Obj *realPrefixObj; /* Object containing the prefix words of the * command that implements this ensemble * subcommand. */ } EnsembleCmdRep; /* * Declarations for functions local to this file: */ static void DeleteImportedCmd(ClientData clientData); static int DoImport(Tcl_Interp *interp, Namespace *nsPtr, Tcl_HashEntry *hPtr, CONST char *cmdName, CONST char *pattern, Namespace *importNsPtr, int allowOverwrite); static void DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr); static char * ErrorCodeRead(ClientData clientData,Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags); static char * ErrorInfoRead(ClientData clientData,Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags); static char * EstablishErrorCodeTraces(ClientData clientData, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags); static char * EstablishErrorInfoTraces(ClientData clientData, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags); static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int InvokeImportedCmd(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); static int NamespaceChildrenCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int NamespaceCurrentCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int NamespaceEnsembleCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static void NamespaceFree(Namespace *nsPtr); static int NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int NamespaceInscopeCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int NamespacePathCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int NamespaceQualifiersCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); static int NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfNsName(Tcl_Obj *objPtr); static int NsEnsembleImplementationCmd(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); static int NsEnsembleStringOrder(CONST VOID *strPtr1, CONST VOID *strPtr2); static void DeleteEnsembleConfig(ClientData clientData); static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr, CONST char *subcmdName, Tcl_Obj *prefixObjPtr); static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); static void UnlinkNsPath(Namespace *nsPtr); static void SetNsPath(Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* * This structure defines a Tcl object type that contains a namespace * reference. It is used in commands that take the name of a namespace as an * argument. The namespace reference is resolved, and the result in cached in * the object. */ Tcl_ObjType tclNsNameType = { "nsName", /* the type's name */ FreeNsNameInternalRep, /* freeIntRepProc */ DupNsNameInternalRep, /* dupIntRepProc */ UpdateStringOfNsName, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; /* * This structure defines a Tcl object type that contains a reference to an * ensemble subcommand (e.g. the "length" in [string length ab]) It is used to * cache the mapping between the subcommand itself and the real command that * implements it. */ static Tcl_ObjType ensembleCmdType = { "ensembleCommand", /* the type's name */ FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ StringOfEnsembleCmdRep, /* updateStringProc */ NULL /* setFromAnyProc */ }; /* *---------------------------------------------------------------------- * * TclInitNamespaceSubsystem -- * * This function is called to initialize all the structures that are used * by namespaces on a per-process basis. * * Results: * None. * * Side effects: * None. * |
︙ | ︙ | |||
342 343 344 345 346 347 348 | * None. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetCurrentNamespace(interp) | | | | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 | * None. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetCurrentNamespace(interp) register Tcl_Interp *interp;/* Interpreter whose current namespace is * being queried. */ { register Interp *iPtr = (Interp *) interp; register Namespace *nsPtr; if (iPtr->varFramePtr != NULL) { nsPtr = iPtr->varFramePtr->nsPtr; } else { |
︙ | ︙ | |||
374 375 376 377 378 379 380 | * None. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetGlobalNamespace(interp) | | | | | | | | | | | | | | | | | < | | | < | | | | < | | | | > | 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 | * None. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetGlobalNamespace(interp) register Tcl_Interp *interp;/* Interpreter whose global namespace should * be returned. */ { register Interp *iPtr = (Interp *) interp; return (Tcl_Namespace *) iPtr->globalNsPtr; } /* *---------------------------------------------------------------------- * * Tcl_PushCallFrame -- * * Pushes a new call frame onto the interpreter's Tcl call stack. Called * when executing a Tcl procedure or a "namespace eval" or "namespace * inscope" command. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter's result object) if something goes wrong. * * Side effects: * Modifies the interpreter's Tcl call stack. * *---------------------------------------------------------------------- */ int Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame) Tcl_Interp *interp; /* Interpreter in which the new call frame is * to be pushed. */ Tcl_CallFrame *callFramePtr;/* Points to a call frame structure to push. * Storage for this has already been allocated * by the caller; typically this is the * address of a CallFrame structure allocated * on the caller's C stack. The call frame * will be initialized by this function. The * caller can pop the frame later with * Tcl_PopCallFrame, and it is responsible for * freeing the frame's storage. */ Tcl_Namespace *namespacePtr;/* Points to the namespace in which the frame * will execute. If NULL, the interpreter's * current namespace will be used. */ int isProcCallFrame; /* If nonzero, the frame represents a called * Tcl procedure and may have local vars. Vars * will ordinarily be looked up in the frame. * If new variables are created, they will be * created in the frame. If 0, the frame is * for a "namespace eval" or "namespace * inscope" command and var references are * treated as references to namespace * variables. */ { Interp *iPtr = (Interp *) interp; register CallFrame *framePtr = (CallFrame *) callFramePtr; register Namespace *nsPtr; if (namespacePtr == NULL) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); |
︙ | ︙ | |||
455 456 457 458 459 460 461 | framePtr->callerPtr = iPtr->framePtr; framePtr->callerVarPtr = iPtr->varFramePtr; if (iPtr->varFramePtr != NULL) { framePtr->level = (iPtr->varFramePtr->level + 1); } else { framePtr->level = 1; } | | | | | | | < | | | < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | framePtr->callerPtr = iPtr->framePtr; framePtr->callerVarPtr = iPtr->varFramePtr; if (iPtr->varFramePtr != NULL) { framePtr->level = (iPtr->varFramePtr->level + 1); } else { framePtr->level = 1; } framePtr->procPtr = NULL; /* no called procedure */ framePtr->varTablePtr = NULL; /* and no local variables */ framePtr->numCompiledLocals = 0; framePtr->compiledLocals = NULL; /* * Push the new call frame onto the interpreter's stack of procedure call * frames making it the current frame. */ iPtr->framePtr = framePtr; iPtr->varFramePtr = framePtr; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_PopCallFrame -- * * Removes a call frame from the Tcl call stack for the interpreter. * Called to remove a frame previously pushed by Tcl_PushCallFrame. * * Results: * None. * * Side effects: * Modifies the call stack of the interpreter. Resets various fields of * the popped call frame. If a namespace has been deleted and has no more * activations on the call stack, the namespace is destroyed. * *---------------------------------------------------------------------- */ void Tcl_PopCallFrame(interp) Tcl_Interp* interp; /* Interpreter with call frame to pop. */ { register Interp *iPtr = (Interp *) interp; register CallFrame *framePtr = iPtr->framePtr; Namespace *nsPtr; /* * It's important to remove the call frame from the interpreter's stack of * call frames before deleting local variables, so that traces invoked by * the variable deletion don't see the partially-deleted frame. */ iPtr->framePtr = framePtr->callerPtr; iPtr->varFramePtr = framePtr->callerVarPtr; if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); ckfree((char *) framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); } /* * Decrement the namespace's count of active call frames. If the namespace * is "dying" and there are no more active call frames, call * Tcl_DeleteNamespace to destroy it. */ nsPtr = framePtr->nsPtr; nsPtr->activationCount--; if ((nsPtr->flags & NS_DYING) && (nsPtr->activationCount == 0)) { Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); } framePtr->nsPtr = NULL; } /* *---------------------------------------------------------------------- * * TclPushStackFrame -- * * Allocates a new call frame in the interpreter's execution stack, then * pushes it onto the interpreter's Tcl call stack. Called when executing * a Tcl procedure or a "namespace eval" or "namespace inscope" command. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter's result object) if something goes wrong. * * Side effects: * Modifies the interpreter's Tcl call stack. * *---------------------------------------------------------------------- */ int TclPushStackFrame(interp, framePtrPtr, namespacePtr, isProcCallFrame) Tcl_Interp *interp; /* Interpreter in which the new call frame is * to be pushed. */ Tcl_CallFrame **framePtrPtr;/* Place to store a pointer to the stack * allocated call frame.*/ Tcl_Namespace *namespacePtr;/* Points to the namespace in which the frame * will execute. If NULL, the interpreter's * current namespace will be used. */ int isProcCallFrame; /* If nonzero, the frame represents a called * Tcl procedure and may have local vars. Vars * will ordinarily be looked up in the frame. * If new variables are created, they will be * created in the frame. If 0, the frame is * for a "namespace eval" or "namespace * inscope" command and var references are * treated as references to namespace * variables. */ { *framePtrPtr = (Tcl_CallFrame *) TclStackAlloc(interp, sizeof(CallFrame)); return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr, isProcCallFrame); } void TclPopStackFrame(interp) Tcl_Interp* interp; /* Interpreter with call frame to pop. */ { Tcl_PopCallFrame(interp); TclStackFree(interp); } /* *---------------------------------------------------------------------- * * EstablishErrorCodeTraces -- * * Creates traces on the ::errorCode variable to keep its value |
︙ | ︙ | |||
568 569 570 571 572 573 574 | } /* *---------------------------------------------------------------------- * * ErrorCodeRead -- * | | | | | > | > | 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 | } /* *---------------------------------------------------------------------- * * ErrorCodeRead -- * * Called when the ::errorCode variable is read. Copies the current value * of the interp's errorCode field into ::errorCode. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static char * ErrorCodeRead(clientData, interp, name1, name2, flags) ClientData clientData; Tcl_Interp *interp; CONST char *name1; CONST char *name2; int flags; { Interp *iPtr = (Interp *)interp; if (flags & TCL_INTERP_DESTROYED || iPtr->errorCode == NULL) { return NULL; } Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, iPtr->errorCode, TCL_GLOBAL_ONLY); return NULL; } /* *---------------------------------------------------------------------- * * EstablishErrorInfoTraces -- |
︙ | ︙ | |||
633 634 635 636 637 638 639 | } /* *---------------------------------------------------------------------- * * ErrorInfoRead -- * | | | | | > | > | | | | | | < | | | | | | | | | < | | < | | < | | | | < | | | | | | 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 | } /* *---------------------------------------------------------------------- * * ErrorInfoRead -- * * Called when the ::errorInfo variable is read. Copies the current value * of the interp's errorInfo field into ::errorInfo. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static char * ErrorInfoRead(clientData, interp, name1, name2, flags) ClientData clientData; Tcl_Interp *interp; CONST char *name1; CONST char *name2; int flags; { Interp *iPtr = (Interp *)interp; if (flags & TCL_INTERP_DESTROYED || iPtr->errorInfo == NULL) { return NULL; } Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY); return NULL; } /* *---------------------------------------------------------------------- * * Tcl_CreateNamespace -- * * Creates a new namespace with the given name. If there is no active * namespace (i.e., the interpreter is being initialized), the global :: * namespace is created and returned. * * Results: * Returns a pointer to the new namespace if successful. If the namespace * already exists or if another error occurs, this routine returns NULL, * along with an error message in the interpreter's result object. * * Side effects: * If the name contains "::" qualifiers and a parent namespace does not * already exist, it is automatically created. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_CreateNamespace(interp, name, clientData, deleteProc) Tcl_Interp *interp; /* Interpreter in which a new namespace is * being created. Also used for error * reporting. */ CONST char *name; /* Name for the new namespace. May be a * qualified name with names of ancestor * namespaces separated by "::"s. */ ClientData clientData; /* One-word value to store with namespace. */ Tcl_NamespaceDeleteProc *deleteProc; /* Function called to delete client data when * the namespace is deleted. NULL if no * function should be called. */ { Interp *iPtr = (Interp *) interp; register Namespace *nsPtr, *ancestorPtr; Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; Namespace *globalNsPtr = iPtr->globalNsPtr; CONST char *simpleName; Tcl_HashEntry *entryPtr; Tcl_DString buffer1, buffer2; int newEntry; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * If there is no active namespace, the interpreter is being initialized. */ if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) { /* * Treat this namespace as the global namespace, and avoid looking for * a parent. */ parentPtr = NULL; simpleName = ""; } else if (*name == '\0') { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't create namespace \"\": ", "only global namespace can have empty name", NULL); return NULL; } else { /* * Find the parent for the new namespace. */ TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, /*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); /* * If the unqualified name at the end is empty, there were trailing * "::"s after the namespace's name which we ignore. The new namespace * was already (recursively) created and is pointed to by parentPtr. */ if (*simpleName == '\0') { return (Tcl_Namespace *) parentPtr; } /* * Check for a bad namespace name and make sure that the name does not * already exist in the parent namespace. */ if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { Tcl_AppendResult(interp, "can't create namespace \"", name, "\": already exists", (char *) NULL); return NULL; } } /* * Create the new namespace and root it in its parent. Increment the count * of namespaces created. */ nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1)); strcpy(nsPtr->name, simpleName); nsPtr->fullName = NULL; /* set below */ nsPtr->clientData = clientData; |
︙ | ︙ | |||
789 790 791 792 793 794 795 796 797 798 799 800 801 | nsPtr->cmdRefEpoch = 0; nsPtr->resolverEpoch = 0; nsPtr->cmdResProc = NULL; nsPtr->varResProc = NULL; nsPtr->compiledVarResProc = NULL; nsPtr->exportLookupEpoch = 0; nsPtr->ensembles = NULL; if (parentPtr != NULL) { entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, &newEntry); Tcl_SetHashValue(entryPtr, (ClientData) nsPtr); } else { | > > > | | | > | 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 | nsPtr->cmdRefEpoch = 0; nsPtr->resolverEpoch = 0; nsPtr->cmdResProc = NULL; nsPtr->varResProc = NULL; nsPtr->compiledVarResProc = NULL; nsPtr->exportLookupEpoch = 0; nsPtr->ensembles = NULL; nsPtr->commandPathLength = 0; nsPtr->commandPathArray = NULL; nsPtr->commandPathSourceList = NULL; if (parentPtr != NULL) { entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, &newEntry); Tcl_SetHashValue(entryPtr, (ClientData) nsPtr); } else { /* * In the global namespace create traces to maintain the ::errorInfo * and ::errorCode variables. */ iPtr->globalNsPtr = nsPtr; EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0); EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0); } /* * Build the fully qualified name for this namespace. |
︙ | ︙ | |||
849 850 851 852 853 854 855 | * Deletes a namespace and all of the commands, variables, and other * namespaces within it. * * Results: * None. * * Side effects: | | | | | | | | < | > > | < | | | | | | | | | | | | | | | 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 | * Deletes a namespace and all of the commands, variables, and other * namespaces within it. * * Results: * None. * * Side effects: * When a namespace is deleted, it is automatically removed as a child of * its parent namespace. Also, all its commands, variables and child * namespaces are deleted. * *---------------------------------------------------------------------- */ void Tcl_DeleteNamespace(namespacePtr) Tcl_Namespace *namespacePtr; /* Points to the namespace to delete */ { register Namespace *nsPtr = (Namespace *) namespacePtr; Interp *iPtr = (Interp *) nsPtr->interp; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); Tcl_HashEntry *entryPtr; /* * If the namespace has associated ensemble commands, delete them first. * This leaves the actual contents of the namespace alone (unless they are * linked ensemble commands, of course). Note that this code is actually * reentrant so command delete traces won't purturb things badly. */ while (nsPtr->ensembles != NULL) { EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles; /* * Splice out and link to indicate that we've already been killed. */ nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; ensemblePtr->next = ensemblePtr; Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token); } /* * If the namespace is on the call frame stack, it is marked as "dying" * (NS_DYING is OR'd into its flags): the namespace can't be looked up by * name but its commands and variables are still usable by those active * call frames. When all active call frames referring to the namespace * have been popped from the Tcl stack, Tcl_PopCallFrame will call this * function again to delete everything in the namespace. If no nsName * objects refer to the namespace (i.e., if its refCount is zero), its * commands and variables are deleted and the storage for its namespace * structure is freed. Otherwise, if its refCount is nonzero, the * namespace's commands and variables are deleted but the structure isn't * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the * namespace resolution code to recognize that the namespace is "deleted". * The structure's storage is freed by FreeNsNameInternalRep when its * refCount reaches 0. */ if (nsPtr->activationCount > 0) { nsPtr->flags |= NS_DYING; if (nsPtr->parentPtr != NULL) { entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, nsPtr->name); |
︙ | ︙ | |||
924 925 926 927 928 929 930 | */ TclTeardownNamespace(nsPtr); if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { /* * If this is the global namespace, then it may have residual | | | | > | > > | | 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 | */ TclTeardownNamespace(nsPtr); if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { /* * If this is the global namespace, then it may have residual * "errorInfo" and "errorCode" variables for errors that occurred * while it was being torn down. Try to clear the variable list * one last time. */ TclDeleteVars((Interp *) nsPtr->interp, &nsPtr->varTable); Tcl_DeleteHashTable(&nsPtr->childTable); Tcl_DeleteHashTable(&nsPtr->cmdTable); /* * If the reference count is 0, then discard the namespace. * Otherwise, mark it as "dead" so that it can't be used. */ if (nsPtr->refCount == 0) { NamespaceFree(nsPtr); } else { nsPtr->flags |= NS_DEAD; } } else { /* * Restore the ::errorInfo and ::errorCode traces. */ EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0); EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0); } } } /* *---------------------------------------------------------------------- * * TclTeardownNamespace -- * * Used internally to dismantle and unlink a namespace when it is * deleted. Divorces the namespace from its parent, and deletes all * commands, variables, and child namespaces. * * This is kept separate from Tcl_DeleteNamespace so that the global * namespace can be handled specially. * * Results: * None. * * Side effects: * Removes this namespace from its parent's child namespace hashtable. * Deletes all commands, variables and namespaces in this namespace. |
︙ | ︙ | |||
987 988 989 990 991 992 993 | register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Tcl_Namespace *childNsPtr; Tcl_Command cmd; int i; /* | | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Tcl_Namespace *childNsPtr; Tcl_Command cmd; int i; /* * Start by destroying the namespace's variable table, since variables * might trigger traces. Variable table should be cleared but not freed! * TclDeleteVars frees it, so we reinitialize it afterwards. */ TclDeleteVars(iPtr, &nsPtr->varTable); Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); /* * Delete all commands in this namespace. Be careful when traversing the * hash table: when each command is deleted, it removes itself from the * command table. * * Don't optimize to Tcl_NextHashEntry() because of traces. */ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL; entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); } Tcl_DeleteHashTable(&nsPtr->cmdTable); Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); /* * Remove the namespace from its parent's child hashtable. */ if (nsPtr->parentPtr != NULL) { entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, nsPtr->name); if (entryPtr != NULL) { Tcl_DeleteHashEntry(entryPtr); } } nsPtr->parentPtr = NULL; /* * Delete the namespace path if one is installed. */ if (nsPtr->commandPathLength != 0) { UnlinkNsPath(nsPtr); nsPtr->commandPathLength = 0; } if (nsPtr->commandPathSourceList != NULL) { NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; do { nsPathPtr->nsPtr = NULL; nsPathPtr = nsPathPtr->nextPtr; } while (nsPathPtr != NULL); } /* * Delete all the child namespaces. * * BE CAREFUL: When each child is deleted, it will divorce itself from its * parent. You can't traverse a hash table properly if its elements are * being deleted. We use only the Tcl_FirstHashEntry function to be * safe. * * Don't optimize to Tcl_NextHashEntry() because of traces. */ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); entryPtr != NULL; entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr); Tcl_DeleteNamespace(childNsPtr); } /* * Free the namespace's export pattern array. */ if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { |
︙ | ︙ | |||
1069 1070 1071 1072 1073 1074 1075 | if (nsPtr->deleteProc != NULL) { (*nsPtr->deleteProc)(nsPtr->clientData); } nsPtr->deleteProc = NULL; nsPtr->clientData = NULL; /* | | | | | < | | 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 | if (nsPtr->deleteProc != NULL) { (*nsPtr->deleteProc)(nsPtr->clientData); } nsPtr->deleteProc = NULL; nsPtr->clientData = NULL; /* * Reset the namespace's id field to ensure that this namespace won't be * interpreted as valid by, e.g., the cache validation code for cached * command references in Tcl_GetCommandFromObj. */ nsPtr->nsId = 0; } /* *---------------------------------------------------------------------- * * NamespaceFree -- * * Called after a namespace has been deleted, when its reference count * reaches 0. Frees the data structure representing the namespace. * * Results: * None. * * Side effects: * None. * |
︙ | ︙ | |||
1117 1118 1119 1120 1121 1122 1123 | /* *---------------------------------------------------------------------- * * Tcl_Export -- * * Makes all the commands matching a pattern available to later be | | | | | | | | | | | | | < | | | | 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 | /* *---------------------------------------------------------------------- * * Tcl_Export -- * * Makes all the commands matching a pattern available to later be * imported from the namespace specified by namespacePtr (or the current * namespace if namespacePtr is NULL). The specified pattern is appended * onto the namespace's export pattern list, which is optionally cleared * beforehand. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter's result) if something goes wrong. * * Side effects: * Appends the export pattern onto the namespace's export list. * Optionally reset the namespace's export pattern list. * *---------------------------------------------------------------------- */ int Tcl_Export(interp, namespacePtr, pattern, resetListFirst) Tcl_Interp *interp; /* Current interpreter. */ Tcl_Namespace *namespacePtr;/* Points to the namespace from which commands * are to be exported. NULL for the current * namespace. */ CONST char *pattern; /* String pattern indicating which commands to * export. This pattern may not include any * namespace qualifiers; only commands in the * specified namespace may be exported. */ int resetListFirst; /* If nonzero, resets the namespace's export * list before appending. */ { #define INIT_EXPORT_PATTERNS 5 Namespace *nsPtr, *exportNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); CONST char *simplePattern; char *patternCpy; int neededElems, len, i; /* |
︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 | "\": pattern can't specify a namespace", (char *) NULL); return TCL_ERROR; } /* * Make sure that we don't already have the pattern in the array */ if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) { /* * The pattern already exists in the list */ return TCL_OK; } } } /* | > | | | | | | < | | | | | | | | | | | 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 | "\": pattern can't specify a namespace", (char *) NULL); return TCL_ERROR; } /* * Make sure that we don't already have the pattern in the array */ if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) { /* * The pattern already exists in the list */ return TCL_OK; } } } /* * Make sure there is room in the namespace's pattern array for the new * pattern. */ neededElems = nsPtr->numExportPatterns + 1; if (nsPtr->exportArrayPtr == NULL) { nsPtr->exportArrayPtr = (char **) ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *))); nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS; } else if (neededElems > nsPtr->maxExportPatterns) { int numNewElems = 2 * nsPtr->maxExportPatterns; size_t currBytes = nsPtr->numExportPatterns * sizeof(char *); size_t newBytes = numNewElems * sizeof(char *); char **newPtr = (char **) ckalloc((unsigned) newBytes); memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr, currBytes); ckfree((char *) nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = (char **) newPtr; nsPtr->maxExportPatterns = numNewElems; } /* * Add the pattern to the namespace's array of export patterns. */ len = strlen(pattern); patternCpy = (char *) ckalloc((unsigned) (len + 1)); strcpy(patternCpy, pattern); nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; nsPtr->numExportPatterns++; /* * The list of commands actually exported from the namespace might have * changed (probably will have!) However, we do not need to recompute this * just yet; next time we need the info will be soon enough. */ TclInvalidateNsCmdLookup(nsPtr); return TCL_OK; #undef INIT_EXPORT_PATTERNS } /* *---------------------------------------------------------------------- * * Tcl_AppendExportList -- * * Appends onto the argument object the list of export patterns for the * specified namespace. * * Results: * The return value is normally TCL_OK; in this case the object * referenced by objPtr has each export pattern appended to it. If an * error occurs, TCL_ERROR is returned and the interpreter's result holds * an error message. * * Side effects: * If necessary, the object referenced by objPtr is converted into a list * object. * *---------------------------------------------------------------------- */ int Tcl_AppendExportList(interp, namespacePtr, objPtr) Tcl_Interp *interp; /* Interpreter used for error reporting. */ Tcl_Namespace *namespacePtr;/* Points to the namespace whose export * pattern list is appended onto objPtr. NULL * for the current namespace. */ Tcl_Obj *objPtr; /* Points to the Tcl object onto which the * export pattern list is appended. */ { Namespace *nsPtr; int i, result; /* * If the specified namespace is NULL, use the current namespace. */ |
︙ | ︙ | |||
1320 1321 1322 1323 1324 1325 1326 | /* *---------------------------------------------------------------------- * * Tcl_Import -- * * Imports all of the commands matching a pattern into the namespace | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | 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 | /* *---------------------------------------------------------------------- * * Tcl_Import -- * * Imports all of the commands matching a pattern into the namespace * specified by namespacePtr (or the current namespace if contextNsPtr is * NULL). This is done by creating a new command (the "imported command") * that points to the real command in its original namespace. * * If matching commands are on the autoload path but haven't been loaded * yet, this command forces them to be loaded, then creates the links to * them. * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter's result) if something goes wrong. * * Side effects: * Creates new commands in the importing namespace. These indirect calls * back to the real command and are deleted if the real commands are * deleted. * *---------------------------------------------------------------------- */ int Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) Tcl_Interp *interp; /* Current interpreter. */ Tcl_Namespace *namespacePtr;/* Points to the namespace into which the * commands are to be imported. NULL for the * current namespace. */ CONST char *pattern; /* String pattern indicating which commands to * import. This pattern should be qualified by * the name of the namespace from which to * import the command(s). */ int allowOverwrite; /* If nonzero, allow existing commands to be * overwritten by imported commands. If 0, * return an error if an imported cmd * conflicts with an existing one. */ { Namespace *nsPtr, *importNsPtr, *dummyPtr; CONST char *simplePattern; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; /* * If the specified namespace is NULL, use the current namespace. */ if (namespacePtr == NULL) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } /* * First, invoke the "auto_import" command with the pattern being * imported. This command is part of the Tcl library. It looks for * imported commands in autoloaded libraries and loads them in. That way, * they will be found when we try to create links below. * * Note that we don't just call Tcl_EvalObjv() directly because we do not * want absence of the command to be a failure case. */ if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) { Tcl_Obj *objv[2]; int result; objv[0] = Tcl_NewStringObj("auto_import", -1); |
︙ | ︙ | |||
1401 1402 1403 1404 1405 1406 1407 | if (result != TCL_OK) { return TCL_ERROR; } Tcl_ResetResult(interp); } /* | | | < | 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 | if (result != TCL_OK) { return TCL_ERROR; } Tcl_ResetResult(interp); } /* * From the pattern, find the namespace from which we are importing and * get the simple pattern (no namespace qualifiers or ::'s) at the end. */ if (strlen(pattern) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1)); return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, |
︙ | ︙ | |||
1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 | /* * Scan through the command table in the source namespace and look for * exported commands that match the string pattern. Create an "imported * command" in the current namespace for each imported command; these * commands redirect their invocations to the "real" command. */ for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); | > > > > > > > > | > > > > > > > > | > > > > | | > | > > > > > > > > | | < > > > > > > > > > | < < | > | > > > > | > > | | < > | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | < | < | | | | | | | | < | | | | | | | | < | | | | | | | | > > > > > | > > > | | | | | | | | | | < | | | | | | | | | | | | | < > > | | > > > > > > > | > | > | | | > | 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 | /* * Scan through the command table in the source namespace and look for * exported commands that match the string pattern. Create an "imported * command" in the current namespace for each imported command; these * commands redirect their invocations to the "real" command. */ if ((simplePattern != NULL) && TclMatchIsTrivial(simplePattern)) { hPtr = Tcl_FindHashEntry(&importNsPtr->cmdTable, simplePattern); if (hPtr == NULL) { return TCL_OK; } return DoImport(interp, nsPtr, hPtr, simplePattern, pattern, importNsPtr, allowOverwrite); } for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); if (Tcl_StringMatch(cmdName, simplePattern) && DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, allowOverwrite) == TCL_ERROR) { return TCL_ERROR; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * DoImport -- * * Import a particular command from one namespace into another. Helper * for Tcl_Import(). * * Results: * Standard Tcl result code. If TCL_ERROR, appends an error message to * the interpreter result. * * Side effects: * A new command is created in the target namespace unless this is a * reimport of exactly the same command as before. * *---------------------------------------------------------------------- */ static int DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, allowOverwrite) Tcl_Interp *interp; Namespace *nsPtr; Tcl_HashEntry *hPtr; CONST char *cmdName; CONST char *pattern; Namespace *importNsPtr; int allowOverwrite; { int i = 0, exported = 0; Tcl_HashEntry *found; /* * The command cmdName in the source namespace matches the pattern. Check * whether it was exported. If it wasn't, we ignore it. */ while (!exported && (i < importNsPtr->numExportPatterns)) { exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]); } if (!exported) { return TCL_OK; } /* * Unless there is a name clash, create an imported command in the current * namespace that refers to cmdPtr. */ found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); if ((found == NULL) || allowOverwrite) { /* * Create the imported command and its client data. To create the new * command in the current namespace, generate a fully qualified name * for it. */ Tcl_DString ds; Tcl_Command importedCmd; ImportedCmdData *dataPtr; Command *cmdPtr; ImportRef *refPtr; Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, nsPtr->fullName, -1); if (nsPtr != ((Interp *) interp)->globalNsPtr) { Tcl_DStringAppend(&ds, "::", 2); } Tcl_DStringAppend(&ds, cmdName, -1); /* * Check whether creating the new imported command in the current * namespace would create a cycle of imported command references. */ cmdPtr = (Command *) Tcl_GetHashValue(hPtr); if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) { Command *overwrite = (Command *) Tcl_GetHashValue(found); Command *link = cmdPtr; while (link->deleteProc == DeleteImportedCmd) { ImportedCmdData *dataPtr; dataPtr = (ImportedCmdData *) link->objClientData; link = dataPtr->realCmdPtr; if (overwrite == link) { Tcl_AppendResult(interp, "import pattern \"", pattern, "\" would create a loop containing command \"", Tcl_DStringValue(&ds), "\"", (char *) NULL); Tcl_DStringFree(&ds); return TCL_ERROR; } } } dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), InvokeImportedCmd, (ClientData) dataPtr, DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; dataPtr->selfPtr = (Command *) importedCmd; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; Tcl_DStringFree(&ds); /* * Create an ImportRef structure describing this new import command * and add it to the import ref list in the "real" command. */ refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); refPtr->importedCmdPtr = (Command *) importedCmd; refPtr->nextPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = refPtr; } else { Command *overwrite = (Command *) Tcl_GetHashValue(found); if (overwrite->deleteProc == DeleteImportedCmd) { ImportedCmdData *dataPtr = (ImportedCmdData *) overwrite->objClientData; if (dataPtr->realCmdPtr == (Command *) Tcl_GetHashValue(hPtr)) { /* Repeated import of same command -- acceptable */ return TCL_OK; } } Tcl_AppendResult(interp, "can't import command \"", cmdName, "\": already exists", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ForgetImport -- * * Deletes commands previously imported into the namespace indicated. * The by namespacePtr, or the current namespace of interp, when * namespacePtr is NULL. The pattern controls which imported commands are * deleted. A simple pattern, one without namespace separators, matches * the current command names of imported commands in the namespace. * Matching imported commands are deleted. A qualified pattern is * interpreted as deletion selection on the basis of where the command is * imported from. The original command and "first link" command for each * imported command are determined, and they are matched against the * pattern. A match leads to deletion of the imported command. * * Results: * Returns TCL_ERROR and records an error message in the interp result if * a namespace qualified pattern refers to a namespace that does not * exist. Otherwise, returns TCL_OK. * * Side effects: * May delete commands. * *---------------------------------------------------------------------- */ int Tcl_ForgetImport(interp, namespacePtr, pattern) Tcl_Interp *interp; /* Current interpreter. */ Tcl_Namespace *namespacePtr;/* Points to the namespace from which * previously imported commands should be * removed. NULL for current namespace. */ CONST char *pattern; /* String pattern indicating which imported * commands to remove. */ { Namespace *nsPtr, *sourceNsPtr, *dummyPtr; CONST char *simplePattern; char *cmdName; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; /* * If the specified namespace is NULL, use the current namespace. */ if (namespacePtr == NULL) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } /* * Parse the pattern into its namespace-qualification (if any) and the * simple pattern. */ TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { Tcl_AppendResult(interp, "unknown namespace in namespace forget pattern \"", pattern, "\"", (char *) NULL); return TCL_ERROR; } if (strcmp(pattern, simplePattern) == 0) { /* * The pattern is simple. Delete any imported commands that match it. */ if (TclMatchIsTrivial(simplePattern)) { Command *cmdPtr; hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if ((hPtr != NULL) && (cmdPtr = (Command *) Tcl_GetHashValue(hPtr)) && (cmdPtr->deleteProc == DeleteImportedCmd)) { Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); } return TCL_OK; } for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr); if (cmdPtr->deleteProc != DeleteImportedCmd) { continue; } cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); if (Tcl_StringMatch(cmdName, simplePattern)) { Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); } } return TCL_OK; } /* * The pattern was namespace-qualified. */ for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { Tcl_CmdInfo info; Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr); Tcl_Command origin = TclGetOriginalCommand(token); if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) { continue; /* Not an imported command */ } if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { /* * Original not in namespace we're matching. Check the first link * in the import chain. */ Command *cmdPtr = (Command *) token; ImportedCmdData *dataPtr = (ImportedCmdData *) cmdPtr->objClientData; Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; if (firstToken == origin) { continue; } |
︙ | ︙ | |||
1677 1678 1679 1680 1681 1682 1683 | /* *---------------------------------------------------------------------- * * TclGetOriginalCommand -- * * An imported command is created in an namespace when a "real" command * is imported from another namespace. If the specified command is an | | | | | | | | | | | | | | 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 | /* *---------------------------------------------------------------------- * * TclGetOriginalCommand -- * * An imported command is created in an namespace when a "real" command * is imported from another namespace. If the specified command is an * imported command, this function returns the original command it refers * to. * * Results: * If the command was imported into a sequence of namespaces a, b,...,n * where each successive namespace just imports the command from the * previous namespace, this function returns the Tcl_Command token in the * first namespace, a. Otherwise, if the specified command is not an * imported command, the function returns NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Command TclGetOriginalCommand(command) Tcl_Command command; /* The imported command for which the original * command should be returned. */ { register Command *cmdPtr = (Command *) command; ImportedCmdData *dataPtr; if (cmdPtr->deleteProc != DeleteImportedCmd) { return (Tcl_Command) NULL; } while (cmdPtr->deleteProc == DeleteImportedCmd) { dataPtr = (ImportedCmdData *) cmdPtr->objClientData; cmdPtr = dataPtr->realCmdPtr; } return (Tcl_Command) cmdPtr; } /* *---------------------------------------------------------------------- * * InvokeImportedCmd -- * * Invoked by Tcl whenever the user calls an imported command that was * created by Tcl_Import. Finds the "real" command (in another * namespace), and passes control to it. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything goes * wrong, the result object is set to an error message. * *---------------------------------------------------------------------- */ static int InvokeImportedCmd(clientData, interp, objc, objv) ClientData clientData; /* Points to the imported command's |
︙ | ︙ | |||
1752 1753 1754 1755 1756 1757 1758 | /* *---------------------------------------------------------------------- * * DeleteImportedCmd -- * * Invoked by Tcl whenever an imported command is deleted. The "real" | | | | | | | 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 | /* *---------------------------------------------------------------------- * * DeleteImportedCmd -- * * Invoked by Tcl whenever an imported command is deleted. The "real" * command keeps a list of all the imported commands that refer to it, so * those imported commands can be deleted when the real command is * deleted. This function removes the imported command reference from the * real command's list, and frees up the memory associated with the * imported command. * * Results: * None. * * Side effects: * Removes the imported command from the real command's import list. * |
︙ | ︙ | |||
1807 1808 1809 1810 1811 1812 1813 | /* *---------------------------------------------------------------------- * * TclGetNamespaceForQualName -- * * Given a qualified name specifying a command, variable, or namespace, | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | < | | | | | | | | | | | | | | | 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 | /* *---------------------------------------------------------------------- * * TclGetNamespaceForQualName -- * * Given a qualified name specifying a command, variable, or namespace, * and a namespace in which to resolve the name, this function returns a * pointer to the namespace that contains the item. A qualified name * consists of the "simple" name of an item qualified by the names of an * arbitrary number of containing namespace separated by "::"s. If the * qualified name starts with "::", it is interpreted absolutely from the * global namespace. Otherwise, it is interpreted relative to the * namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr is * NULL, the name is interpreted relative to the current namespace. * * A relative name like "foo::bar::x" can be found starting in either the * current namespace or in the global namespace. So each search usually * follows two tracks, and two possible namespaces are returned. If the * function sets either *nsPtrPtr or *altNsPtrPtr to NULL, then that path * failed. * * If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is * sought only in the global :: namespace. The alternate search (also) * starting from the global namespace is ignored and *altNsPtrPtr is set * NULL. * * If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified name is * sought only in the namespace specified by cxtNsPtr. The alternate * search starting from the global namespace is ignored and *altNsPtrPtr * is set NULL. If both TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY are * specified, TCL_GLOBAL_ONLY is ignored and the search starts from the * namespace specified by cxtNsPtr. * * If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, all namespace components * of the qualified name that cannot be found are automatically created * within their specified parent. This makes sure that functions like * Tcl_CreateCommand always succeed. There is no alternate search path, * so *altNsPtrPtr is set NULL. * * If "flags" contains TCL_FIND_ONLY_NS, the qualified name is treated as * a reference to a namespace, and the entire qualified name is followed. * If the name is relative, the namespace is looked up only in the * current namespace. A pointer to the namespace is stored in *nsPtrPtr * and NULL is stored in *simpleNamePtr. Otherwise, if TCL_FIND_ONLY_NS * is not specified, only the leading components are treated as namespace * names, and a pointer to the simple name of the final component is * stored in *simpleNamePtr. * * Results: * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible * namespaces which represent the last (containing) namespace in the * qualified name. If the function sets either *nsPtrPtr or *altNsPtrPtr * to NULL, then the search along that path failed. The function also * stores a pointer to the simple name of the final component in * *simpleNamePtr. If the qualified name is "::" or was treated as a * namespace reference (TCL_FIND_ONLY_NS), the function stores a pointer * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets * *simpleNamePtr to point to an empty string. * * If there is an error, this function returns TCL_ERROR. If "flags" * contains TCL_LEAVE_ERR_MSG, an error message is returned in the * interpreter's result object. Otherwise, the interpreter's result * object is left unchanged. * * *actualCxtPtrPtr is set to the actual context namespace. It is set to * the input context namespace pointer in cxtNsPtr. If cxtNsPtr is NULL, * it is set to the current namespace context. * * For backwards compatibility with the TclPro byte code loader, this * function always returns TCL_OK. * * Side effects: * If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, new namespaces may be * created. * *---------------------------------------------------------------------- */ int TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) Tcl_Interp *interp; /* Interpreter in which to find the namespace * containing qualName. */ CONST char *qualName; /* A namespace-qualified name of an command, * variable, or namespace. */ Namespace *cxtNsPtr; /* The namespace in which to start the search * for qualName's namespace. If NULL start * from the current namespace. Ignored if * TCL_GLOBAL_ONLY is set. */ int flags; /* Flags controlling the search: an OR'd * combination of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, and * TCL_CREATE_NS_IF_UNKNOWN. */ Namespace **nsPtrPtr; /* Address where function stores a pointer to * containing namespace if qualName is found * starting from *cxtNsPtr or, if * TCL_GLOBAL_ONLY is set, if qualName is * found in the global :: namespace. NULL is * stored otherwise. */ Namespace **altNsPtrPtr; /* Address where function stores a pointer to * containing namespace if qualName is found * starting from the global :: namespace. * NULL is stored if qualName isn't found * starting from :: or if the TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, * TCL_CREATE_NS_IF_UNKNOWN flag is set. */ Namespace **actualCxtPtrPtr;/* Address where function stores a pointer to * the actual namespace from which the search * started. This is either cxtNsPtr, the :: * namespace if TCL_GLOBAL_ONLY was specified, * or the current namespace if cxtNsPtr was * NULL. */ CONST char **simpleNamePtr; /* Address where function stores the simple * name at end of the qualName, or NULL if * qualName is "::" or the flag * TCL_FIND_ONLY_NS was specified. */ { Interp *iPtr = (Interp *) interp; Namespace *nsPtr = cxtNsPtr; Namespace *altNsPtr; Namespace *globalNsPtr = iPtr->globalNsPtr; CONST char *start, *end; CONST char *nsName; Tcl_HashEntry *entryPtr; Tcl_DString buffer; int len; /* * Determine the context namespace nsPtr in which to start the primary * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY was * specified, search from the global namespace. Otherwise, use the * namespace given in cxtNsPtr, or if that is NULL, use the current * namespace context. Note that we always treat two or more adjacent ":"s * as a namespace separator. */ if (flags & TCL_GLOBAL_ONLY) { nsPtr = globalNsPtr; } else if (nsPtr == NULL) { if (iPtr->varFramePtr != NULL) { nsPtr = iPtr->varFramePtr->nsPtr; |
︙ | ︙ | |||
1987 1988 1989 1990 1991 1992 1993 | * Loop to resolve each namespace qualifier in qualName. */ Tcl_DStringInit(&buffer); end = start; while (*start != '\0') { /* | | | | | | | | | | | | | | | | 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 | * Loop to resolve each namespace qualifier in qualName. */ Tcl_DStringInit(&buffer); end = start; while (*start != '\0') { /* * Find the next namespace qualifier (i.e., a name ending in "::") or * the end of the qualified name (i.e., a name ending in "\0"). Set * len to the number of characters, starting from start, in the name; * set end to point after the "::"s or at the "\0". */ len = 0; for (end = start; *end != '\0'; end++) { if ((*end == ':') && (*(end+1) == ':')) { end += 2; /* skip over the initial :: */ while (*end == ':') { end++; /* skip over the subsequent : */ } break; /* exit for loop; end is after ::'s */ } len++; } if (*end=='\0' && !(end-start>=2 && *(end-1)==':' && *(end-2)==':')) { /* * qualName ended with a simple name at start. If TCL_FIND_ONLY_NS * was specified, look this up as a namespace. Otherwise, start is * the name of a cmd or var and we are done. */ if (flags & TCL_FIND_ONLY_NS) { nsName = start; } else { *nsPtrPtr = nsPtr; *altNsPtrPtr = altNsPtr; *simpleNamePtr = start; Tcl_DStringFree(&buffer); return TCL_OK; } } else { /* * start points to the beginning of a namespace qualifier ending * in "::". end points to the start of a name in that namespace * that might be empty. Copy the namespace qualifier to a buffer * so it can be null terminated. We can't modify the incoming * qualName since it may be a string constant. */ Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, start, len); nsName = Tcl_DStringValue(&buffer); } /* * Look up the namespace qualifier nsName in the current namespace * context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set, * create that qualifying namespace. This is needed for functions like * Tcl_CreateCommand that cannot fail. */ if (nsPtr != NULL) { entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName); if (entryPtr != NULL) { nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) { Tcl_CallFrame *framePtr; (void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); TclPopStackFrame(interp); if (nsPtr == NULL) { Tcl_Panic("Could not create namespace '%s'", nsName); } } else { /* namespace not found and wasn't created */ nsPtr = NULL; } |
︙ | ︙ | |||
2098 2099 2100 2101 2102 2103 2104 | /* * We ignore trailing "::"s in a namespace name, but in a command or * variable name, trailing "::"s refer to the cmd or var named {}. */ if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < | < | < | | | | | > | | > | 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 | /* * We ignore trailing "::"s in a namespace name, but in a command or * variable name, trailing "::"s refer to the cmd or var named {}. */ if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) { *simpleNamePtr = NULL; /* found namespace name */ } else { *simpleNamePtr = end; /* found cmd/var: points to empty string */ } /* * As a special case, if we are looking for a namespace and qualName is "" * and the current active namespace (nsPtr) is not the global namespace, * return NULL (no namespace was found). This is because namespaces can * not have empty names except for the global namespace. */ if ((flags & TCL_FIND_ONLY_NS) && (*qualName == '\0') && (nsPtr != globalNsPtr)) { nsPtr = NULL; } *nsPtrPtr = nsPtr; *altNsPtrPtr = altNsPtr; Tcl_DStringFree(&buffer); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_FindNamespace -- * * Searches for a namespace. * * Results: * Returns a pointer to the namespace if it is found. Otherwise, returns * NULL and leaves an error message in the interpreter's result object if * "flags" contains TCL_LEAVE_ERR_MSG. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_FindNamespace(interp, name, contextNsPtr, flags) Tcl_Interp *interp; /* The interpreter in which to find the * namespace. */ CONST char *name; /* Namespace 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 is set or * if the name starts with "::". Otherwise, * points to namespace in which to resolve * name; if NULL, look up name in the current * namespace. */ register int flags; /* Flags controlling namespace lookup: an OR'd * combination of TCL_GLOBAL_ONLY and * TCL_LEAVE_ERR_MSG flags. */ { Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; CONST char *dummy; /* * Find the namespace(s) that contain the specified namespace name. Add * the TCL_FIND_ONLY_NS flag to resolve the name all the way down to its * last component, a namespace. */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); if (nsPtr != NULL) { return (Tcl_Namespace *) nsPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", (char *) NULL); } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_FindCommand -- * * Searches for a command. * * Results: * Returns a token for the command if it is found. Otherwise, if it can't * be found or there is an error, returns NULL and leaves an error * message in the interpreter's result object if "flags" contains * TCL_LEAVE_ERR_MSG. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_FindCommand(interp, name, contextNsPtr, flags) Tcl_Interp *interp; /* The interpreter in which to find the * command and to report errors. */ CONST char *name; /* Command'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 in the * current namespace. */ int flags; /* An OR'd combination of flags: * TCL_GLOBAL_ONLY (look up name only in * global namespace), TCL_NAMESPACE_ONLY (look * up only in contextNsPtr, or the current * namespace if contextNsPtr is NULL), and * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY * and TCL_NAMESPACE_ONLY are given, * TCL_GLOBAL_ONLY is ignored. */ { Interp *iPtr = (Interp*)interp; Namespace *cxtNsPtr; register Tcl_HashEntry *entryPtr; register Command *cmdPtr; CONST char *simpleName; int result; /* * If this namespace has a command resolver, then give it first crack at * the command resolution. If the interpreter has any command resolvers, * consult them next. The command resolver functions may return a * Tcl_Command value, they may signal to continue onward, or they may * signal an error. */ if (flags & TCL_GLOBAL_ONLY) { cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); } else if (contextNsPtr != NULL) { cxtNsPtr = (Namespace *) contextNsPtr; } else { cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { ResolverScheme *resPtr = iPtr->resolverPtr; Tcl_Command cmd; if (cxtNsPtr->cmdResProc) { result = (*cxtNsPtr->cmdResProc)(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &cmd); } else { result = TCL_CONTINUE; } |
︙ | ︙ | |||
2276 2277 2278 2279 2280 2281 2282 | } } /* * Find the namespace(s) that contain the command. */ | | | | < < < | < < < > > > | | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | | | | | | | | | | | | | | | | | | | | | | | | < | | | < > | 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 | } } /* * Find the namespace(s) that contain the command. */ cmdPtr = NULL; if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)) { int i; Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr; (void) TclGetNamespaceForQualName(interp, name, cxtNsPtr, TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if (realNsPtr != NULL && simpleName != NULL) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); } } /* * Next, check along the path. */ for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) { pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr; if (pathNsPtr == NULL) { continue; } (void) TclGetNamespaceForQualName(interp, name, pathNsPtr, TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if (realNsPtr != NULL && simpleName != NULL) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); } } } /* * If we've still not found the command, look in the global namespace * as a last resort. */ if (cmdPtr == NULL) { (void) TclGetNamespaceForQualName(interp, name, NULL, TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if (realNsPtr != NULL && simpleName != NULL) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); } } } } else { Namespace *nsPtr[2]; register int search; TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the command in the command table of its namespace. Be sure * to check both possible search paths: from the specified namespace * context and from the global namespace. */ for (search = 0; (search < 2) && (cmdPtr == NULL); search++) { if ((nsPtr[search] != NULL) && (simpleName != NULL)) { entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, simpleName); if (entryPtr != NULL) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); } } } } if (cmdPtr != NULL) { return (Tcl_Command) cmdPtr; } if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "unknown command \"", name, "\"", (char *) NULL); } return (Tcl_Command) NULL; } /* *---------------------------------------------------------------------- * * Tcl_FindNamespaceVar -- * * Searches for a namespace variable, a variable not local to a * procedure. The variable can be either a scalar or an array, but may * not be an element of an array. * * Results: * Returns a token for the variable if it is found. Otherwise, if it * can't be found or there is an error, returns NULL and leaves an error * message in the interpreter's result object if "flags" contains * TCL_LEAVE_ERR_MSG. * * Side effects: * None. * *---------------------------------------------------------------------- */ 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 in the * current namespace. */ int flags; /* An OR'd combination of flags: * TCL_GLOBAL_ONLY (look up name only in * global namespace), TCL_NAMESPACE_ONLY (look * up only in contextNsPtr, or the current * namespace if contextNsPtr is NULL), and * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY * and TCL_NAMESPACE_ONLY are given, * TCL_GLOBAL_ONLY is ignored. */ { Interp *iPtr = (Interp*)interp; ResolverScheme *resPtr; Namespace *nsPtr[2], *cxtNsPtr; CONST char *simpleName; Tcl_HashEntry *entryPtr; Var *varPtr; register int search; int result; Tcl_Var var; /* * 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) != 0) { cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); } else if (contextNsPtr != NULL) { cxtNsPtr = (Namespace *) contextNsPtr; } else { cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } |
︙ | ︙ | |||
2407 2408 2409 2410 2411 2412 2413 | * Find the namespace(s) that contain the variable. */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | > | | | < | | 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 | * Find the namespace(s) that contain the variable. */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the variable in the variable table of its namespace. Be sure * to check both possible search paths: from the specified namespace * context and from the global namespace. */ varPtr = NULL; for (search = 0; (search < 2) && (varPtr == NULL); search++) { if ((nsPtr[search] != NULL) && (simpleName != NULL)) { entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable, simpleName); if (entryPtr != NULL) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); } } } if (varPtr != NULL) { return (Tcl_Var) varPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "unknown variable \"", name, "\"", (char *) NULL); } return (Tcl_Var) NULL; } /* *---------------------------------------------------------------------- * * TclResetShadowedCmdRefs -- * * Called when a command is added to a namespace to check for existing * command references that the new command may invalidate. Consider the * following cases that could happen when you add a command "foo" to a * namespace "b": * 1. It could shadow a command named "foo" at the global scope. If * it does, all command references in the namespace "b" are * suspect. * 2. Suppose the namespace "b" resides in a namespace "a". Then to * "a" the new command "b::foo" could shadow another command * "b::foo" in the global namespace. If so, then all command * references in "a" * are suspect. * The same checks are applied to all parent namespaces, until we reach * the global :: namespace. * * Results: * None. * * Side effects: * If the new command shadows an existing command, the cmdRefEpoch * counter is incremented in each namespace that sees the shadow. This * invalidates all command references that were previously cached in that * namespace. The next time the commands are used, they are resolved from * scratch. * *---------------------------------------------------------------------- */ void TclResetShadowedCmdRefs(interp, newCmdPtr) Tcl_Interp *interp; /* Interpreter containing the new command. */ Command *newCmdPtr; /* Points to the new command. */ { char *cmdName; Tcl_HashEntry *hPtr; register Namespace *nsPtr; Namespace *trailNsPtr, *shadowNsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); int found, i; /* * This function generates an array used to hold the trail list. This * starts out with stack-allocated space but uses dynamically-allocated * storage if needed. */ Namespace *(trailStorage[NUM_TRAIL_ELEMS]); Namespace **trailPtr = trailStorage; int trailFront = -1; int trailSize = NUM_TRAIL_ELEMS; /* * Start at the namespace containing the new command, and work up through * the list of parents. Stop just before the global namespace, since the * global namespace can't "shadow" its own entries. * * The namespace "trail" list we build consists of the names of each * namespace that encloses the new command, in order from outermost to * innermost: for example, "a" then "b". Each iteration of this loop * eventually extends the trail upwards by one namespace, nsPtr. We use * this trail list to see if nsPtr (e.g. "a" in 2. above) could have * now-invalid cached command references. This will happen if nsPtr * (e.g. "a") contains a sequence of child namespaces (e.g. "b") such that * there is a identically-named sequence of child namespaces starting from * :: (e.g. "::b") whose tail namespace contains a command also named * cmdName. */ cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr); for (nsPtr=newCmdPtr->nsPtr ; (nsPtr!=NULL) && (nsPtr!=globalNsPtr) ; nsPtr=nsPtr->parentPtr) { /* * Find the maximal sequence of child namespaces contained in nsPtr * such that there is a identically-named sequence of child namespaces * starting from ::. shadowNsPtr will be the tail of this sequence, or * the deepest namespace under :: that might contain a command now * shadowed by cmdName. We check below if shadowNsPtr actually * contains a command cmdName. */ found = 1; shadowNsPtr = globalNsPtr; for (i = trailFront; i >= 0; i--) { trailNsPtr = trailPtr[i]; hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable, trailNsPtr->name); if (hPtr != NULL) { shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr); } else { found = 0; break; } } /* * If shadowNsPtr contains a command named cmdName, we invalidate all * of the command refs cached in nsPtr. As a boundary case, * shadowNsPtr is initially :: and we check for case 1. above. */ if (found) { hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); if (hPtr != NULL) { nsPtr->cmdRefEpoch++; TclInvalidateNsPath(nsPtr); /* * If the shadowed command was compiled to bytecodes, we * invalidate all the bytecodes in nsPtr, to force a new * compilation. We use the resolverEpoch to signal the need * for a fresh compilation of every bytecode. */ if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL) { nsPtr->resolverEpoch++; } } } /* * Insert nsPtr at the front of the trail list: i.e., at the end of * the trailPtr array. */ trailFront++; if (trailFront == trailSize) { size_t currBytes = trailSize * sizeof(Namespace *); int newSize = 2*trailSize; size_t newBytes = newSize * sizeof(Namespace *); Namespace **newPtr = (Namespace **) ckalloc((unsigned) newBytes); memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes); if (trailPtr != trailStorage) { ckfree((char *) trailPtr); } trailPtr = newPtr; trailSize = newSize; |
︙ | ︙ | |||
2590 2591 2592 2593 2594 2595 2596 | ckfree((char *) trailPtr); } } /* *---------------------------------------------------------------------- * | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | ckfree((char *) trailPtr); } } /* *---------------------------------------------------------------------- * * TclGetNamespaceFromObj -- * * Gets the namespace specified by the name in a Tcl_Obj. * * Results: * Returns TCL_OK if the namespace was resolved successfully, and stores * a pointer to the namespace in the location specified by nsPtrPtr. If * the namespace can't be found, the function stores NULL in *nsPtrPtr * and returns TCL_OK. If anything else goes wrong, this function returns * TCL_ERROR. * * Side effects: * May update the internal representation for the object, caching the * namespace reference. The next time this function is called, the * namespace value can be found quickly. * * If anything goes wrong, an error message is left in the interpreter's * result object. * *---------------------------------------------------------------------- */ int TclGetNamespaceFromObj(interp, objPtr, nsPtrPtr) Tcl_Interp *interp; /* The current interpreter. */ Tcl_Obj *objPtr; /* The object to be resolved as the name of a * namespace. */ Tcl_Namespace **nsPtrPtr; /* Result namespace pointer goes here. */ { Interp *iPtr = (Interp *) interp; register ResolvedNsName *resNamePtr; register Namespace *nsPtr; Namespace *currNsPtr; CallFrame *savedFramePtr; int result = TCL_OK; char *name; /* * If the namespace name is fully qualified, do as if the lookup were done * from the global namespace; this helps avoid repeated lookups of fully * qualified names. */ savedFramePtr = iPtr->varFramePtr; name = TclGetString(objPtr); if ((*name++ == ':') && (*name == ':')) { iPtr->varFramePtr = NULL; } currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); /* * Get the internal representation, converting to a namespace type if * needed. The internal representation is a ResolvedNsName that points to * the actual namespace. */ if (objPtr->typePtr != &tclNsNameType) { result = tclNsNameType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { goto done; } } resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; /* * Check the context namespace of the resolved symbol to make sure that it * is fresh. If not, then force another conversion to the namespace type, * to discard the old rep and create a new one. Note that we verify that * the namespace id of the cached namespace is the same as the id when we * cached it; this insures that the namespace wasn't deleted and a new one * created at the same address. */ nsPtr = NULL; if ((resNamePtr != NULL) && (resNamePtr->refNsPtr == currNsPtr) && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { nsPtr = resNamePtr->nsPtr; if (nsPtr->flags & NS_DEAD) { nsPtr = NULL; } } if (nsPtr == NULL) { /* try again */ |
︙ | ︙ | |||
2698 2699 2700 2701 2702 2703 2704 | } /* *---------------------------------------------------------------------- * * Tcl_NamespaceObjCmd -- * | | | > | | | | | | < | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_NamespaceObjCmd -- * * Invoked to implement the "namespace" command that creates, deletes, or * manipulates Tcl namespaces. Handles the following syntax: * * namespace children ?name? ?pattern? * namespace code arg * namespace current * namespace delete ?name name...? * namespace ensemble subcommand ?arg...? * namespace eval name arg ?arg...? * namespace exists name * namespace export ?-clear? ?pattern pattern...? * namespace forget ?pattern pattern...? * namespace import ?-force? ?pattern pattern...? * namespace inscope name arg ?arg...? * namespace origin name * namespace parent ?name? * namespace qualifiers string * namespace tail string * namespace which ?-command? ?-variable? name * * Results: * Returns TCL_OK if the command is successful. Returns TCL_ERROR if * anything goes wrong. * * Side effects: * Based on the subcommand name (e.g., "import"), this function * dispatches to a corresponding function NamespaceXXXCmd defined * statically in this file. This function's side effects depend on * whatever that subcommand function does. If there is an error, this * function returns an error message in the interpreter's result object. * Otherwise it may return a result in the interpreter's result object. * *---------------------------------------------------------------------- */ int Tcl_NamespaceObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Arbitrary value passed to cmd. */ Tcl_Interp *interp; /* Current interpreter. */ register int objc; /* Number of arguments. */ register Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *subCmds[] = { "children", "code", "current", "delete", "ensemble", "eval", "exists", "export", "forget", "import", "inscope", "origin", "parent", "path", "qualifiers", "tail", "which", (char *) NULL }; enum NSSubCmdIdx { NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx, NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx, NSTailIdx, NSWhichIdx }; int index, result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); return TCL_ERROR; |
︙ | ︙ | |||
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 | break; case NSOriginIdx: result = NamespaceOriginCmd(clientData, interp, objc, objv); break; case NSParentIdx: result = NamespaceParentCmd(clientData, interp, objc, objv); break; case NSQualifiersIdx: result = NamespaceQualifiersCmd(clientData, interp, objc, objv); break; case NSTailIdx: result = NamespaceTailCmd(clientData, interp, objc, objv); break; case NSWhichIdx: result = NamespaceWhichCmd(clientData, interp, objc, objv); break; } return result; } /* *---------------------------------------------------------------------- * * NamespaceChildrenCmd -- * * Invoked to implement the "namespace children" command that returns a | > > > | | | | | 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 | break; case NSOriginIdx: result = NamespaceOriginCmd(clientData, interp, objc, objv); break; case NSParentIdx: result = NamespaceParentCmd(clientData, interp, objc, objv); break; case NSPathIdx: result = NamespacePathCmd(clientData, interp, objc, objv); break; case NSQualifiersIdx: result = NamespaceQualifiersCmd(clientData, interp, objc, objv); break; case NSTailIdx: result = NamespaceTailCmd(clientData, interp, objc, objv); break; case NSWhichIdx: result = NamespaceWhichCmd(clientData, interp, objc, objv); break; } return result; } /* *---------------------------------------------------------------------- * * NamespaceChildrenCmd -- * * Invoked to implement the "namespace children" command that returns a * list containing the fully-qualified names of the child namespaces of a * given namespace. Handles the following syntax: * * namespace children ?name? ?pattern? * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything goes * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceChildrenCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
2866 2867 2868 2869 2870 2871 2872 | /* * Get a pointer to the specified namespace, or the current namespace. */ if (objc == 2) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else if ((objc == 3) || (objc == 4)) { | | | 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 | /* * Get a pointer to the specified namespace, or the current namespace. */ if (objc == 2) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } else if ((objc == 3) || (objc == 4)) { if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { return TCL_ERROR; } if (namespacePtr == NULL) { Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]), "\" in namespace children command", (char *) NULL); return TCL_ERROR; |
︙ | ︙ | |||
2902 2903 2904 2905 2906 2907 2908 | } Tcl_DStringAppend(&buffer, name, -1); pattern = Tcl_DStringValue(&buffer); } } /* | | | > > > > > > > > | | | | | 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 | } Tcl_DStringAppend(&buffer, name, -1); pattern = Tcl_DStringValue(&buffer); } } /* * Create a list containing the full names of all child namespaces whose * names match the specified pattern, if any. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { if (Tcl_FindHashEntry(&nsPtr->childTable, pattern) != NULL) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(pattern, -1)); } goto searchDone; } entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); while (entryPtr != NULL) { childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); if ((pattern == NULL) || Tcl_StringMatch(childNsPtr->fullName, pattern)) { elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1); Tcl_ListObjAppendElement(interp, listPtr, elemPtr); } entryPtr = Tcl_NextHashEntry(&search); } searchDone: Tcl_SetObjResult(interp, listPtr); Tcl_DStringFree(&buffer); return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceCodeCmd -- * * Invoked to implement the "namespace code" command to capture the * namespace context of a command. Handles the following syntax: * * namespace code arg * * Here "arg" can be a list. "namespace code arg" produces a result * equivalent to that produced by the command * * list ::namespace inscope [namespace current] $arg * * However, if "arg" is itself a scoped value starting with "::namespace * inscope", then the result is just "arg". * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * If anything goes wrong, this function returns an error message as the * result in the interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceCodeCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
2989 2990 2991 2992 2993 2994 2995 | Tcl_SetObjResult(interp, objv[2]); return TCL_OK; } } /* * Otherwise, construct a scoped command by building a list with | | | | | | 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 | Tcl_SetObjResult(interp, objv[2]); return TCL_OK; } } /* * Otherwise, construct a scoped command by building a list with * "namespace inscope", the full name of the current namespace, and the * argument "arg". By constructing a list, we ensure that scoped commands * are interpreted properly when they are executed later, by the * "namespace inscope" command. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("::namespace", -1)); Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("inscope", -1)); |
︙ | ︙ | |||
3020 3021 3022 3023 3024 3025 3026 | } /* *---------------------------------------------------------------------- * * NamespaceCurrentCmd -- * | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * NamespaceCurrentCmd -- * * Invoked to implement the "namespace current" command which returns the * fully-qualified name of the current namespace. Handles the following * syntax: * * namespace current * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything goes * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceCurrentCmd(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 Namespace *currNsPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } /* * The "real" name of the global namespace ("::") is the null string, but * we return "::" for it as a convenience to programmers. Note that "" and * "::" are treated as synonyms by the namespace code so that it is still * easy to do things like: * * namespace [namespace current]::bar { ... } */ currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2)); |
︙ | ︙ | |||
3081 3082 3083 3084 3085 3086 3087 | * namespace(s). Handles the following syntax: * * namespace delete ?name name...? * * Each name identifies a namespace. It may include a sequence of * namespace qualifiers separated by "::"s. If a namespace is found, it * is deleted: all variables and procedures contained in that namespace | | | | | | | < | 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 | * namespace(s). Handles the following syntax: * * namespace delete ?name name...? * * Each name identifies a namespace. It may include a sequence of * namespace qualifiers separated by "::"s. If a namespace is found, it * is deleted: all variables and procedures contained in that namespace * are deleted. If that namespace is being used on the call stack, it is * kept alive (but logically deleted) until it is removed from the call * stack: that is, it can no longer be referenced by name but any * currently executing procedure that refers to it is allowed to do so * until the procedure returns. If the namespace can't be found, this * function returns an error. If no namespaces are specified, this * command does nothing. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Deletes the specified namespaces. If anything goes wrong, this * function returns an error message in the interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceDeleteCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
3117 3118 3119 3120 3121 3122 3123 | if (objc < 2) { Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); return TCL_ERROR; } /* | | | | | 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 | if (objc < 2) { Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); return TCL_ERROR; } /* * Destroying one namespace may cause another to be destroyed. Break this * into two passes: first check to make sure that all namespaces on the * command line are valid, and report any errors. */ for (i = 2; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, (Tcl_Namespace *) NULL, /*flags*/ 0); if (namespacePtr == NULL) { |
︙ | ︙ | |||
3154 3155 3156 3157 3158 3159 3160 | } /* *---------------------------------------------------------------------- * * NamespaceEvalCmd -- * | | | | | | | | | | | | | | | | | | | > | | | > > > > | > | < < | < < | < < < | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * NamespaceEvalCmd -- * * Invoked to implement the "namespace eval" command. Executes commands * in a namespace. If the namespace does not already exist, it is * created. Handles the following syntax: * * namespace eval name arg ?arg...? * * If more than one arg argument is specified, the command that is * executed is the result of concatenating the arguments together with a * space between each argument. * * Results: * Returns TCL_OK if the namespace is found and the commands are executed * successfully. Returns TCL_ERROR if anything goes wrong. * * Side effects: * Returns the result of the command in the interpreter's result object. * If anything goes wrong, this function returns an error message as the * result. * *---------------------------------------------------------------------- */ static int NamespaceEvalCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; Tcl_Obj *objPtr; int result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); return TCL_ERROR; } /* * Try to resolve the namespace reference, caching the result in the * namespace object along the way. */ result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr); if (result != TCL_OK) { return result; } /* * If the namespace wasn't found, try to create it. */ if (namespacePtr == NULL) { char *name = TclGetString(objv[2]); namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); if (namespacePtr == NULL) { return TCL_ERROR; } } /* * Make the specified namespace the current namespace and evaluate the * command(s). */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ framePtrPtr = &framePtr; result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return TCL_ERROR; } framePtr->objc = objc; framePtr->objv = objv; /* Reference counts do not need to be * incremented here. */ if (objc == 4) { result = Tcl_EvalObjEx(interp, objv[3], 0); } else { /* * More than one argument: concatenate them together with spaces * between, then evaluate the result. Tcl_EvalObjEx will delete the * object when it decrements its refcount after eval'ing it. */ objPtr = Tcl_ConcatObj(objc-3, objv+3); result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { int length = strlen(namespacePtr->fullName); int limit = 200; int overflow = (length > limit); TclFormatToErrorInfo(interp, "\n (in namespace eval \"%.*s%s\" script line %d)", (overflow ? limit : length), namespacePtr->fullName, (overflow ? "..." : ""), interp->errorLine); } /* * Restore the previous "current" namespace. */ TclPopStackFrame(interp); return result; } /* *---------------------------------------------------------------------- * * NamespaceExistsCmd -- * * Invoked to implement the "namespace exists" command that returns true * if the given namespace currently exists, and false otherwise. Handles * the following syntax: * * namespace exists name * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything goes * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceExistsCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
3304 3305 3306 3307 3308 3309 3310 | return TCL_ERROR; } /* * Check whether the given namespace exists */ | | | | | | | | | | | | | | 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 | return TCL_ERROR; } /* * Check whether the given namespace exists */ if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(namespacePtr != NULL)); return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceExportCmd -- * * Invoked to implement the "namespace export" command that specifies * which commands are exported from a namespace. The exported commands * are those that can be imported into another namespace using "namespace * import". Both commands defined in a namespace and commands the * namespace has imported can be exported by a namespace. This command * has the following syntax: * * namespace export ?-clear? ?pattern pattern...? * * Each pattern may contain "string match"-style pattern matching special * characters, but the pattern may not include any namespace qualifiers: * that is, the pattern must specify commands in the current (exporting) * namespace. The specified patterns are appended onto the namespace's * list of export patterns. * * To reset the namespace's export pattern list, specify the "-clear" * flag. * * If there are no export patterns and the "-clear" flag isn't given, * this command returns the namespace's current export list. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything goes * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceExportCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
3379 3380 3381 3382 3383 3384 3385 | if (strcmp(string, "-clear") == 0) { resetListFirst = 1; firstArg++; } } /* | | | | 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 | if (strcmp(string, "-clear") == 0) { resetListFirst = 1; firstArg++; } } /* * If no pattern arguments are given, and "-clear" isn't specified, return * the namespace's current export pattern list. */ patternCt = (objc - firstArg); if (patternCt == 0) { if (firstArg > 2) { return TCL_OK; } else { /* create list with export patterns */ |
︙ | ︙ | |||
3419 3420 3421 3422 3423 3424 3425 | } /* *---------------------------------------------------------------------- * * NamespaceForgetCmd -- * | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * NamespaceForgetCmd -- * * Invoked to implement the "namespace forget" command to remove imported * commands from a namespace. Handles the following syntax: * * namespace forget ?pattern pattern...? * * Each pattern is a name like "foo::*" or "a::b::x*". That is, the * pattern may include the special pattern matching characters recognized * by the "string match" command, but only in the command name at the end * of the qualified name; the special pattern characters may not appear * in a namespace name. All of the commands that match that pattern are * checked to see if they have an imported command in the current * namespace that refers to the matched command. If there is an alias, it * is removed. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Imported commands are removed from the current namespace. If anything * goes wrong, this function returns an error message in the * interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceForgetCmd(dummy, interp, objc, objv) |
︙ | ︙ | |||
3479 3480 3481 3482 3483 3484 3485 | * NamespaceImportCmd -- * * Invoked to implement the "namespace import" command that imports * commands into a namespace. Handles the following syntax: * * namespace import ?-force? ?pattern pattern...? * | | | | | | | | | | | < | | | 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 | * NamespaceImportCmd -- * * Invoked to implement the "namespace import" command that imports * commands into a namespace. Handles the following syntax: * * namespace import ?-force? ?pattern pattern...? * * Each pattern is a namespace-qualified name like "foo::*", "a::b::x*", * or "bar::p". That is, the pattern may include the special pattern * matching characters recognized by the "string match" command, but only * in the command name at the end of the qualified name; the special * pattern characters may not appear in a namespace name. All of the * commands that match the pattern and which are exported from their * namespace are made accessible from the current namespace context. This * is done by creating a new "imported command" in the current namespace * that points to the real command in its original namespace; when the * imported command is called, it invokes the real command. * * If an imported command conflicts with an existing command, it is * treated as an error. But if the "-force" option is included, then * existing commands are overwritten by the imported commands. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Adds imported commands to the current namespace. If anything goes * wrong, this function returns an error message in the interpreter's * result object. * *---------------------------------------------------------------------- */ static int NamespaceImportCmd(dummy, interp, objc, objv) |
︙ | ︙ | |||
3558 3559 3560 3561 3562 3563 3564 | /* *---------------------------------------------------------------------- * * NamespaceInscopeCmd -- * * Invoked to implement the "namespace inscope" command that executes a * script in the context of a particular namespace. This command is not | | | | | | | | | | | | < | | | | | | 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 | /* *---------------------------------------------------------------------- * * NamespaceInscopeCmd -- * * Invoked to implement the "namespace inscope" command that executes a * script in the context of a particular namespace. This command is not * expected to be used directly by programmers; calls to it are generated * implicitly when programs use "namespace code" commands to register * callback scripts. Handles the following syntax: * * namespace inscope name arg ?arg...? * * The "namespace inscope" command is much like the "namespace eval" * command except that it has lappend semantics and the namespace must * already exist. It treats the first argument as a list, and appends any * arguments after the first onto the end as proper list elements. For * example, * * namespace inscope ::foo {a b} c d e * * is equivalent to * * namespace eval ::foo [concat {a b} [list c d e]] * * This lappend semantics is important because many callback scripts are * actually prefixes. * * Results: * Returns TCL_OK to indicate success, or TCL_ERROR to indicate failure. * * Side effects: * Returns a result in the Tcl interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceInscopeCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; Tcl_CallFrame *framePtr; int i, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); return TCL_ERROR; } /* * Resolve the namespace reference. */ result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr); if (result != TCL_OK) { return result; } if (namespacePtr == NULL) { Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]), "\" in inscope namespace command", (char *) NULL); return TCL_ERROR; } /* * Make the specified namespace the current namespace. */ result = TclPushStackFrame(interp, &framePtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; } /* * Execute the command. If there is just one argument, just treat it as a * script and evaluate it. Otherwise, create a list from the arguments * after the first one, then concatenate the first argument and the list * of extra arguments to form the command to evaluate. */ if (objc == 4) { result = Tcl_EvalObjEx(interp, objv[3], 0); } else { |
︙ | ︙ | |||
3659 3660 3661 3662 3663 3664 3665 | concatObjv[1] = listPtr; cmdObjPtr = Tcl_ConcatObj(2, concatObjv); result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); Tcl_DecrRefCount(listPtr); /* we're done with the list object */ } if (result == TCL_ERROR) { | > > > | > | < < | < < | < < < | | 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 | concatObjv[1] = listPtr; cmdObjPtr = Tcl_ConcatObj(2, concatObjv); result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); Tcl_DecrRefCount(listPtr); /* we're done with the list object */ } if (result == TCL_ERROR) { int length = strlen(namespacePtr->fullName); int limit = 200; int overflow = (length > limit); TclFormatToErrorInfo(interp, "\n (in namespace inscope \"%.*s%s\" script line %d)", (overflow ? limit : length), namespacePtr->fullName, (overflow ? "..." : ""), interp->errorLine); } /* * Restore the previous "current" namespace. */ TclPopStackFrame(interp); return result; } /* *---------------------------------------------------------------------- * * NamespaceOriginCmd -- |
︙ | ︙ | |||
3699 3700 3701 3702 3703 3704 3705 | * An imported command is created in an namespace when that namespace * imports a command from another namespace. If a command is imported * into a sequence of namespaces a, b,...,n where each successive * namespace just imports the command from the previous namespace, this * command returns the fully-qualified name of the original command in * the first namespace, a. If "name" does not refer to an alias, its * fully-qualified name is returned. The returned name is stored in the | | | | | 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 | * An imported command is created in an namespace when that namespace * imports a command from another namespace. If a command is imported * into a sequence of namespaces a, b,...,n where each successive * namespace just imports the command from the previous namespace, this * command returns the fully-qualified name of the original command in * the first namespace, a. If "name" does not refer to an alias, its * fully-qualified name is returned. The returned name is stored in the * interpreter's result object. This function returns TCL_OK if * successful, and TCL_ERROR if anything goes wrong. * * Side effects: * If anything goes wrong, this function returns an error message in the * interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceOriginCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
3735 3736 3737 3738 3739 3740 3741 | return TCL_ERROR; } origCommand = TclGetOriginalCommand(command); resultPtr = Tcl_NewObj(); if (origCommand == (Tcl_Command) NULL) { /* * The specified command isn't an imported command. Return the | | | | 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 | return TCL_ERROR; } origCommand = TclGetOriginalCommand(command); resultPtr = Tcl_NewObj(); if (origCommand == (Tcl_Command) NULL) { /* * The specified command isn't an imported command. Return the * command's name qualified by the full name of the namespace it was * defined in. */ Tcl_GetCommandFullName(interp, command, resultPtr); } else { Tcl_GetCommandFullName(interp, origCommand, resultPtr); } Tcl_SetObjResult(interp, resultPtr); |
︙ | ︙ | |||
3762 3763 3764 3765 3766 3767 3768 | * * namespace parent ?name? * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: | | | | | 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 | * * namespace parent ?name? * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything goes * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceParentCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *nsPtr; int result; if (objc == 2) { nsPtr = Tcl_GetCurrentNamespace(interp); } else if (objc == 3) { result = TclGetNamespaceFromObj(interp, objv[2], &nsPtr); if (result != TCL_OK) { return result; } if (nsPtr == NULL) { Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]), "\" in namespace parent command", (char *) NULL); |
︙ | ︙ | |||
3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 | } return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespaceQualifiersCmd -- * * Invoked to implement the "namespace qualifiers" command that returns * any leading namespace qualifiers in a string. These qualifiers are * namespace names separated by "::"s. For example, for "::foo::p" this | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | < | | | | | | 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 | } return TCL_OK; } /* *---------------------------------------------------------------------- * * NamespacePathCmd -- * * Invoked to implement the "namespace path" command that reads and * writes the current namespace's command resolution path. Has one * optional argument: if present, it is a list of named namespaces to set * the path to, and if absent, the current path should be returned. * Handles the following syntax: * * namespace path ?nsList? * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong * (most notably if the namespace list contains the name of something * other than a namespace). In the successful-exit case, may set the * interpreter result to the list of names of the namespaces on the * current namespace's path. * * Side effects: * May update the namespace path (triggering a recomputing of all command * names that depend on the namespace for resolution). * *---------------------------------------------------------------------- */ static int NamespacePathCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); int i, nsObjc, result = TCL_ERROR; Tcl_Obj **nsObjv; Tcl_Namespace **namespaceList = NULL; Tcl_Namespace *staticNs[4]; if (objc > 3) { Tcl_WrongNumArgs(interp, 2, objv, "?pathList?"); return TCL_ERROR; } /* * If no path is given, return the current path. */ if (objc == 2) { /* * Not a very fast way to compute this, but easy to get right. */ for (i=0 ; i<nsPtr->commandPathLength ; i++) { if (nsPtr->commandPathArray[i].nsPtr != NULL) { Tcl_AppendElement(interp, nsPtr->commandPathArray[i].nsPtr->fullName); } } return TCL_OK; } /* * There is a path given, so parse it into an array of namespace pointers. */ if (Tcl_ListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) { goto badNamespace; } if (nsObjc != 0) { if (nsObjc > 4) { namespaceList = (Tcl_Namespace **) ckalloc(sizeof(Tcl_Namespace *) * nsObjc); } else { namespaceList = staticNs; } for (i=0 ; i<nsObjc ; i++) { if (TclGetNamespaceFromObj(interp, nsObjv[i], &namespaceList[i]) != TCL_OK) { goto badNamespace; } if (namespaceList[i] == NULL) { Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(nsObjv[i]), "\"", NULL); goto badNamespace; } } } /* * Now we have the list of valid namespaces, install it as the path. */ SetNsPath(nsPtr, nsObjc, namespaceList); result = TCL_OK; badNamespace: if (namespaceList != NULL && namespaceList != staticNs) { ckfree((char *) namespaceList); } return result; } /* *---------------------------------------------------------------------- * * SetNsPath -- * * Sets the namespace command name resolution path to the given list of * namespaces. If the list is empty (of zero length) the path is set to * empty and the default old-style behaviour of command name resolution * is used. * * Results: * nothing * * Side effects: * Invalidates the command name resolution caches for any command * resolved in the given namespace. * *---------------------------------------------------------------------- */ /* EXPOSE ME? */ static void SetNsPath(nsPtr, pathLength, pathAry) Namespace *nsPtr; /* Namespace whose path is to be set. */ int pathLength; /* Length of pathAry */ Tcl_Namespace *pathAry[]; /* Array of namespaces that are the path. */ { NamespacePathEntry *tmpPathArray; int i; if (pathLength != 0) { tmpPathArray = (NamespacePathEntry *) ckalloc(sizeof(NamespacePathEntry) * pathLength); for (i=0 ; i<pathLength ; i++) { tmpPathArray[i].nsPtr = (Namespace *) pathAry[i]; tmpPathArray[i].creatorNsPtr = nsPtr; tmpPathArray[i].prevPtr = NULL; tmpPathArray[i].nextPtr = tmpPathArray[i].nsPtr->commandPathSourceList; if (tmpPathArray[i].nextPtr != NULL) { tmpPathArray[i].nextPtr->prevPtr = &tmpPathArray[i]; } tmpPathArray[i].nsPtr->commandPathSourceList = &tmpPathArray[i]; } if (nsPtr->commandPathLength != 0) { UnlinkNsPath(nsPtr); } nsPtr->commandPathArray = tmpPathArray; } else { if (nsPtr->commandPathLength != 0) { UnlinkNsPath(nsPtr); } } nsPtr->commandPathLength = pathLength; nsPtr->cmdRefEpoch++; nsPtr->resolverEpoch++; } /* *---------------------------------------------------------------------- * * UnlinkNsPath -- * * Delete the given namespace's command name resolution path. Only call * if the path is non-empty. Caller must reset the counter containing the * path size. * * Results: * nothing * * Side effects: * Deletes the array of path entries and unlinks those path entries from * the target namespace's list of interested namespaces. * *---------------------------------------------------------------------- */ static void UnlinkNsPath(nsPtr) Namespace *nsPtr; { int i; for (i=0 ; i<nsPtr->commandPathLength ; i++) { NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i]; if (nsPathPtr->prevPtr != NULL) { nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr; } if (nsPathPtr->nextPtr != NULL) { nsPathPtr->nextPtr->prevPtr = nsPathPtr->prevPtr; } if (nsPathPtr->nsPtr != NULL) { if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) { nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr; } } } ckfree((char *) nsPtr->commandPathArray); } /* *---------------------------------------------------------------------- * * TclInvalidateNsPath -- * * Invalidate the name resolution caches for all names looked up in * namespaces whose name path includes the given namespace. * * Results: * nothing * * Side effects: * Increments the command reference epoch in each namespace whose path * includes the given namespace. This causes any cached resolved names * whose root cacheing context starts at that namespace to be recomputed * the next time they are used. * *---------------------------------------------------------------------- */ void TclInvalidateNsPath(nsPtr) Namespace *nsPtr; { NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; while (nsPathPtr != NULL) { if (nsPathPtr->nsPtr != NULL) { nsPathPtr->creatorNsPtr->cmdRefEpoch++; } nsPathPtr = nsPathPtr->nextPtr; } } /* *---------------------------------------------------------------------- * * NamespaceQualifiersCmd -- * * Invoked to implement the "namespace qualifiers" command that returns * any leading namespace qualifiers in a string. These qualifiers are * namespace names separated by "::"s. For example, for "::foo::p" this * command returns "::foo", and for "::" it returns "". This command is * the complement of the "namespace tail" command. Note that this command * does not check whether the "namespace" names are, in fact, the names * of currently defined namespaces. Handles the following syntax: * * namespace qualifiers string * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything goes * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceQualifiersCmd(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 char *name, *p; int length; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } /* * Find the end of the string, then work backward and find the start of * the last "::" qualifier. */ name = TclGetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } while (--p >= name) { |
︙ | ︙ | |||
3880 3881 3882 3883 3884 3885 3886 | /* *---------------------------------------------------------------------- * * NamespaceTailCmd -- * * Invoked to implement the "namespace tail" command that returns the | | | | | | | | | | | | | 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 | /* *---------------------------------------------------------------------- * * NamespaceTailCmd -- * * Invoked to implement the "namespace tail" command that returns the * trailing name at the end of a string with "::" namespace qualifiers. * These qualifiers are namespace names separated by "::"s. For example, * for "::foo::p" this command returns "p", and for "::" it returns "". * This command is the complement of the "namespace qualifiers" command. * Note that this command does not check whether the "namespace" names * are, in fact, the names of currently defined namespaces. Handles the * following syntax: * * namespace tail string * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything goes * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceTailCmd(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 char *name, *p; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } /* * Find the end of the string, then work backward and find the last "::" * qualifier. */ name = TclGetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } while (--p > name) { |
︙ | ︙ | |||
3952 3953 3954 3955 3956 3957 3958 | * * namespace which ?-command? ?-variable? name * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: | | | | | 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 | * * namespace which ?-command? ?-variable? name * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Returns a result in the interpreter's result object. If anything goes * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceWhichCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *opts[] = { "-command", "-variable", NULL }; |
︙ | ︙ | |||
3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 | */ if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, &lookupType) != TCL_OK) { /* * Preserve old style of error message! */ Tcl_ResetResult(interp); goto badArgs; } } resultPtr = Tcl_NewObj(); switch (lookupType) { case 0: { /* -command */ Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); | > > | > | 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 | */ if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, &lookupType) != TCL_OK) { /* * Preserve old style of error message! */ Tcl_ResetResult(interp); goto badArgs; } } resultPtr = Tcl_NewObj(); switch (lookupType) { case 0: { /* -command */ Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); if (cmd != (Tcl_Command) NULL) { Tcl_GetCommandFullName(interp, cmd, resultPtr); } break; } case 1: { /* -variable */ Tcl_Var var = Tcl_FindNamespaceVar(interp, TclGetString(objv[objc-1]), NULL, /*flags*/ 0); if (var != (Tcl_Var) NULL) { Tcl_GetVariableFullName(interp, var, resultPtr); } break; } } Tcl_SetObjResult(interp, resultPtr); |
︙ | ︙ | |||
4024 4025 4026 4027 4028 4029 4030 | * Frees the resources associated with a nsName object's internal * representation. * * Results: * None. * * Side effects: | | | | | | | | | | | | 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 | * Frees the resources associated with a nsName object's internal * representation. * * Results: * None. * * Side effects: * Decrements the ref count of any Namespace structure pointed to by the * nsName's internal representation. If there are no more references to * the namespace, it's structure will be freed. * *---------------------------------------------------------------------- */ static void FreeNsNameInternalRep(objPtr) register Tcl_Obj *objPtr; /* nsName object with internal representation * to free */ { register ResolvedNsName *resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; Namespace *nsPtr; /* * Decrement the reference count of the namespace. If there are no more * references, free it up. */ if (resNamePtr != NULL) { resNamePtr->refCount--; if (resNamePtr->refCount == 0) { /* * Decrement the reference count for the cached namespace. If the * namespace is dead, and there are no more references to it, free * it. */ nsPtr = resNamePtr->nsPtr; nsPtr->refCount--; if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { NamespaceFree(nsPtr); } |
︙ | ︙ | |||
4078 4079 4080 4081 4082 4083 4084 | * of the internal representation of another nsName object. * * Results: * None. * * Side effects: * copyPtr's internal rep is set to refer to the same namespace | | | | 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 | * of the internal representation of another nsName object. * * Results: * None. * * Side effects: * copyPtr's internal rep is set to refer to the same namespace * referenced by srcPtr's internal rep. Increments the ref count of the * ResolvedNsName structure used to hold the namespace reference. * *---------------------------------------------------------------------- */ static void DupNsNameInternalRep(srcPtr, copyPtr) Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ |
︙ | ︙ | |||
4104 4105 4106 4107 4108 4109 4110 | } /* *---------------------------------------------------------------------- * * SetNsNameFromAny -- * | | < | | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * SetNsNameFromAny -- * * Attempt to generate a nsName internal representation for a Tcl object. * * Results: * Returns TCL_OK if the value could be converted to a proper namespace * reference. Otherwise, it returns TCL_ERROR, along with an error * message in the interpreter's result object. * * Side effects: * If successful, the object is made a nsName object. Its internal rep is * set to point to a ResolvedNsName, which contains a cached pointer to * the Namespace. Reference counts are kept on both the ResolvedNsName * and the Namespace, so we can keep track of their usage and free them * when appropriate. * *---------------------------------------------------------------------- */ static int SetNsNameFromAny(interp, objPtr) Tcl_Interp *interp; /* Points to the namespace in which to resolve * name. Also used for error reporting if not * NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { char *name; CONST char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; register ResolvedNsName *resNamePtr; /* * Get the string representation. Make it up-to-date if necessary. */ name = objPtr->bytes; if (name == NULL) { name = TclGetString(objPtr); } /* * Look for the namespace "name" in the current namespace. If there is an * error parsing the (possibly qualified) name, return an error. If the * namespace isn't found, we convert the object to an nsName object with a * NULL ResolvedNsName* internal rep. */ TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); /* * If we found a namespace, then create a new ResolvedNsName structure |
︙ | ︙ | |||
4173 4174 4175 4176 4177 4178 4179 | resNamePtr->refNsPtr = currNsPtr; resNamePtr->refCount = 1; } else { resNamePtr = NULL; } /* | | | | | | | | | | 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 | resNamePtr->refNsPtr = currNsPtr; resNamePtr->refCount = 1; } else { resNamePtr = NULL; } /* * 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. */ TclFreeIntRep(objPtr); objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; objPtr->typePtr = &tclNsNameType; return TCL_OK; } /* *---------------------------------------------------------------------- * * UpdateStringOfNsName -- * * Updates the string representation for a nsName object. Note: This * function does not free an existing old string rep so storage will be * lost if this has not already been done. * * Results: * None. * * Side effects: * The object's string is set to a copy of the fully qualified namespace * name. * *---------------------------------------------------------------------- */ static void UpdateStringOfNsName(objPtr) register Tcl_Obj *objPtr; /* nsName object with string rep to update. */ |
︙ | ︙ | |||
4225 4226 4227 4228 4229 4230 4231 | } if (nsPtr != NULL) { name = nsPtr->fullName; } } /* | | | | | | | | | | | 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 | } if (nsPtr != NULL) { name = nsPtr->fullName; } } /* * The following sets the string rep to an empty string on the heap if the * internal rep is NULL. */ length = strlen(name); if (length == 0) { objPtr->bytes = tclEmptyStringRep; } else { objPtr->bytes = (char *) ckalloc((unsigned) (length + 1)); memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length); objPtr->bytes[length] = '\0'; } objPtr->length = length; } /* *---------------------------------------------------------------------- * * NamespaceEnsembleCmd -- * * Invoked to implement the "namespace ensemble" command that creates and * manipulates ensembles built on top of namespaces. Handles the * following syntax: * * namespace ensemble name ?dictionary? * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: * Creates the ensemble for the namespace if one did not previously * exist. Alternatively, alters the way that the ensemble's subcommand => * implementation prefix is configured. * *---------------------------------------------------------------------- */ static int NamespaceEnsembleCmd(dummy, interp, objc, objv) ClientData dummy; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { Namespace *nsPtr; Tcl_Command token; static CONST char *subcommands[] = { "configure", "create", "exists", NULL }; enum EnsSubcmds { ENS_CONFIG, ENS_CREATE, ENS_EXISTS }; static CONST char *createOptions[] = { |
︙ | ︙ | |||
4313 4314 4315 4316 4317 4318 4319 | return TCL_ERROR; } switch ((enum EnsSubcmds) index) { case ENS_CREATE: { char *name; Tcl_DictSearch search; | | | | | < | | | | | 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 | return TCL_ERROR; } switch ((enum EnsSubcmds) index) { case ENS_CREATE: { char *name; Tcl_DictSearch search; Tcl_Obj *listObj; int done, len, allocatedMapFlag = 0; /* * Defaults */ Tcl_Obj *subcmdObj = NULL; Tcl_Obj *mapObj = NULL; int permitPrefix = 1; Tcl_Obj *unknownObj = NULL; objv += 3; objc -= 3; /* * Work out what name to use for the command to create. If supplied, * it is either fully specified or relative to the current namespace. * If not supplied, it is exactly the name of the current namespace. */ name = nsPtr->fullName; /* * Parse the option list, applying type checks as we go. Note that we * are not incrementing any reference counts in the objects at this * stage, so the presence of an option multiple times won't cause any * memory leaks. */ for (; objc>1 ; objc-=2,objv+=2 ) { if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option", 0, &index) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); |
︙ | ︙ | |||
4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 | } return TCL_ERROR; } subcmdObj = (len > 0 ? objv[1] : NULL); continue; case CRT_MAP: { Tcl_Obj *patchedDict = NULL, *subcmdObj; /* * Verify that the map is sensible. */ if (Tcl_DictObjFirst(interp, objv[1], &search, &subcmdObj, &listObj, &done) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } | > > | 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 | } return TCL_ERROR; } subcmdObj = (len > 0 ? objv[1] : NULL); continue; case CRT_MAP: { Tcl_Obj *patchedDict = NULL, *subcmdObj; /* * Verify that the map is sensible. */ if (Tcl_DictObjFirst(interp, objv[1], &search, &subcmdObj, &listObj, &done) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } |
︙ | ︙ | |||
4410 4411 4412 4413 4414 4415 4416 | Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } cmd = TclGetString(listv[0]); if (!(cmd[0] == ':' && cmd[1] == ':')) { Tcl_Obj *newList = Tcl_NewListObj(len, listv); | | | > | 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 | Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } cmd = TclGetString(listv[0]); if (!(cmd[0] == ':' && cmd[1] == ':')) { Tcl_Obj *newList = Tcl_NewListObj(len, listv); Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1); if (nsPtr->parentPtr) { Tcl_AppendStringsToObj(newCmd, "::", NULL); } Tcl_AppendObjToObj(newCmd, listv[0]); Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); if (patchedDict == NULL) { patchedDict = Tcl_DuplicateObj(objv[1]); } Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList); } Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done); } while (!done); if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } mapObj = (patchedDict ? patchedDict : objv[1]); if (patchedDict) { allocatedMapFlag = 1; } |
︙ | ︙ | |||
4455 4456 4457 4458 4459 4460 4461 | } unknownObj = (len > 0 ? objv[1] : NULL); continue; } } /* | < < < < < < < < < < < < < < < < | | | < | < < | < < < < < < < < < < | > | < | | < < < < < < | < > | < < < < | > > | | | > > > | | > | | | > > > | > | > > > | > > | | | > > > > > | | < > > > > > | > > | > > > | | < > > > | | < > < < | > | | | | > | | | | | | 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 | } unknownObj = (len > 0 ? objv[1] : NULL); continue; } } /* * Create the ensemble. Note that this might delete another ensemble * linked to the same namespace, so we must be careful. However, we * should be OK because we only link the namespace into the list once * we've created it (and after any deletions have occurred.) */ token = Tcl_CreateEnsemble(interp, name, NULL, (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); Tcl_SetEnsembleMappingDict(interp, token, mapObj); Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); /* * Tricky! Must ensure that the result is not shared (command delete * traces could have corrupted the pristine object that we started * with). [Snit test rename-1.5] */ Tcl_ResetResult(interp); Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); return TCL_OK; } case ENS_EXISTS: if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "cmdname"); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( Tcl_FindEnsemble(interp, objv[3], 0) != NULL)); return TCL_OK; case ENS_CONFIG: if (objc < 4 || (objc != 5 && objc & 1)) { Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ..."); return TCL_ERROR; } token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG); if (token == NULL) { return TCL_ERROR; } if (objc == 5) { Tcl_Obj *resultObj; if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum EnsConfigOpts) index) { case CONF_SUBCMDS: Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); if (resultObj != NULL) { Tcl_SetObjResult(interp, resultObj); } break; case CONF_MAP: Tcl_GetEnsembleMappingDict(NULL, token, &resultObj); if (resultObj != NULL) { Tcl_SetObjResult(interp, resultObj); } break; case CONF_NAMESPACE: { Tcl_Namespace *namespacePtr; Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); Tcl_SetResult(interp, ((Namespace *)namespacePtr)->fullName, TCL_VOLATILE); break; } case CONF_PREFIX: { int flags; Tcl_GetEnsembleFlags(NULL, token, &flags); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); break; } case CONF_UNKNOWN: Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj); if (resultObj != NULL) { Tcl_SetObjResult(interp, resultObj); } break; } return TCL_OK; } else if (objc == 4) { /* * Produce list of all information. */ Tcl_Obj *resultObj, *tmpObj; Tcl_Namespace *namespacePtr; int flags; TclNewObj(resultObj); /* -map option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(configOptions[CONF_MAP], -1)); Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj); if (tmpObj != NULL) { Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); } else { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); } /* -namespace option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1)); Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(((Namespace *)namespacePtr)->fullName, -1)); /* -prefix option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(configOptions[CONF_PREFIX], -1)); Tcl_GetEnsembleFlags(NULL, token, &flags); Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); /* -subcommands option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1)); Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj); if (tmpObj != NULL) { Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); } else { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); } /* -unknown option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1)); Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj); if (tmpObj != NULL) { Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); } else { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } else { Tcl_DictSearch search; Tcl_Obj *listObj; int done, len, allocatedMapFlag = 0; Tcl_Obj *subcmdObj, *mapObj, *unknownObj; /* Defaults */ int permitPrefix, flags; Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj); Tcl_GetEnsembleMappingDict(NULL, token, &mapObj); Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj); Tcl_GetEnsembleFlags(NULL, token, &flags); permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; objv += 4; objc -= 4; /* * Parse the option list, applying type checks as we go. Note that * we are not incrementing any reference counts in the objects at * this stage, so the presence of an option multiple times won't * cause any memory leaks. */ for (; objc>0 ; objc-=2,objv+=2 ) { if (Tcl_GetIndexFromObj(interp, objv[0], configOptions, "option", 0, &index) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); |
︙ | ︙ | |||
4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 | } return TCL_ERROR; } subcmdObj = (len > 0 ? objv[1] : NULL); continue; case CONF_MAP: { Tcl_Obj *patchedDict = NULL, *subcmdObj; /* * Verify that the map is sensible. */ if (Tcl_DictObjFirst(interp, objv[1], &search, &subcmdObj, &listObj, &done) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } | > > | 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 | } return TCL_ERROR; } subcmdObj = (len > 0 ? objv[1] : NULL); continue; case CONF_MAP: { Tcl_Obj *patchedDict = NULL, *subcmdObj; /* * Verify that the map is sensible. */ if (Tcl_DictObjFirst(interp, objv[1], &search, &subcmdObj, &listObj, &done) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } |
︙ | ︙ | |||
4749 4750 4751 4752 4753 4754 4755 | } unknownObj = (len > 0 ? objv[1] : NULL); continue; } } /* | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < | < < | < < < | < < < < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | > | | | < | | | | | > | | > | > | | | > | | | | | | | | | | | | < | < | | | | | | | | | | > | | | | < | | | | > | | | | | | | | | | < | | > | | | > > | | | | < | | | | 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 | } unknownObj = (len > 0 ? objv[1] : NULL); continue; } } /* * Update the namespace now that we've finished the parsing stage. */ flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX : flags&~TCL_ENSEMBLE_PREFIX); Tcl_SetEnsembleSubcommandList(NULL, token, subcmdObj); Tcl_SetEnsembleMappingDict(NULL, token, mapObj); Tcl_SetEnsembleUnknownHandler(NULL, token, unknownObj); Tcl_SetEnsembleFlags(NULL, token, flags); return TCL_OK; } default: Tcl_Panic("unexpected ensemble command"); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_CreateEnsemble -- * * Create a simple ensemble attached to the given namespace. * * Results: * The token for the command created. * * Side effects: * The ensemble is created and marked for compilation. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateEnsemble(interp, name, namespacePtr, flags) Tcl_Interp *interp; CONST char *name; Tcl_Namespace *namespacePtr; int flags; { Namespace *nsPtr = (Namespace *) namespacePtr; EnsembleConfig *ensemblePtr = (EnsembleConfig *) ckalloc(sizeof(EnsembleConfig)); Tcl_Obj *nameObj = NULL; if (nsPtr == NULL) { nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } /* * Make the name of the ensemble into a fully qualified name. This might * allocate a temporary object. */ if (!(name[0] == ':' && name[1] == ':')) { nameObj = Tcl_NewStringObj(nsPtr->fullName, -1); if (nsPtr->parentPtr == NULL) { Tcl_AppendStringsToObj(nameObj, name, NULL); } else { Tcl_AppendStringsToObj(nameObj, "::", name, NULL); } Tcl_IncrRefCount(nameObj); name = TclGetString(nameObj); } ensemblePtr->nsPtr = nsPtr; ensemblePtr->epoch = 0; Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS); ensemblePtr->subcommandArrayPtr = NULL; ensemblePtr->subcmdList = NULL; ensemblePtr->subcommandDict = NULL; ensemblePtr->flags = flags; ensemblePtr->unknownHandler = NULL; ensemblePtr->token = Tcl_CreateObjCommand(interp, name, NsEnsembleImplementationCmd, (ClientData)ensemblePtr, DeleteEnsembleConfig); ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; /* * Trigger an eventual recomputation of the ensemble command set. Note * that this is slightly tricky, as it means that we are not actually * counting the number of namespace export actions, but it is the simplest * way to go! */ nsPtr->exportLookupEpoch++; if (nameObj != NULL) { TclDecrRefCount(nameObj); } return ensemblePtr->token; } /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleSubcommandList -- * * Set the subcommand list for a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an ensemble * or the subcommand list - if non-NULL - is not a list). * * Side effects: * The ensemble is updated and marked for recompilation. * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleSubcommandList(interp, token, subcmdList) Tcl_Interp *interp; Tcl_Command token; Tcl_Obj *subcmdList; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } if (subcmdList != NULL) { int length; if (Tcl_ListObjLength(interp, subcmdList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { subcmdList = NULL; } } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; oldList = ensemblePtr->subcmdList; ensemblePtr->subcmdList = subcmdList; if (subcmdList != NULL) { Tcl_IncrRefCount(subcmdList); } if (oldList != NULL) { TclDecrRefCount(oldList); } /* * Trigger an eventual recomputation of the ensemble command set. Note * that this is slightly tricky, as it means that we are not actually * counting the number of namespace export actions, but it is the simplest * way to go! */ ensemblePtr->nsPtr->exportLookupEpoch++; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleMappingDict -- * * Set the mapping dictionary for a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an ensemble * or the mapping - if non-NULL - is not a dict). * * Side effects: * The ensemble is updated and marked for recompilation. * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleMappingDict(interp, token, mapDict) Tcl_Interp *interp; Tcl_Command token; Tcl_Obj *mapDict; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; Tcl_Obj *oldDict; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } if (mapDict != NULL) { int size; if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) { return TCL_ERROR; } if (size < 1) { mapDict = NULL; } } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; oldDict = ensemblePtr->subcommandDict; ensemblePtr->subcommandDict = mapDict; if (mapDict != NULL) { Tcl_IncrRefCount(mapDict); } if (oldDict != NULL) { TclDecrRefCount(oldDict); } /* * Trigger an eventual recomputation of the ensemble command set. Note * that this is slightly tricky, as it means that we are not actually * counting the number of namespace export actions, but it is the simplest * way to go! */ ensemblePtr->nsPtr->exportLookupEpoch++; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleUnknownHandler -- * * Set the unknown handler for a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an ensemble * or the unknown handler - if non-NULL - is not a list). * * Side effects: * The ensemble is updated and marked for recompilation. * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleUnknownHandler(interp, token, unknownList) Tcl_Interp *interp; Tcl_Command token; Tcl_Obj *unknownList; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } if (unknownList != NULL) { int length; if (Tcl_ListObjLength(interp, unknownList, &length) != TCL_OK) { return TCL_ERROR; } if (length < 1) { unknownList = NULL; } } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; oldList = ensemblePtr->unknownHandler; ensemblePtr->unknownHandler = unknownList; if (unknownList != NULL) { Tcl_IncrRefCount(unknownList); } if (oldList != NULL) { TclDecrRefCount(oldList); } /* * Trigger an eventual recomputation of the ensemble command set. Note * that this is slightly tricky, as it means that we are not actually * counting the number of namespace export actions, but it is the simplest * way to go! */ ensemblePtr->nsPtr->exportLookupEpoch++; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleFlags -- * * Set the flags for a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble). * * Side effects: * The ensemble is updated and marked for recompilation. * *---------------------------------------------------------------------- */ int Tcl_SetEnsembleFlags(interp, token, flags) Tcl_Interp *interp; Tcl_Command token; int flags; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; /* * This API refuses to set the ENS_DEAD flag... */ ensemblePtr->flags &= ENS_DEAD; ensemblePtr->flags |= flags & ~ENS_DEAD; /* * Trigger an eventual recomputation of the ensemble command set. Note * that this is slightly tricky, as it means that we are not actually * counting the number of namespace export actions, but it is the simplest * way to go! */ ensemblePtr->nsPtr->exportLookupEpoch++; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetEnsembleSubcommandList -- * * Get the list of subcommands associated with a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble). The list of subcommands is returned by updating the * variable pointed to by the last parameter (NULL if this is to be * derived from the mapping dictionary or the associated namespace's * exported commands). * * Side effects: * None * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleSubcommandList(interp, token, subcmdListPtr) Tcl_Interp *interp; Tcl_Command token; Tcl_Obj **subcmdListPtr; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; *subcmdListPtr = ensemblePtr->subcmdList; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetEnsembleMappingDict -- * * Get the command mapping dictionary associated with a particular * ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble). The mapping dict is returned by updating the variable * pointed to by the last parameter (NULL if none is installed). * * Side effects: * None * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleMappingDict(interp, token, mapDictPtr) Tcl_Interp *interp; Tcl_Command token; Tcl_Obj **mapDictPtr; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; *mapDictPtr = ensemblePtr->subcommandDict; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetEnsembleUnknownHandler -- * * Get the unknown handler associated with a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble). The unknown handler is returned by updating the variable * pointed to by the last parameter (NULL if no handler is installed). * * Side effects: * None * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleUnknownHandler(interp, token, unknownListPtr) Tcl_Interp *interp; Tcl_Command token; Tcl_Obj **unknownListPtr; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; *unknownListPtr = ensemblePtr->unknownHandler; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetEnsembleFlags -- * * Get the flags for a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble). The flags are returned by updating the variable pointed to * by the last parameter. * * Side effects: * None * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleFlags(interp, token, flagsPtr) Tcl_Interp *interp; Tcl_Command token; int *flagsPtr; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; *flagsPtr = ensemblePtr->flags; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetEnsembleNamespace -- * * Get the namespace associated with a particular ensemble. * * Results: * Tcl result code (error if command token does not indicate an * ensemble). Namespace is returned by updating the variable pointed to * by the last parameter. * * Side effects: * None * *---------------------------------------------------------------------- */ int Tcl_GetEnsembleNamespace(interp, token, namespacePtrPtr) Tcl_Interp *interp; Tcl_Command token; Tcl_Namespace **namespacePtrPtr; { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { if (interp != NULL) { Tcl_AppendResult(interp, "command is not an ensemble", NULL); } return TCL_ERROR; } ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_FindEnsemble -- * * Given a command name, get the ensemble token for it, allowing for * [namespace import]s. [Bug 1017022] * * Results: * The token for the ensemble command with the given name, or NULL if the * command either does not exist or is not an ensemble (when an error * message will be written into the interp if thats non-NULL). * * Side effects: * None * *---------------------------------------------------------------------- */ Tcl_Command Tcl_FindEnsemble(interp, cmdNameObj, flags) Tcl_Interp *interp; /* Where to do the lookup, and where to write * the errors if TCL_LEAVE_ERR_MSG is set in * the flags. */ Tcl_Obj *cmdNameObj; /* Name of command to look up. */ int flags; /* Either 0 or TCL_LEAVE_ERR_MSG; other flags * are probably not useful. */ { Command *cmdPtr; cmdPtr = (Command *) Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); if (cmdPtr == NULL) { return NULL; } if (cmdPtr->objProc != NsEnsembleImplementationCmd) { /* * Reuse existing infrastructure for following import link chains * rather than duplicating it. */ cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { if (flags & TCL_LEAVE_ERR_MSG) { Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj), "\" is not an ensemble command", NULL); } return NULL; } } return (Tcl_Command) cmdPtr; } /* *---------------------------------------------------------------------- * * Tcl_IsEnsemble -- * * Simple test for ensemble-hood that takes into account imported * ensemble commands as well. * * Results: * Boolean value * * Side effects: * None * *---------------------------------------------------------------------- */ int Tcl_IsEnsemble(token) Tcl_Command token; { Command *cmdPtr = (Command *) token; if (cmdPtr->objProc == NsEnsembleImplementationCmd) { return 1; } cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { return 0; } return 1; } /* *---------------------------------------------------------------------- * * NsEnsembleImplementationCmd -- * * Implements an ensemble of commands (being those exported by a * namespace other than the global namespace) as a command with the same * (short) name as the namespace in the parent namespace. * * Results: * A standard Tcl result code. Will be TCL_ERROR if the command is not an * unambiguous prefix of any command exported by the ensemble's * namespace. * * Side effects: * Depends on the command within the namespace that gets executed. If the * ensemble itself returns TCL_ERROR, a descriptive error message will be * placed in the interpreter's result. * *---------------------------------------------------------------------- */ static int NsEnsembleImplementationCmd(clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj *CONST objv[]; { EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData; /* The ensemble itself. */ Tcl_Obj **tempObjv; /* Space used to construct the list of * arguments to pass to the command that * implements the ensemble subcommand. */ int result; /* The result of the subcommand execution. */ Tcl_Obj *prefixObj; /* An object containing the prefix words of * the command that implements the * subcommand. */ Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully * specified but not yet cached command * names. */ Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the * target command prefix. */ int prefixObjc; /* Size of prefixObjv of course! */ int reparseCount = 0; /* Number of reparses. */ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?"); return TCL_ERROR; } restartEnsembleParse: if (ensemblePtr->nsPtr->flags & NS_DEAD) { /* * Don't know how we got here, but make things give up quickly. */ if (!Tcl_InterpDeleted(interp)) { Tcl_AppendResult(interp, "ensemble activated for deleted namespace", NULL); } return TCL_ERROR; } if (ensemblePtr->epoch != ensemblePtr->nsPtr->exportLookupEpoch) { ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch; BuildEnsembleConfig(ensemblePtr); } else { /* * Table of subcommands is still valid; therefore there might be a * valid cache of discovered information which we can reuse. Do the * check here, and if we're still valid, we can jump straight to the * part where we do the invocation of the subcommand. */ if (objv[1]->typePtr == &ensembleCmdType) { EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *) objv[1]->internalRep.otherValuePtr; if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && ensembleCmd->epoch == ensemblePtr->epoch && ensembleCmd->token == ensemblePtr->token) { prefixObj = ensembleCmd->realPrefixObj; Tcl_IncrRefCount(prefixObj); goto runResultingSubcommand; } } } /* * Look in the hashtable for the subcommand name; this is the fastest way * of all. */ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, TclGetString(objv[1])); if (hPtr != NULL) { char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr); prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); /* * Cache for later in the subcommand object. */ MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { /* * Can't find and we are prohibited from using unambiguous prefixes. */ goto unknownOrAmbiguousSubcommand; } else { /* * If we've not already confirmed the command with the hash as part of * building our export table, we need to scan the sorted array for * matches. */ char *subcmdName; /* Name of the subcommand, or unique prefix of * it (will be an error for a non-unique * prefix). */ char *fullName = NULL; /* Full name of the subcommand. */ int stringLength, i; int tableLength = ensemblePtr->subcommandTable.numEntries; subcmdName = TclGetString(objv[1]); stringLength = objv[1]->length; for (i=0 ; i<tableLength ; i++) { register int cmp = strncmp(subcmdName, ensemblePtr->subcommandArrayPtr[i], (unsigned) stringLength); if (cmp == 0) { if (fullName != NULL) { /* * Since there's never the exact-match case to worry about * (hash search filters this), getting here indicates that * our subcommand is an ambiguous prefix of (at least) two * exported subcommands, which is an error case. */ goto unknownOrAmbiguousSubcommand; } fullName = ensemblePtr->subcommandArrayPtr[i]; } else if (cmp < 0) { /* * Because we are searching a sorted table, we can now stop * searching because we have gone past anything that could * possibly match. */ break; } } if (fullName == NULL) { /* * The subcommand is not a prefix of anything, so bail out! */ goto unknownOrAmbiguousSubcommand; } hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName); if (hPtr == NULL) { Tcl_Panic("full name %s not found in supposedly synchronized hash", fullName); } prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); /* * Cache for later in the subcommand object. */ MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); } /* * Do the real work of execution of the subcommand by building an array of * objects (note that this is potentially not the same length as the * number of arguments to this ensemble command), populating it and then * feeding it back through the main command-lookup engine. In theory, we * could look up the command in the namespace ourselves, as we already * have the namespace in which it is guaranteed to exist, but we don't do * that (the cacheing of the command object used should help with that.) */ Tcl_IncrRefCount(prefixObj); runResultingSubcommand: { Interp *iPtr = (Interp *) interp; int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); |
︙ | ︙ | |||
5109 5110 5111 5112 5113 5114 5115 | iPtr->ensembleRewrite.numInsertedObjs = 0; } return result; } unknownOrAmbiguousSubcommand: /* | | | | | | 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 | iPtr->ensembleRewrite.numInsertedObjs = 0; } return result; } unknownOrAmbiguousSubcommand: /* * Have not been able to match the subcommand asked for with a real * subcommand that we export. See whether a handler has been registered * for dealing with this situation. Will only call (at most) once for any * particular ensemble invocation. */ if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { int paramc, i; Tcl_Obj **paramv, *unknownCmd, *ensObj; unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); |
︙ | ︙ | |||
5145 5146 5147 5148 5149 5150 5151 | Tcl_SetResult(interp, "unknown subcommand handler deleted its ensemble", TCL_STATIC); return TCL_ERROR; } /* | | | | | 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 | Tcl_SetResult(interp, "unknown subcommand handler deleted its ensemble", TCL_STATIC); return TCL_ERROR; } /* * Namespace is still there. Check if the result is a valid list. * If it is, and it is non-empty, that list is what we are using * as our replacement. */ if (Tcl_ListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) { Tcl_DecrRefCount(prefixObj); Tcl_AddErrorInfo(interp, "\n while parsing result of ensemble unknown subcommand handler"); return TCL_ERROR; |
︙ | ︙ | |||
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 | Tcl_AppendResult(interp, "break", NULL); break; case TCL_CONTINUE: Tcl_AppendResult(interp, "continue", NULL); break; default: { char buf[TCL_INTEGER_SPACE]; sprintf(buf, "%d", result); Tcl_AppendResult(interp, buf, NULL); } } Tcl_AddErrorInfo(interp, "\n result of ensemble unknown subcommand handler: "); Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); } else { Tcl_AddErrorInfo(interp, "\n (ensemble unknown subcommand handler)"); } } Tcl_DecrRefCount(unknownCmd); Tcl_Release(ensemblePtr); return TCL_ERROR; } /* * Cannot determine what subcommand to hand off to, so generate a | > | | | | | | | | | < | | | > | > | | | | | | | | | | 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 | Tcl_AppendResult(interp, "break", NULL); break; case TCL_CONTINUE: Tcl_AppendResult(interp, "continue", NULL); break; default: { char buf[TCL_INTEGER_SPACE]; sprintf(buf, "%d", result); Tcl_AppendResult(interp, buf, NULL); } } Tcl_AddErrorInfo(interp, "\n result of ensemble unknown subcommand handler: "); Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); } else { Tcl_AddErrorInfo(interp, "\n (ensemble unknown subcommand handler)"); } } Tcl_DecrRefCount(unknownCmd); Tcl_Release(ensemblePtr); return TCL_ERROR; } /* * Cannot determine what subcommand to hand off to, so generate a * (standard) failure message. Note the one odd case compared with * standard ensemble-like command, which is where a namespace has no * exported commands at all... */ Tcl_ResetResult(interp); if (ensemblePtr->subcommandTable.numEntries == 0) { Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]), "\": namespace ", ensemblePtr->nsPtr->fullName, " does not export any commands", NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "unknown ", (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""), "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL); if (ensemblePtr->subcommandTable.numEntries == 1) { Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL); } else { int i; for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) { Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[i], ", ", NULL); } Tcl_AppendResult(interp, "or ", ensemblePtr->subcommandArrayPtr[i], NULL); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * MakeCachedEnsembleCommand -- * * Cache what we've computed so far; it's not nice to repeatedly copy * strings about. Note that to do this, we start by deleting any old * representation that there was (though if it was an out of date * ensemble rep, we can skip some of the deallocation process.) * * Results: * None * * Side effects: * Alters the internal representation of the first object parameter. * *---------------------------------------------------------------------- */ static void MakeCachedEnsembleCommand(objPtr, ensemblePtr, subcommandName, prefixObjPtr) Tcl_Obj *objPtr; EnsembleConfig *ensemblePtr; CONST char *subcommandName; Tcl_Obj *prefixObjPtr; { register EnsembleCmdRep *ensembleCmd; int length; if (objPtr->typePtr == &ensembleCmdType) { ensembleCmd = (EnsembleCmdRep *) objPtr->internalRep.otherValuePtr; Tcl_DecrRefCount(ensembleCmd->realPrefixObj); ensembleCmd->nsPtr->refCount--; if ((ensembleCmd->nsPtr->refCount == 0) && (ensembleCmd->nsPtr->flags & NS_DEAD)) { NamespaceFree(ensembleCmd->nsPtr); } ckfree(ensembleCmd->fullSubcmdName); } else { /* * Kill the old internal rep, and replace it with a brand new one of * our own. */ TclFreeIntRep(objPtr); ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); objPtr->internalRep.otherValuePtr = (VOID *) ensembleCmd; objPtr->typePtr = &ensembleCmdType; } /* * Populate the internal rep. */ ensembleCmd->nsPtr = ensemblePtr->nsPtr; ensembleCmd->epoch = ensemblePtr->epoch; ensembleCmd->token = ensemblePtr->token; ensemblePtr->nsPtr->refCount++; ensembleCmd->realPrefixObj = prefixObjPtr; length = strlen(subcommandName)+1; ensembleCmd->fullSubcmdName = ckalloc((unsigned) length); memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length); Tcl_IncrRefCount(ensembleCmd->realPrefixObj); } /* *---------------------------------------------------------------------- * * DeleteEnsembleConfig -- * * Destroys the data structure used to represent an ensemble. This is * called when the ensemble's command is deleted (which happens * automatically if the ensemble's namespace is deleted.) Maintainers * should note that ensembles should be deleted by deleting their * commands. * * Results: * None. * * Side effects: * Memory is (eventually) deallocated. * *---------------------------------------------------------------------- */ static void DeleteEnsembleConfig(clientData) ClientData clientData; { EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData; Namespace *nsPtr = ensemblePtr->nsPtr; Tcl_HashSearch search; Tcl_HashEntry *hEnt; /* * Unlink from the ensemble chain if it has not been marked as having been * done already. */ if (ensemblePtr->next != ensemblePtr) { EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles; if (ensPtr == ensemblePtr) { nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; } else { while (ensPtr != NULL) { if (ensPtr->next == ensemblePtr) { ensPtr->next = ensemblePtr->next; break; } ensPtr = ensPtr->next; } } } /* * Mark the namespace as dead so code that uses Tcl_Preserve() can tell * whether disaster happened anyway. */ ensemblePtr->flags |= ENS_DEAD; /* * Kill the pointer-containing fields. */ |
︙ | ︙ | |||
5377 5378 5379 5380 5381 5382 5383 | Tcl_DecrRefCount(ensemblePtr->subcommandDict); } if (ensemblePtr->unknownHandler != NULL) { Tcl_DecrRefCount(ensemblePtr->unknownHandler); } /* | | | | | | | | | | | | | | | | | > | | | < > > > | | < | > | | | < > > | | | < | | | | | | | | | | | | 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 | Tcl_DecrRefCount(ensemblePtr->subcommandDict); } if (ensemblePtr->unknownHandler != NULL) { Tcl_DecrRefCount(ensemblePtr->unknownHandler); } /* * Arrange for the structure to be reclaimed. Note that this is complex * because we have to make sure that we can react sensibly when an * ensemble is deleted during the process of initialising the ensemble * (especially the unknown callback.) */ Tcl_EventuallyFree((ClientData) ensemblePtr, TCL_DYNAMIC); } /* *---------------------------------------------------------------------- * * BuildEnsembleConfig -- * * Create the internal data structures that describe how an ensemble * looks, being a hash mapping from the full command name to the Tcl list * that describes the implementation prefix words, and a sorted array of * all the full command names to allow for reasonably efficient * unambiguous prefix handling. * * Results: * None. * * Side effects: * Reallocates and rebuilds the hash table and array stored at the * ensemblePtr argument. For large ensembles or large namespaces, this is * a potentially expensive operation. * *---------------------------------------------------------------------- */ static void BuildEnsembleConfig(ensemblePtr) EnsembleConfig *ensemblePtr; { Tcl_HashSearch search; /* Used for scanning the set of commands in * the namespace that backs up this * ensemble. */ int i, j, isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; if (hash->numEntries != 0) { /* * Remove pre-existing table. */ Tcl_HashSearch search; ckfree((char *)ensemblePtr->subcommandArrayPtr); hPtr = Tcl_FirstHashEntry(hash, &search); while (hPtr != NULL) { Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); Tcl_DecrRefCount(prefixObj); hPtr = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(hash); Tcl_InitHashTable(hash, TCL_STRING_KEYS); } /* * See if we've got an export list. If so, we will only export exactly * those commands, which may be either implemented by the prefix in the * subcommandDict or mapped directly onto the namespace's commands. */ if (ensemblePtr->subcmdList != NULL) { Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj; int subcmdc; Tcl_ListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc, &subcmdv); for (i=0 ; i<subcmdc ; i++) { char *name = TclGetString(subcmdv[i]); hPtr = Tcl_CreateHashEntry(hash, name, &isNew); /* Skip non-unique cases. */ if (!isNew) { continue; } /* * Look in our dictionary (if present) for the command. */ if (ensemblePtr->subcommandDict != NULL) { Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i], &target); if (target != NULL) { Tcl_SetHashValue(hPtr, (ClientData) target); Tcl_IncrRefCount(target); continue; } } /* * Not there, so map onto the namespace. Note in this case that we * do not guarantee that the command is actually there; that is * the programmer's responsibility (or [::unknown] of course). */ cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); if (ensemblePtr->nsPtr->parentPtr != NULL) { Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); } else { Tcl_AppendStringsToObj(cmdObj, name, NULL); } cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, (ClientData) cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } } else if (ensemblePtr->subcommandDict != NULL) { /* * No subcmd list, but we do have a mapping dictionary so we should * use the keys of that. Convert the dictionary's contents into the * form required for the ensemble's internal hashtable. */ Tcl_DictSearch dictSearch; Tcl_Obj *keyObj, *valueObj; int done; Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, &keyObj, &valueObj, &done); while (!done) { char *name = TclGetString(keyObj); hPtr = Tcl_CreateHashEntry(hash, name, &isNew); Tcl_SetHashValue(hPtr, (ClientData) valueObj); Tcl_IncrRefCount(valueObj); Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); } } else { /* * Discover what commands are actually exported by the namespace. * What we have is an array of patterns and a hash table whose keys * are the command names exported by the namespace (the contents do * not matter here.) We must find out what commands are actually * exported by filtering each command in the namespace against each of * the patterns in the export list. Note that we use an intermediate * hash table to make memory management easier, and because that makes * exact matching far easier too. * * Suggestion for future enhancement: compute the unique prefixes and * place them in the hash too, which should make for even faster * matching. */ hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { char *nsCmdName = /* Name of command in namespace. */ Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) { if (Tcl_StringMatch(nsCmdName, ensemblePtr->nsPtr->exportArrayPtr[i])) { hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); /* * Remember, hash entries have a full reference to the * substituted part of the command (as a list) as their * content! */ if (isNew) { Tcl_Obj *cmdObj, *cmdPrefixObj; TclNewObj(cmdObj); Tcl_AppendStringsToObj(cmdObj, |
︙ | ︙ | |||
5563 5564 5565 5566 5567 5568 5569 | if (hash->numEntries == 0) { ensemblePtr->subcommandArrayPtr = NULL; return; } /* | | | | | | < | | | < | | | < | | | < | | | | | | | 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 | if (hash->numEntries == 0) { ensemblePtr->subcommandArrayPtr = NULL; return; } /* * Create a sorted array of all subcommands in the ensemble; hash tables * are all very well for a quick look for an exact match, but they can't * determine things like whether a string is a prefix of another (not * without lots of preparation anyway) and they're no good for when we're * generating the error message either. * * We do this by filling an array with the names (we use the hash keys * directly to save a copy, since any time we change the array we change * the hash too, and vice versa) and running quicksort over the array. */ ensemblePtr->subcommandArrayPtr = (char **) ckalloc(sizeof(char *) * hash->numEntries); /* * Fill array from both ends as this makes us less likely to end up with * performance problems in qsort(), which is good. Note that doing this * makes this code much more opaque, but the naive alternatve: * * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ; * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) { * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr); * } * * can produce long runs of precisely ordered table entries when the * commands in the namespace are declared in a sorted fashion (an ordering * some people like) and the hashing functions (or the command names * themselves) are fairly unfortunate. By filling from both ends, it * requires active malice (and probably a debugger) to get qsort() to have * awful runtime behaviour. */ i = 0; j = hash->numEntries; hPtr = Tcl_FirstHashEntry(hash, &search); while (hPtr != NULL) { ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr); |
︙ | ︙ | |||
5622 5623 5624 5625 5626 5627 5628 | } /* *---------------------------------------------------------------------- * * NsEnsembleStringOrder -- * | | | | | | 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 | } /* *---------------------------------------------------------------------- * * NsEnsembleStringOrder -- * * Helper function to compare two pointers to two strings for use with * qsort(). * * Results: * -1 if the first string is smaller, 1 if the second string is smaller, * and 0 if they are equal. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
5654 5655 5656 5657 5658 5659 5660 | * Destroys the internal representation of a Tcl_Obj that has been * holding information about a command in an ensemble. * * Results: * None. * * Side effects: | | | 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 | * Destroys the internal representation of a Tcl_Obj that has been * holding information about a command in an ensemble. * * Results: * None. * * Side effects: * Memory is deallocated. If this held the last reference to a * namespace's main structure, that main structure will also be * destroyed. * *---------------------------------------------------------------------- */ static void |
︙ | ︙ | |||
5683 5684 5685 5686 5687 5688 5689 | } /* *---------------------------------------------------------------------- * * DupEnsembleCmdRep -- * | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * DupEnsembleCmdRep -- * * Makes one Tcl_Obj into a copy of another that is a subcommand of an * ensemble. * * Results: * None. * * Side effects: * Memory is allocated, and the namespace that the ensemble is built on * top of gains another reference. * *---------------------------------------------------------------------- */ static void DupEnsembleCmdRep(objPtr, copyPtr) Tcl_Obj *objPtr, *copyPtr; { EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *) objPtr->internalRep.otherValuePtr; EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); int length = strlen(ensembleCmd->fullSubcmdName); copyPtr->typePtr = &ensembleCmdType; copyPtr->internalRep.otherValuePtr = (VOID *) ensembleCopy; ensembleCopy->nsPtr = ensembleCmd->nsPtr; ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; ensembleCopy->nsPtr->refCount++; ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj; Tcl_IncrRefCount(ensembleCopy->realPrefixObj); ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1); memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName, (unsigned) length+1); } /* *---------------------------------------------------------------------- * * StringOfEnsembleCmdRep -- * * Creates a string representation of a Tcl_Obj that holds a subcommand * of an ensemble. * * Results: * None. * * Side effects: * The object gains a string (UTF-8) representation. * |
︙ | ︙ | |||
5748 5749 5750 5751 5752 5753 5754 | objPtr->internalRep.otherValuePtr; int length = strlen(ensembleCmd->fullSubcmdName); objPtr->length = length; objPtr->bytes = ckalloc((unsigned) length+1); memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); } | > > > > > > > > | 6620 6621 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 | objPtr->internalRep.otherValuePtr; int length = strlen(ensembleCmd->fullSubcmdName); objPtr->length = length; objPtr->bytes = ckalloc((unsigned) length+1); memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclNotify.c.
|
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | /* * tclNotify.c -- * * This file implements the generic portion of the Tcl notifier. The * notifier is lowest-level part of the event system. It manages an event * queue that holds Tcl_Event structures. The platform specific portion * of the notifier is defined in the tcl*Notify.c files in each platform * directory. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclNotify.c,v 1.16.2.2 2005/08/02 18:16:02 dgp Exp $ */ #include "tclInt.h" extern TclStubs tclStubs; /* * For each event source (created with Tcl_CreateEventSource) there is a * structure of the following type: */ typedef struct EventSource { Tcl_EventSetupProc *setupProc; Tcl_EventCheckProc *checkProc; ClientData clientData; struct EventSource *nextPtr; } EventSource; /* * The following structure keeps track of the state of the notifier on a * per-thread basis. The first three elements keep track of the event queue. * In addition to the first (next to be serviced) and last events in the * queue, we keep track of a "marker" event. This provides a simple priority * mechanism whereby events can be inserted at the front of the queue but * behind all other high-priority events already in the queue (this is used * for things like a sequence of Enter and Leave events generated during a * grab in Tk). These elements are protected by the queueMutex so that any * thread can queue an event on any notifier. Note that all of the values in * this structure will be initialized to 0. */ typedef struct ThreadSpecificData { Tcl_Event *firstEventPtr; /* First pending event, or NULL if none. */ Tcl_Event *lastEventPtr; /* Last pending event, or NULL if none. */ Tcl_Event *markerEventPtr; /* Last high-priority event in queue, or NULL * if none. */ Tcl_Mutex queueMutex; /* Mutex to protect access to the previous * three fields. */ int serviceMode; /* One of TCL_SERVICE_NONE or * TCL_SERVICE_ALL. */ int blockTimeSet; /* 0 means there is no maximum block time: * block forever. */ Tcl_Time blockTime; /* If blockTimeSet is 1, gives the maximum * elapsed time for the next block. */ int inTraversal; /* 1 if Tcl_SetMaxBlockTime is being called * during an event source traversal. */ EventSource *firstEventSourcePtr; /* Pointer to first event source in list of * event sources for this thread. */ Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */ ClientData clientData; /* Opaque handle for platform specific * notifier. */ int initialized; /* 1 if notifier has been initialized. */ struct ThreadSpecificData *nextPtr; /* Next notifier in global list of notifiers. * Access is controlled by the listLock global * mutex. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * Global list of notifiers. Access to this list is controlled by the listLock * mutex. If this becomes a performance bottleneck, this could be replaced * with a hashtable. */ static ThreadSpecificData *firstNotifierPtr = NULL; TCL_DECLARE_MUTEX(listLock) /* * Declarations for routines used only in this file. |
︙ | ︙ | |||
112 113 114 115 116 117 118 | TclInitNotifier() { ThreadSpecificData *tsdPtr; Tcl_ThreadId threadId = Tcl_GetCurrentThread(); Tcl_MutexLock(&listLock); for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId; | | > > | > > > | < | | | | | | | | | | | | | | > | | | | | | | 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 | TclInitNotifier() { ThreadSpecificData *tsdPtr; Tcl_ThreadId threadId = Tcl_GetCurrentThread(); Tcl_MutexLock(&listLock); for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId; tsdPtr = tsdPtr->nextPtr) { /* Empty loop body. */ } if (NULL == tsdPtr) { /* * Notifier not yet initialized in this thread. */ tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->threadId = threadId; tsdPtr->clientData = tclStubs.tcl_InitNotifier(); tsdPtr->initialized = 1; tsdPtr->nextPtr = firstNotifierPtr; firstNotifierPtr = tsdPtr; } Tcl_MutexUnlock(&listLock); } /* *---------------------------------------------------------------------- * * TclFinalizeNotifier -- * * Finalize the thread local data structures for the notifier subsystem. * * Results: * None. * * Side effects: * Removes the notifier associated with the current thread from the * global notifier list. This is done only if the notifier was * initialized for this thread by call to TclInitNotifier(). This is * always true for threads which have been seeded with an Tcl * interpreter, since the call to Tcl_CreateInterp will, among other * things, call TclInitializeSubsystems() and this one will, in turn, * call the TclInitNotifier() for the thread. For threads created without * the Tcl interpreter, though, nobody is explicitly nor implicitly * calling the TclInitNotifier hence, TclFinalizeNotifier should not be * performed at all. * *---------------------------------------------------------------------- */ void TclFinalizeNotifier() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ThreadSpecificData **prevPtrPtr; Tcl_Event *evPtr, *hold; if (!tsdPtr->initialized) { return; /* Notifier not initialized for the current thread */ } Tcl_MutexLock(&(tsdPtr->queueMutex)); for (evPtr = tsdPtr->firstEventPtr; evPtr != (Tcl_Event *) NULL; ) { hold = evPtr; evPtr = evPtr->nextPtr; ckfree((char *) hold); } tsdPtr->firstEventPtr = NULL; tsdPtr->lastEventPtr = NULL; Tcl_MutexUnlock(&(tsdPtr->queueMutex)); Tcl_MutexLock(&listLock); if (tclStubs.tcl_FinalizeNotifier) { tclStubs.tcl_FinalizeNotifier(tsdPtr->clientData); } Tcl_MutexFinalize(&(tsdPtr->queueMutex)); for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL; prevPtrPtr = &((*prevPtrPtr)->nextPtr)) { if (*prevPtrPtr == tsdPtr) { *prevPtrPtr = tsdPtr->nextPtr; break; } } tsdPtr->initialized = 0; Tcl_MutexUnlock(&listLock); } /* *---------------------------------------------------------------------- * * Tcl_SetNotifier -- * * Install a set of alternate functions for use with the notifier. In * particular, this can be used to install the Xt-based notifier for use * with the Browser plugin. * * Results: * None. * * Side effects: * Overstomps part of the stub vector. This relies on hooks added to the * default functions in case those are called directly (i.e., not through * the stub table.) * *---------------------------------------------------------------------- */ void Tcl_SetNotifier(notifierProcPtr) Tcl_NotifierProcs *notifierProcPtr; |
︙ | ︙ | |||
231 232 233 234 235 236 237 | } /* *---------------------------------------------------------------------- * * Tcl_CreateEventSource -- * | | | | < | | | | | | | | | | | > | | > | | | | | | | < | > | | > | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_CreateEventSource -- * * This function is invoked to create a new source of events. The source * is identified by a function that gets invoked during Tcl_DoOneEvent to * check for events on that source and queue them. * * * Results: * None. * * Side effects: * SetupProc and checkProc will be invoked each time that Tcl_DoOneEvent * runs out of things to do. SetupProc will be invoked before * Tcl_DoOneEvent calls select or whatever else it uses to wait for * events. SetupProc typically calls functions like Tcl_SetMaxBlockTime * to indicate what to wait for. * * CheckProc is called after select or whatever operation was actually * used to wait. It figures out whether anything interesting actually * happened (e.g. by calling Tcl_AsyncReady), and then calls * Tcl_QueueEvent to queue any events that are ready. * * Each of these functions is passed two arguments, e.g. * (*checkProc)(ClientData clientData, int flags)); * ClientData is the same as the clientData argument here, and flags is a * combination of things like TCL_FILE_EVENTS that indicates what events * are of interest: setupProc and checkProc use flags to figure out * whether their events are relevant or not. * *---------------------------------------------------------------------- */ void Tcl_CreateEventSource(setupProc, checkProc, clientData) Tcl_EventSetupProc *setupProc; /* Function to invoke to figure out what to * wait for. */ Tcl_EventCheckProc *checkProc; /* Function to call after waiting to see what * happened. */ ClientData clientData; /* One-word argument to pass to setupProc and * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource)); sourcePtr->setupProc = setupProc; sourcePtr->checkProc = checkProc; sourcePtr->clientData = clientData; sourcePtr->nextPtr = tsdPtr->firstEventSourcePtr; tsdPtr->firstEventSourcePtr = sourcePtr; } /* *---------------------------------------------------------------------- * * Tcl_DeleteEventSource -- * * This function is invoked to delete the source of events given by proc * and clientData. * * Results: * None. * * Side effects: * The given event source is cancelled, so its function will never again * be called. If no such source exists, nothing happens. * *---------------------------------------------------------------------- */ void Tcl_DeleteEventSource(setupProc, checkProc, clientData) Tcl_EventSetupProc *setupProc; /* Function to invoke to figure out what to * wait for. */ Tcl_EventCheckProc *checkProc; /* Function to call after waiting to see what * happened. */ ClientData clientData; /* One-word argument to pass to setupProc and * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); EventSource *sourcePtr, *prevPtr; for (sourcePtr = tsdPtr->firstEventSourcePtr, prevPtr = NULL; sourcePtr != NULL; prevPtr = sourcePtr, sourcePtr = sourcePtr->nextPtr) { |
︙ | ︙ | |||
335 336 337 338 339 340 341 | } /* *---------------------------------------------------------------------- * * Tcl_QueueEvent -- * | | < | | | | | < | 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 | } /* *---------------------------------------------------------------------- * * Tcl_QueueEvent -- * * Queue an event on the event queue associated with the current thread. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_QueueEvent(evPtr, position) Tcl_Event* evPtr; /* Event to add to queue. The storage space * must have been allocated the caller with * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, * TCL_QUEUE_MARK. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); QueueEvent(tsdPtr, evPtr, position); } |
︙ | ︙ | |||
381 382 383 384 385 386 387 | * *---------------------------------------------------------------------- */ void Tcl_ThreadQueueEvent(threadId, evPtr, position) Tcl_ThreadId threadId; /* Identifier for thread to use. */ | | | | | | < | | | | | | | | | | | | < | 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 | * *---------------------------------------------------------------------- */ void Tcl_ThreadQueueEvent(threadId, evPtr, position) Tcl_ThreadId threadId; /* Identifier for thread to use. */ Tcl_Event* evPtr; /* Event to add to queue. The storage space * must have been allocated the caller with * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, * TCL_QUEUE_MARK. */ { ThreadSpecificData *tsdPtr; /* * Find the notifier associated with the specified thread. */ Tcl_MutexLock(&listLock); for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId; tsdPtr = tsdPtr->nextPtr) { /* Empty loop body. */ } /* * Queue the event if there was a notifier associated with the thread. */ if (tsdPtr) { QueueEvent(tsdPtr, evPtr, position); } Tcl_MutexUnlock(&listLock); } /* *---------------------------------------------------------------------- * * QueueEvent -- * * Insert an event into the specified thread's event queue at one of * three positions: the head, the tail, or before a floating marker. * Events inserted before the marker will be processed in first-in- * first-out order, but before any events inserted at the tail of the * queue. Events inserted at the head of the queue will be processed in * last-in-first-out order. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void QueueEvent(tsdPtr, evPtr, position) ThreadSpecificData *tsdPtr; /* Handle to thread local data that indicates * which event queue to use. */ Tcl_Event* evPtr; /* Event to add to queue. The storage space * must have been allocated the caller with * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, * TCL_QUEUE_MARK. */ { Tcl_MutexLock(&(tsdPtr->queueMutex)); if (position == TCL_QUEUE_TAIL) { /* * Append the event on the end of the queue. |
︙ | ︙ | |||
467 468 469 470 471 472 473 | /* * Push the event on the head of the queue. */ evPtr->nextPtr = tsdPtr->firstEventPtr; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->lastEventPtr = evPtr; | | | | | 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 | /* * Push the event on the head of the queue. */ evPtr->nextPtr = tsdPtr->firstEventPtr; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->lastEventPtr = evPtr; } tsdPtr->firstEventPtr = evPtr; } else if (position == TCL_QUEUE_MARK) { /* * Insert the event after the current marker event and advance the * marker to the new event. */ if (tsdPtr->markerEventPtr == NULL) { evPtr->nextPtr = tsdPtr->firstEventPtr; tsdPtr->firstEventPtr = evPtr; } else { evPtr->nextPtr = tsdPtr->markerEventPtr->nextPtr; |
︙ | ︙ | |||
495 496 497 498 499 500 501 | } /* *---------------------------------------------------------------------- * * Tcl_DeleteEvents -- * | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_DeleteEvents -- * * Calls a function for each event in the queue and deletes those for * which the function returns 1. Events for which the function returns 0 * are left in the queue. Operates on the queue associated with the * current thread. * * Results: * None. * * Side effects: * Potentially removes one or more events from the event queue. * *---------------------------------------------------------------------- */ void Tcl_DeleteEvents(proc, clientData) Tcl_EventDeleteProc *proc; /* The function to call. */ ClientData clientData; /* The type-specific data. */ { Tcl_Event *evPtr, *prevPtr, *hold; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_MutexLock(&(tsdPtr->queueMutex)); for (prevPtr = (Tcl_Event *) NULL, evPtr = tsdPtr->firstEventPtr; evPtr != (Tcl_Event *) NULL; /*EMPTY STEP*/) { if ((*proc) (evPtr, clientData) == 1) { if (tsdPtr->firstEventPtr == evPtr) { tsdPtr->firstEventPtr = evPtr->nextPtr; } else { prevPtr->nextPtr = evPtr->nextPtr; } if (evPtr->nextPtr == (Tcl_Event *) NULL) { tsdPtr->lastEventPtr = prevPtr; } if (tsdPtr->markerEventPtr == evPtr) { tsdPtr->markerEventPtr = prevPtr; } hold = evPtr; evPtr = evPtr->nextPtr; ckfree((char *) hold); } else { prevPtr = evPtr; evPtr = evPtr->nextPtr; } } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); } /* *---------------------------------------------------------------------- * * Tcl_ServiceEvent -- * * Process one event from the event queue, or invoke an asynchronous * event handler. Operates on event queue for current thread. * * Results: * The return value is 1 if the function actually found an event to * process. If no processing occurred, then 0 is returned. * * Side effects: * Invokes all of the event handlers for the highest priority event in * the event queue. May collapse some events into a single event or * discard stale events. * *---------------------------------------------------------------------- */ int Tcl_ServiceEvent(flags) int flags; /* Indicates what events should be processed. * May be any combination of TCL_WINDOW_EVENTS * TCL_FILE_EVENTS, TCL_TIMER_EVENTS, or other * flags defined elsewhere. Events not * matching this will be skipped for * processing later. */ { Tcl_Event *evPtr, *prevPtr; Tcl_EventProc *proc; int result; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Asynchronous event handlers are considered to be the highest priority * events, and so must be invoked before we process events on the event * queue. */ if (Tcl_AsyncReady()) { (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); return 1; } /* * No event flags is equivalent to TCL_ALL_EVENTS. */ if ((flags & TCL_ALL_EVENTS) == 0) { flags |= TCL_ALL_EVENTS; } /* * Loop through all the events in the queue until we find one that can * actually be handled. */ Tcl_MutexLock(&(tsdPtr->queueMutex)); for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; evPtr = evPtr->nextPtr) { /* * Call the handler for the event. If it actually handles the event * then free the storage for the event. There are two tricky things * here, both stemming from the fact that the event code may be * re-entered while servicing the event: * * 1. Set the "proc" field to NULL. This is a signal to ourselves * that we shouldn't reexecute the handler if the event loop is * re-entered. * 2. When freeing the event, must search the queue again from the * front to find it. This is because the event queue could change * almost arbitrarily while handling the event, so we can't depend * on pointers found now still being valid when the handler * returns. */ proc = evPtr->proc; if (proc == NULL) { continue; } evPtr->proc = NULL; /* * Release the lock before calling the event function. This allows * other threads to post events if we enter a recursive event loop in * this thread. Note that we are making the assumption that if the * proc returns 0, the event is still in the list. */ Tcl_MutexUnlock(&(tsdPtr->queueMutex)); result = (*proc)(evPtr, flags); Tcl_MutexLock(&(tsdPtr->queueMutex)); if (result) { |
︙ | ︙ | |||
654 655 656 657 658 659 660 | tsdPtr->lastEventPtr = NULL; } if (tsdPtr->markerEventPtr == evPtr) { tsdPtr->markerEventPtr = NULL; } } else { for (prevPtr = tsdPtr->firstEventPtr; | | | | 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 | tsdPtr->lastEventPtr = NULL; } if (tsdPtr->markerEventPtr == evPtr) { tsdPtr->markerEventPtr = NULL; } } else { for (prevPtr = tsdPtr->firstEventPtr; prevPtr && prevPtr->nextPtr != evPtr; prevPtr = prevPtr->nextPtr) { /* Empty loop body. */ } if (prevPtr) { prevPtr->nextPtr = evPtr->nextPtr; if (evPtr->nextPtr == NULL) { tsdPtr->lastEventPtr = prevPtr; } |
︙ | ︙ | |||
677 678 679 680 681 682 683 | if (evPtr) { ckfree((char *) evPtr); } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); return 1; } else { /* | | | | 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 | if (evPtr) { ckfree((char *) evPtr); } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); return 1; } else { /* * The event wasn't actually handled, so we have to restore the * proc field to allow the event to be attempted again. */ evPtr->proc = proc; } } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); return 0; |
︙ | ︙ | |||
723 724 725 726 727 728 729 | * * This routine sets the current service mode of the tsdPtr-> * * Results: * Returns the previous service mode. * * Side effects: | | | 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 | * * This routine sets the current service mode of the tsdPtr-> * * Results: * Returns the previous service mode. * * Side effects: * Invokes the notifier service mode hook function. * *---------------------------------------------------------------------- */ int Tcl_SetServiceMode(mode) int mode; /* New service mode: TCL_SERVICE_ALL or |
︙ | ︙ | |||
749 750 751 752 753 754 755 | } /* *---------------------------------------------------------------------- * * Tcl_SetMaxBlockTime -- * | | | | | | | | | | | | | | | | | | | | | | < | | | | | < | | | | | | | | | | | | | | | | | < | | | | | | | | < | | | | < | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_SetMaxBlockTime -- * * This function is invoked by event sources to tell the notifier how * long it may block the next time it blocks. The timePtr argument gives * a maximum time; the actual time may be less if some other event source * requested a smaller time. * * Results: * None. * * Side effects: * May reduce the length of the next sleep in the tsdPtr-> * *---------------------------------------------------------------------- */ void Tcl_SetMaxBlockTime(timePtr) Tcl_Time *timePtr; /* Specifies a maximum elapsed time for the * next blocking operation in the event * tsdPtr-> */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->blockTimeSet || (timePtr->sec < tsdPtr->blockTime.sec) || ((timePtr->sec == tsdPtr->blockTime.sec) && (timePtr->usec < tsdPtr->blockTime.usec))) { tsdPtr->blockTime = *timePtr; tsdPtr->blockTimeSet = 1; } /* * If we are called outside an event source traversal, set the timeout * immediately. */ if (!tsdPtr->inTraversal) { if (tsdPtr->blockTimeSet) { Tcl_SetTimer(&tsdPtr->blockTime); } else { Tcl_SetTimer(NULL); } } } /* *---------------------------------------------------------------------- * * Tcl_DoOneEvent -- * * Process a single event of some sort. If there's no work to do, wait * for an event to occur, then process it. * * Results: * The return value is 1 if the function actually found an event to * process. If no processing occurred, then 0 is returned (this can * happen if the TCL_DONT_WAIT flag is set or if there are no event * handlers to wait for in the set specified by flags). * * Side effects: * May delay execution of process while waiting for an event, unless * TCL_DONT_WAIT is set in the flags argument. Event sources are invoked * to check for and queue events. Event handlers may produce arbitrary * side effects. * *---------------------------------------------------------------------- */ int Tcl_DoOneEvent(flags) int flags; /* Miscellaneous flag values: may be any * combination of TCL_DONT_WAIT, * TCL_WINDOW_EVENTS, TCL_FILE_EVENTS, * TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, or * others defined by event sources. */ { int result = 0, oldMode; EventSource *sourcePtr; Tcl_Time *timePtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * The first thing we do is to service any asynchronous event handlers. */ if (Tcl_AsyncReady()) { (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); return 1; } /* * No event flags is equivalent to TCL_ALL_EVENTS. */ if ((flags & TCL_ALL_EVENTS) == 0) { flags |= TCL_ALL_EVENTS; } /* * Set the service mode to none so notifier event routines won't try to * service events recursively. */ oldMode = tsdPtr->serviceMode; tsdPtr->serviceMode = TCL_SERVICE_NONE; /* * The core of this function is an infinite loop, even though we only * service one event. The reason for this is that we may be processing * events that don't do anything inside of Tcl. */ while (1) { /* * If idle events are the only things to service, skip the main part * of the loop and go directly to handle idle events (i.e. don't wait * even if TCL_DONT_WAIT isn't set). */ if ((flags & TCL_ALL_EVENTS) == TCL_IDLE_EVENTS) { flags = TCL_IDLE_EVENTS | TCL_DONT_WAIT; goto idleEvents; } /* * Ask Tcl to service a queued event, if there are any. */ if (Tcl_ServiceEvent(flags)) { result = 1; break; } /* * If TCL_DONT_WAIT is set, be sure to poll rather than blocking, * otherwise reset the block time to infinity. */ if (flags & TCL_DONT_WAIT) { tsdPtr->blockTime.sec = 0; tsdPtr->blockTime.usec = 0; tsdPtr->blockTimeSet = 1; } else { tsdPtr->blockTimeSet = 0; } /* * Set up all the event sources for new events. This will cause the * block time to be updated if necessary. */ tsdPtr->inTraversal = 1; for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->setupProc) { (sourcePtr->setupProc)(sourcePtr->clientData, flags); } } tsdPtr->inTraversal = 0; if ((flags & TCL_DONT_WAIT) || tsdPtr->blockTimeSet) { timePtr = &tsdPtr->blockTime; } else { timePtr = NULL; } /* * Wait for a new event or a timeout. If Tcl_WaitForEvent returns -1, * we should abort Tcl_DoOneEvent. */ result = Tcl_WaitForEvent(timePtr); if (result < 0) { result = 0; break; } /* * Check all the event sources for new events. */ for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->checkProc) { (sourcePtr->checkProc)(sourcePtr->clientData, flags); } } /* * Check for events queued by the notifier or event sources. */ if (Tcl_ServiceEvent(flags)) { result = 1; break; } /* * We've tried everything at this point, but nobody we know about had * anything to do. Check for idle events. If none, either quit or go * back to the top and try again. */ idleEvents: if (flags & TCL_IDLE_EVENTS) { if (TclServiceIdle()) { result = 1; break; } } if (flags & TCL_DONT_WAIT) { break; } /* * If Tcl_WaitForEvent has returned 1, indicating that one system * event has been dispatched (and thus that some Tcl code might have * been indirectly executed), we break out of the loop. We do this to * give VwaitCmd for instance a chance to check if that system event * had the side effect of changing the variable (so the vwait can * return and unwind properly). * * NB: We will process idle events if any first, because otherwise we * might never do the idle events if the notifier always gets * system events. */ if (result) { break; } } tsdPtr->serviceMode = oldMode; return result; } /* *---------------------------------------------------------------------- * * Tcl_ServiceAll -- * * This routine checks all of the event sources, processes events that * are on the Tcl event queue, and then calls the any idle handlers. * Platform specific notifier callbacks that generate events should call * this routine before returning to the system in order to ensure that * Tcl gets a chance to process the new events. * * Results: * Returns 1 if an event or idle handler was invoked, else 0. * * Side effects: * Anything that an event or idle handler may do. * |
︙ | ︙ | |||
1020 1021 1022 1023 1024 1025 1026 | ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->serviceMode == TCL_SERVICE_NONE) { return result; } /* | | | | | | | | | | 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 | ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->serviceMode == TCL_SERVICE_NONE) { return result; } /* * We need to turn off event servicing like we to in Tcl_DoOneEvent, to * avoid recursive calls. */ tsdPtr->serviceMode = TCL_SERVICE_NONE; /* * Check async handlers first. */ if (Tcl_AsyncReady()) { (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); } /* * Make a single pass through all event sources, queued events, and idle * handlers. Note that we wait to update the notifier timer until the end * so we can avoid multiple changes. */ tsdPtr->inTraversal = 1; tsdPtr->blockTimeSet = 0; for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->setupProc) { (sourcePtr->setupProc)(sourcePtr->clientData, TCL_ALL_EVENTS); } } for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->checkProc) { (sourcePtr->checkProc)(sourcePtr->clientData, TCL_ALL_EVENTS); } } while (Tcl_ServiceEvent(0)) { result = 1; |
︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 | } /* *---------------------------------------------------------------------- * * Tcl_ThreadAlert -- * | | | | | < | > > > > > > > > | 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 | } /* *---------------------------------------------------------------------- * * Tcl_ThreadAlert -- * * This function wakes up the notifier associated with the specified * thread (if there is one). * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_ThreadAlert(threadId) Tcl_ThreadId threadId; /* Identifier for thread to use. */ { ThreadSpecificData *tsdPtr; /* * Find the notifier associated with the specified thread. Note that we * need to hold the listLock while calling Tcl_AlertNotifier to avoid a * race condition where the specified thread might destroy its notifier. */ Tcl_MutexLock(&listLock); for (tsdPtr = firstNotifierPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { if (tsdPtr->threadId == threadId) { if (tclStubs.tcl_AlertNotifier) { tclStubs.tcl_AlertNotifier(tsdPtr->clientData); } break; } } Tcl_MutexUnlock(&listLock); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclObj.c.
1 2 3 | /* * tclObj.c -- * | | | > | | | | > > > | | | | | | | > | < > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > < > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > < < > | > > > > > > > > > > > > > | | > > > > > > > > > | > > < < < < < | > > > > > > > | < | < | > > > > > | | | > > > > | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | < < < < < < < | | | < | | | > > > > > > < < < | | | | | | | | < < < < < < < < < | < < < < | < < < | | | | < | | | | | | | > | | > > > > > > > > | < | | < < < < | | < | < < | | | | | | | | | | | > > | | | > | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 | /* * 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. * Copyright (c) 2005 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: tclObj.c,v 1.72.2.42 2005/10/08 06:07:58 dgp Exp $ */ #include "tclInt.h" #include "tommath.h" #include <float.h> #define BIGNUM_AUTO_NARROW 1 /* * Table of all object types. */ static Tcl_HashTable typeTable; static int typeTableInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(tableMutex) /* * Head of the list of free Tcl_Obj structs we maintain. */ Tcl_Obj *tclFreeObjList = NULL; /* * The object allocator is single threaded. This mutex is referenced by the * TclNewObj macro, however, so must be visible. */ #ifdef TCL_THREADS Tcl_Mutex tclObjMutex; #endif /* * Pointer to a heap-allocated string of length zero that the Tcl core uses as * the value of an empty string representation for an object. This value is * shared by all new objects allocated by Tcl_NewObj. */ char tclEmptyString = '\0'; char *tclEmptyStringRep = &tclEmptyString; #if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) /* * Thread local table that is used to check that a Tcl_Obj was not allocated * by some other thread. */ typedef struct ThreadSpecificData { Tcl_HashTable *objThreadMap; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #endif /* TCL_MEM_DEBUG && TCL_THREADS */ /* * Nested Tcl_Obj deletion management support * * All context references used in the object freeing code are pointers to this * structure; every thread will have its own structure instance. The purpose * of this structure is to allow deeply nested collections of Tcl_Objs to be * freed without taking a vast depth of C stack (which could cause all sorts * of breakage.) */ typedef struct PendingObjData { int deletionCount; /* Count of the number of invokations of * TclFreeObj() are on the stack (at least * conceptually; many are actually expanded * macros). */ Tcl_Obj *deletionStack; /* Stack of objects that have had TclFreeObj() * invoked upon them but which can't be * deleted yet because they are in a nested * invokation of TclFreeObj(). By postponing * this way, we limit the maximum overall C * stack depth when deleting a complex object. * The down-side is that we alter the overall * behaviour by altering the order in which * objects are deleted, and we change the * order in which the string rep and the * internal rep of an object are deleted. Note * that code which assumes the previous * behaviour in either of these respects is * unsafe anyway; it was never documented as * to exactly what would happen in these * cases, and the overall contract of a * user-level Tcl_DecrRefCount() is still * preserved (assuming that a particular T_DRC * would delete an object is not very * safe). */ } PendingObjData; /* * These are separated out so that some semantic content is attached * to them. */ #define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++) #define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) #define PushObjToDelete(contextPtr,objPtr) \ /* Invalidate the string rep first so we can use the bytes value \ * for our pointer chain. */ \ if (((objPtr)->bytes != NULL) \ && ((objPtr)->bytes != tclEmptyStringRep)) { \ ckfree((char *) (objPtr)->bytes); \ } \ /* Now push onto the head of the stack. */ \ (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ (contextPtr)->deletionStack = (objPtr) #define PopObjToDelete(contextPtr,objPtrVar) \ (objPtrVar) = (contextPtr)->deletionStack; \ (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes /* * Macro to set up the local reference to the deletion context. */ #ifndef TCL_THREADS static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *CONST contextPtr = &pendingObjData #else static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *CONST contextPtr = (PendingObjData *) \ Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif /* * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep */ #define PACK_BIGNUM(bignum, objPtr) \ if ((bignum).used > 0x7fff) { \ mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \ *temp = bignum; \ (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) temp; \ (objPtr)->internalRep.ptrAndLongRep.value = -1; \ } else { \ if ((bignum).alloc > 0x7fff) { \ mp_shrink(&(bignum)); \ } \ (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) (bignum).dp; \ (objPtr)->internalRep.ptrAndLongRep.value = ( ((bignum).sign << 30) \ | ((bignum).alloc << 15) | ((bignum).used)); \ } #define UNPACK_BIGNUM(objPtr, bignum) \ if ((objPtr)->internalRep.ptrAndLongRep.value == -1) { \ (bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \ } else { \ (bignum).dp = (mp_digit*) (objPtr)->internalRep.ptrAndLongRep.ptr; \ (bignum).sign = (objPtr)->internalRep.ptrAndLongRep.value >> 30; \ (bignum).alloc = \ ((objPtr)->internalRep.ptrAndLongRep.value >> 15) & 0x7fff; \ (bignum).used = (objPtr)->internalRep.ptrAndLongRep.value & 0x7fff; \ } /* * Prototypes for procedures defined later in this file: */ static int ParseBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); #ifndef NO_WIDE_TYPE static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr)); #endif static void FreeBignum _ANSI_ARGS_((Tcl_Obj *objPtr)); static void DupBignum _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); static void UpdateStringOfBignum _ANSI_ARGS_((Tcl_Obj *objPtr)); static int GetBignumFromObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int copy, mp_int *bignumValue)); /* * Prototypes for the array hash key methods. */ static Tcl_HashEntry * AllocObjEntry _ANSI_ARGS_(( Tcl_HashTable *tablePtr, VOID *keyPtr)); static int CompareObjKeys _ANSI_ARGS_(( VOID *keyPtr, Tcl_HashEntry *hPtr)); static void FreeObjEntry _ANSI_ARGS_(( Tcl_HashEntry *hPtr)); static unsigned int HashObjKey _ANSI_ARGS_(( Tcl_HashTable *tablePtr, VOID *keyPtr)); /* * Prototypes for the CommandName object type. */ static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); static void FreeCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* * The structures below defines the Tcl object types defined in this file by * means of procedures that can be invoked by generic object code. See also * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager * implementations. */ Tcl_ObjType tclBooleanType = { "boolean", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ SetBooleanFromAny /* setFromAnyProc */ }; Tcl_ObjType tclDoubleType = { "double", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ SetDoubleFromAny /* setFromAnyProc */ }; Tcl_ObjType tclIntType = { "int", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; #ifndef NO_WIDE_TYPE Tcl_ObjType tclWideIntType = { "wideInt", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ UpdateStringOfWideInt, /* updateStringProc */ NULL /* setFromAnyProc */ }; #endif Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ DupBignum, /* dupIntRepProc */ UpdateStringOfBignum, /* updateStringProc */ NULL /* setFromAnyProc */ }; /* * The structure below defines the Tcl obj hash key type. */ Tcl_HashKeyType tclObjHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ 0, /* flags */ HashObjKey, /* hashKeyProc */ CompareObjKeys, /* compareKeysProc */ AllocObjEntry, /* allocEntryProc */ FreeObjEntry /* freeEntryProc */ }; /* * The structure below defines the command name Tcl object type by means of * procedures that can be invoked by generic object code. Objects of this type * cache the Command pointer that results from looking up command names in the * command hashtable. Such objects appear as the zeroth ("command name") * argument in a Tcl command. * * NOTE: the ResolvedCmdName that gets cached is stored in the * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused. You might * think you could use the simpler otherValuePtr field to store the single * ResolvedCmdName pointer, but DO NOT DO THIS. It seems that some extensions * use the second internal pointer field of the twoPtrValue field for their * own purposes. */ static Tcl_ObjType tclCmdNameType = { "cmdName", /* name */ FreeCmdNameInternalRep, /* freeIntRepProc */ DupCmdNameInternalRep, /* dupIntRepProc */ (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ SetCmdNameFromAny /* setFromAnyProc */ }; /* * Structure containing a cached pointer to a command that is the result of * resolving the command's name in some namespace. It is the internal * representation for a cmdName object. It contains the pointer along with * some information that is used to check the pointer's validity. */ typedef struct ResolvedCmdName { Command *cmdPtr; /* A cached Command pointer. */ Namespace *refNsPtr; /* Points to the namespace containing the * reference (not the namespace that contains * the referenced command). */ long refNsId; /* refNsPtr's unique namespace id. Used to * verify that refNsPtr is still valid (e.g., * it's possible that the cmd's containing * namespace was deleted and a new one created * at the same address). */ int refNsCmdEpoch; /* Value of the referencing namespace's * cmdRefEpoch when the pointer was cached. * Before using the cached pointer, we check * if the namespace's epoch was incremented; * if so, this cached pointer is invalid. */ int cmdEpoch; /* Value of the command's cmdEpoch when this * pointer was cached. Before using the cached * pointer, we check if the cmd's epoch was * incremented; if so, the cmd was renamed, * deleted, hidden, or exposed, and so the * pointer is invalid. */ int refCount; /* Reference count: 1 for each cmdName object * that has a pointer to this ResolvedCmdName * structure as its internal rep. This * structure can be freed when refCount * becomes zero. */ } ResolvedCmdName; /* *------------------------------------------------------------------------- * * TclInitObjectSubsystem -- * * This procedure is invoked to perform once-only initialization of the * type table. It also registers the object types defined in this file. * * Results: * None. * * Side effects: * Initializes the table of defined object types "typeTable" with builtin * object types defined in this file. * *------------------------------------------------------------------------- */ void TclInitObjSubsystem() { Tcl_MutexLock(&tableMutex); typeTableInitialized = 1; Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); Tcl_RegisterObjType(&tclArraySearchType); Tcl_RegisterObjType(&tclNsNameType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; tclObjsFreed = 0; { int i; for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) { tclObjsShared[i] = 0; } } Tcl_MutexUnlock(&tclObjMutex); #endif } /* *---------------------------------------------------------------------- * * TclFinalizeObjects -- * * This procedure is called by Tcl_Finalize to clean up all * registered Tcl_ObjType's and to reset the tclFreeObjList. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TclFinalizeObjects() { Tcl_MutexLock(&tableMutex); if (typeTableInitialized) { Tcl_DeleteHashTable(&typeTable); typeTableInitialized = 0; } Tcl_MutexUnlock(&tableMutex); /* * All we do here is reset the head pointer of the linked list of * free Tcl_Obj's to NULL; the memory finalization will take care * of releasing memory for us. */ Tcl_MutexLock(&tclObjMutex); tclFreeObjList = NULL; Tcl_MutexUnlock(&tclObjMutex); } /* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- * * This procedure is called to register a new Tcl object type in the * table of all object types supported by Tcl. * * Results: * None. * * Side effects: * The type is registered in the Tcl type table. If there was already a * type with the same name as in typePtr, it is replaced with the new * type. * *-------------------------------------------------------------- */ void Tcl_RegisterObjType(typePtr) Tcl_ObjType *typePtr; /* Information about object type; storage must * be statically allocated (must live * forever). */ { int new; Tcl_MutexLock(&tableMutex); Tcl_SetHashValue( Tcl_CreateHashEntry(&typeTable, typePtr->name, &new), typePtr); Tcl_MutexUnlock(&tableMutex); } /* *---------------------------------------------------------------------- * * Tcl_AppendAllObjTypes -- * * This procedure appends onto the argument object the name of each * object type as a list element. This includes the builtin object types * (e.g. int, list) as well as those added using Tcl_NewObj. These names * can be used, for example, with Tcl_GetObjType to get pointers to the * corresponding Tcl_ObjType structures. * * Results: * The return value is normally TCL_OK; in this case the object * referenced by objPtr has each type name appended to it. If an error * occurs, TCL_ERROR is returned and the interpreter's result holds an * error message. * * Side effects: * If necessary, the object referenced by objPtr is converted into a list * object. * *---------------------------------------------------------------------- */ int Tcl_AppendAllObjTypes(interp, objPtr) Tcl_Interp *interp; /* Interpreter used for error reporting. */ Tcl_Obj *objPtr; /* Points to the Tcl object onto which the * name of each registered type is appended as * a list element. */ { register Tcl_HashEntry *hPtr; Tcl_HashSearch search; int objc; Tcl_Obj **objv; /* * Get the test for a valid list out of the way first. */ if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { return TCL_ERROR; } /* * Type names are NUL-terminated, not counted strings. * This code relies on that. */ Tcl_MutexLock(&tableMutex); for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1)); } Tcl_MutexUnlock(&tableMutex); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetObjType -- * * This procedure looks up an object type by name. * * Results: * If an object type with name matching "typeName" is found, a pointer to * its Tcl_ObjType structure is returned; otherwise, NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_ObjType * Tcl_GetObjType(typeName) CONST char *typeName; /* Name of Tcl object type to look up. */ { register Tcl_HashEntry *hPtr; Tcl_ObjType *typePtr = NULL; Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typeName); if (hPtr != (Tcl_HashEntry *) NULL) { typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); return typePtr; } /* *---------------------------------------------------------------------- * * Tcl_ConvertToType -- * * Convert the Tcl object "objPtr" to have type "typePtr" if possible. * * Results: * The return value is TCL_OK on success and TCL_ERROR on failure. If * TCL_ERROR is returned, then the interpreter's result contains an error * message unless "interp" is NULL. Passing a NULL "interp" allows this * procedure to be used as a test whether the conversion could be done * (and in fact was done). * * Side effects: * Any internal representation for the old type is freed. * *---------------------------------------------------------------------- */ int Tcl_ConvertToType(interp, objPtr, typePtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr; /* The object to convert. */ Tcl_ObjType *typePtr; /* The target type. */ { if (objPtr->typePtr == typePtr) { return TCL_OK; } /* * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal form * as appropriate for the target type. This frees the old internal * representation. */ if (typePtr->setFromAnyProc == NULL) { Tcl_Panic("may not convert object to type %s", typePtr->name); } return typePtr->setFromAnyProc(interp, objPtr); } /* *---------------------------------------------------------------------- * * TclDbInitNewObj -- * * Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG is * enabled. This function will initialize the members of a Tcl_Obj * struct. Initilization would be done inline via the TclNewObj macro * when compiling without TCL_MEM_DEBUG. * * Results: * The Tcl_Obj struct members are initialized. * * Side effects: * None. *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void TclDbInitNewObj(objPtr) register Tcl_Obj *objPtr; { objPtr->refCount = 0; objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; objPtr->typePtr = NULL; #ifdef TCL_THREADS /* * Add entry to a thread local map used to check if a Tcl_Obj was * allocated by the currently executing thread. */ if (!TclInExit()) { Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; int new; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->objThreadMap == NULL) { tsdPtr->objThreadMap = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); } tablePtr = tsdPtr->objThreadMap; hPtr = Tcl_CreateHashEntry(tablePtr, (char *) objPtr, &new); if (!new) { Tcl_Panic("expected to create new entry for object map"); } Tcl_SetHashValue(hPtr, NULL); } #endif /* TCL_THREADS */ } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_NewObj -- * * This procedure is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote * the empty string. These objects have a NULL object type and NULL * string representation byte pointer. Type managers call this routine to * allocate new objects that they further initialize. * * When TCL_MEM_DEBUG is defined, this procedure just returns the result * of calling the debugging version Tcl_DbNewObj. * * Results: * The result is a newly allocated object that represents the empty * string. The new object's typePtr is set NULL and its ref count is set * to 0. * * Side effects: * If compiling with TCL_COMPILE_STATS, this procedure increments the * global count of allocated objects (tclObjsAlloced). * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewObj |
︙ | ︙ | |||
617 618 619 620 621 622 623 | Tcl_Obj * Tcl_NewObj() { register Tcl_Obj *objPtr; /* | | < | | | | | | | | | | | < | | | | | 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 | 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 */ /* *---------------------------------------------------------------------- * * Tcl_DbNewObj -- * * This procedure is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the * empty string. It is the same as the Tcl_NewObj procedure above except * that it calls Tcl_DbCkalloc directly with the file name and line * number from its caller. This simplifies debugging since then the * [memory active] command will report the correct file name and line * number when reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewObj. * * Results: * The result is a newly allocated that represents the empty string. The * new object's typePtr is set NULL and its ref count is set to 0. * * Side effects: * If compiling with TCL_COMPILE_STATS, this procedure increments the * global count of allocated objects (tclObjsAlloced). * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewObj(file, line) register CONST char *file; /* The name of the source file calling this * 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 for * debugging. */ { return Tcl_NewObj(); } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * TclAllocateFreeObjects -- * * Procedure to allocate a number of free Tcl_Objs. This is done using a * single ckalloc to reduce the overhead for Tcl_Obj allocation. * * Assumes mutex is held. * * Results: * None. * * Side effects: |
︙ | ︙ | |||
719 720 721 722 723 724 725 | char *basePtr; register Tcl_Obj *prevPtr, *objPtr; register int i; /* * This has been noted by Purify to be a potential leak. The problem is * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated | | | > > | 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 | char *basePtr; register Tcl_Obj *prevPtr, *objPtr; register int i; /* * This has been noted by Purify to be a potential leak. The problem is * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually * freeing the memory. TclFinalizeObjects() does not ckfree() this memory, * but leaves it to Tcl's memory subsystem finalization to release it. * Purify apparently can't figure that out, and fires a false alarm. */ basePtr = (char *) ckalloc(bytesToAlloc); memset(basePtr, 0, bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; |
︙ | ︙ | |||
742 743 744 745 746 747 748 | #undef OBJS_TO_ALLOC_EACH_TIME /* *---------------------------------------------------------------------- * * TclFreeObj -- * | | | | | | | | | | | < > > | | | | | | | | | | > > > > > > > > > > > > > > > > | > | | | > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > | | | | | | | | | | | | | 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 | #undef OBJS_TO_ALLOC_EACH_TIME /* *---------------------------------------------------------------------- * * TclFreeObj -- * * This procedure frees the memory associated with the argument object. * It is called by the tcl.h macro Tcl_DecrRefCount when an object's ref * count is zero. It is only "public" since it must be callable by that * macro wherever the macro is used. It should not be directly called by * clients. * * Results: * None. * * Side effects: * Deallocates the storage for the object's Tcl_Obj structure after * deallocating the string representation and calling the type-specific * Tcl_FreeInternalRepProc to deallocate the object's internal * representation. If compiling with TCL_COMPILE_STATS, this procedure * increments the global count of freed objects (tclObjsFreed). * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void TclFreeObj(objPtr) register Tcl_Obj *objPtr; /* The object to be freed. */ { register Tcl_ObjType *typePtr = objPtr->typePtr; /* * This macro declares a variable, so must come here... */ ObjInitDeletionContext(context); if (objPtr->refCount < -1) { Tcl_Panic("Reference count for %lx was negative", objPtr); } if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); } else { if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { ObjDeletionLock(context); typePtr->freeIntRepProc(objPtr); ObjDeletionUnlock(context); } TclInvalidateStringRep(objPtr); Tcl_MutexLock(&tclObjMutex); ckfree((char *) objPtr); Tcl_MutexUnlock(&tclObjMutex); #ifdef TCL_COMPILE_STATS tclObjsFreed++; #endif /* TCL_COMPILE_STATS */ ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; PopObjToDelete(context,objToFree); TclFreeIntRep(objToFree); Tcl_MutexLock(&tclObjMutex); ckfree((char *) objToFree); Tcl_MutexUnlock(&tclObjMutex); #ifdef TCL_COMPILE_STATS tclObjsFreed++; #endif /* TCL_COMPILE_STATS */ } ObjDeletionUnlock(context); } } #else /* TCL_MEM_DEBUG */ void TclFreeObj(objPtr) register Tcl_Obj *objPtr; /* The object to be freed. */ { if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) { /* * objPtr can be freed safely, as it will not attempt to free any * other objects: it will not cause recursive calls to this function. */ if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) { ckfree((char *) objPtr->bytes); } TclFreeObjStorage(objPtr); TclIncrObjsFreed(); } else { /* * This macro declares a variable, so must come here... */ ObjInitDeletionContext(context); if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); } else { /* * Note that the contents of the while loop assume that the string * rep has already been freed and we don't want to do anything * fancy with adding to the queue inside ourselves. Must take care * to unstack the object first since freeing the internal rep can * add further objects to the stack. The code assumes that it is * the first thing in a block; all current usages in the core * satisfy this. */ ObjDeletionLock(context); objPtr->typePtr->freeIntRepProc(objPtr); ObjDeletionUnlock(context); if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) { ckfree((char *) objPtr->bytes); } TclFreeObjStorage(objPtr); TclIncrObjsFreed(); ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; PopObjToDelete(context,objToFree); if ((objToFree->typePtr != NULL) && (objToFree->typePtr->freeIntRepProc != NULL)) { objToFree->typePtr->freeIntRepProc(objToFree); } TclFreeObjStorage(objToFree); TclIncrObjsFreed(); } ObjDeletionUnlock(context); } } } #endif /* *---------------------------------------------------------------------- * * Tcl_DuplicateObj -- * * Create and return a new object that is a duplicate of the argument * object. * * Results: * The return value is a pointer to a newly created Tcl_Obj. This object * has reference count 0 and the same type, if any, as the source object * objPtr. Also: * 1) If the source object has a valid string rep, we copy it; * otherwise, the duplicate's string rep is set NULL to mark it * invalid. * 2) If the source object has an internal representation (i.e. its * typePtr is non-NULL), the new object's internal rep is set to a * copy; otherwise the new internal rep is marked invalid. * * Side effects: * What constitutes "copying" the internal representation depends on the * type. For example, if the argument object is a list, the element * objects it points to will not actually be copied but will be shared * with the duplicate list. That is, the ref counts of the element * objects will be incremented. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_DuplicateObj(objPtr) register Tcl_Obj *objPtr; /* The object to duplicate. */ |
︙ | ︙ | |||
903 904 905 906 907 908 909 | * representation from the internal representation. * *---------------------------------------------------------------------- */ char * Tcl_GetString(objPtr) | | | | | | | | | | | | 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 | * representation from the internal representation. * *---------------------------------------------------------------------- */ char * Tcl_GetString(objPtr) register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should * be returned. */ { if (objPtr->bytes != NULL) { return objPtr->bytes; } if (objPtr->typePtr->updateStringProc == NULL) { Tcl_Panic("UpdateStringProc should not be invoked for type %s", objPtr->typePtr->name); } (*objPtr->typePtr->updateStringProc)(objPtr); return objPtr->bytes; } /* *---------------------------------------------------------------------- * * Tcl_GetStringFromObj -- * * Returns the string representation's byte array pointer and length for * an object. * * Results: * Returns a pointer to the string representation of objPtr. If lengthPtr * isn't NULL, the length of the string representation is stored at * *lengthPtr. The byte array referenced by the returned pointer must not * be modified by the caller. Furthermore, the caller must copy the bytes * if they need to retain them since the object's string rep can change * as a result of other operations. * * Side effects: * May call the object's updateStringProc to update the string * representation from the internal representation. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
975 976 977 978 979 980 981 | * This procedure is called to invalidate an object's string * representation. * * Results: * None. * * Side effects: | | | | | < | < | < | < | | | | | | | | 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 | * This procedure is called to invalidate an object's string * representation. * * Results: * None. * * Side effects: * Deallocates the storage for any old string representation, then sets * the string representation NULL to mark it invalid. * *---------------------------------------------------------------------- */ void Tcl_InvalidateStringRep(objPtr) register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should * be freed. */ { TclInvalidateStringRep(objPtr); } /* *---------------------------------------------------------------------- * * Tcl_NewBooleanObj -- * * This procedure is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and * initializes it from the argument boolean value. A nonzero "boolValue" * is coerced to 1. * * When TCL_MEM_DEBUG is defined, this procedure just returns the result * of calling the debugging version Tcl_DbNewBooleanObj. * * Results: * The newly created object is returned. This object will have an invalid * string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 | Tcl_Obj * Tcl_NewBooleanObj(boolValue) register int boolValue; /* Boolean used to initialize new object. */ { register Tcl_Obj *objPtr; | | < < < < | | | | | | | | | | | < < < | | < < | > > > | | | > | > > > > > > > > > | | > | > > | > > > > > > | > > > | > | > > > > | | | < < < < < < | > > | > > > > | < < < < > | > | < | > > > > > > > > > | > > > | > > > > | > > | > > > > > > > > | > | > > > > | > > > | < < < | > | > > | < < > > > > > | < < > > | < < < < < < < < < < < < < < | | | < | > > > > > > > > > > > > | | > > > > | | < | | < | | < | | | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < | | < < < < < < < < < < < < < < < < | | | | < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < | < | < > | | | 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 | Tcl_Obj * Tcl_NewBooleanObj(boolValue) register int boolValue; /* Boolean used to initialize new object. */ { register Tcl_Obj *objPtr; TclNewBooleanObj(objPtr, boolValue); return objPtr; } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_DbNewBooleanObj -- * * This procedure is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the * same as the Tcl_NewBooleanObj procedure above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] * command will report the correct file name and line number when * reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewBooleanObj. * * Results: * The newly created object is returned. This object will have an invalid * string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewBooleanObj(boolValue, file, line) register int boolValue; /* Boolean used to initialize new object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; objPtr->internalRep.longValue = (boolValue? 1 : 0); objPtr->typePtr = &tclIntType; return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewBooleanObj(boolValue, file, line) register int boolValue; /* Boolean used to initialize new object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ { return Tcl_NewBooleanObj(boolValue); } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetBooleanObj -- * * Modify an object to be a boolean object and to have the specified * boolean value. A nonzero "boolValue" is coerced to 1. * * Results: * None. * * Side effects: * The object's old string rep, if any, is freed. Also, any old internal * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetBooleanObj(objPtr, boolValue) register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ register int boolValue; /* Boolean used to set object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetBooleanObj called with shared object"); } TclSetBooleanObj(objPtr, boolValue); } /* *---------------------------------------------------------------------- * * Tcl_GetBooleanFromObj -- * * Attempt to return a boolean from the Tcl object "objPtr". This * includes conversion from any of Tcl's numeric types. * * Results: * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * The intrep of *objPtr may be changed. * *---------------------------------------------------------------------- */ int 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. */ { do { if (objPtr->typePtr == &tclIntType) { *boolPtr = (objPtr->internalRep.longValue != 0); return TCL_OK; } if (objPtr->typePtr == &tclBooleanType) { *boolPtr = (int) objPtr->internalRep.longValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { /* * Caution: Don't be tempted to check directly for the "double" * Tcl_ObjType and then compare the intrep to 0.0. This isn't * reliable because a "double" Tcl_ObjType can hold the NaN value. * Use the API Tcl_GetDoubleFromObj, which does the checking and * sets the proper error message for us. */ double d; if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) { return TCL_ERROR; } *boolPtr = (d != 0.0); return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { #ifdef BIGNUM_AUTO_NARROW *boolPtr = 1; #else *boolPtr = ((objPtr->internalRep.ptrAndLongRep.value & 0x7fff)!=0); #endif return TCL_OK; } #ifndef NO_WIDE_TYPE if (objPtr->typePtr == &tclWideIntType) { *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; } #endif } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, "boolean value", NULL, -1, NULL, 0))); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * SetBooleanFromAny -- * * Attempt to generate a boolean internal form for the Tcl object * "objPtr". * * Results: * The return value is a standard Tcl result. If an error occurs during * conversion, an error message is left in the interpreter's result * unless "interp" is NULL. * * Side effects: * If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal * representation and the type of "objPtr" is set to boolean. * *---------------------------------------------------------------------- */ static int SetBooleanFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { /* * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine * whether a boolean conversion is possible without generating the string * rep. */ if (objPtr->bytes == NULL) { if (objPtr->typePtr == &tclIntType) { switch (objPtr->internalRep.longValue) { case 0L: case 1L: return TCL_OK; } goto badBoolean; } #ifdef BIGNUM_AUTO_NARROW if (objPtr->typePtr == &tclBignumType) { goto badBoolean; } #else /* TODO: Consider tests to discover values 0 and 1 while preserving * pure bignum. For now, pass through string rep. */ #endif #ifndef NO_WIDE_TYPE /* TODO: Consider tests to discover values 0 and 1 while preserving * pure wide. For now, pass through string rep. */ #endif if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } } if (ParseBoolean(objPtr) == TCL_OK) { return TCL_OK; } badBoolean: if (interp != NULL) { int length; char *str = Tcl_GetStringFromObj(objPtr, &length); Tcl_Obj *msg = Tcl_NewStringObj("expected boolean value but got \"", -1); TclAppendLimitedToObj(msg, str, length, 50, ""); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); } return TCL_ERROR; } static int ParseBoolean(objPtr) register Tcl_Obj *objPtr; /* The object to parse/convert. */ { int i, length, newBool; char lowerCase[6], *str = Tcl_GetStringFromObj(objPtr, &length); if ((length == 0) || (length > 5)) { /* longest valid boolean string rep. is "false" */ return TCL_ERROR; } switch (str[0]) { case '0': if (length == 1) { newBool = 0; goto numericBoolean; } return TCL_ERROR; case '1': if (length == 1) { newBool = 1; goto numericBoolean; } return TCL_ERROR; } /* * Force to lower case for case-insensitive detection. Filter out known * invalid characters at the same time. */ for (i=0; i < length; i++) { char c = str[i]; switch (c) { case 'A': case 'E': case 'F': case 'L': case 'N': case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y': lowerCase[i] = c + (char) ('a' - 'A'); break; case 'a': case 'e': case 'f': case 'l': case 'n': case 'o': case 'r': case 's': case 't': case 'u': case 'y': lowerCase[i] = c; break; default: return TCL_ERROR; } } lowerCase[length] = 0; switch (lowerCase[0]) { case 'y': /* * Checking the 'y' is redundant, but makes the code clearer. */ if (strncmp(lowerCase, "yes", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'n': if (strncmp(lowerCase, "no", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; case 't': if (strncmp(lowerCase, "true", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'f': if (strncmp(lowerCase, "false", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; case 'o': if (length < 2) { return TCL_ERROR; } if (strncmp(lowerCase, "on", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; default: return TCL_ERROR; } /* * 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. */ goodBoolean: TclFreeIntRep(objPtr); objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; numericBoolean: TclFreeIntRep(objPtr); objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_NewDoubleObj -- * * This procedure is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new double object and * initializes it from the argument double value. * * When TCL_MEM_DEBUG is defined, this procedure just returns the result * of calling the debugging version Tcl_DbNewDoubleObj. * * Results: * The newly created object is returned. This object will have an * invalid string representation. The returned object has ref count 0. * * Side effects: * None. |
︙ | ︙ | |||
1490 1491 1492 1493 1494 1495 1496 | Tcl_Obj * Tcl_NewDoubleObj(dblValue) register double dblValue; /* Double used to initialize the object. */ { register Tcl_Obj *objPtr; | | < < < < | | | | | | | | | | < < < | | < | | < | | | > > > > > > > | > | | | | > > > > > | > | < | > | > > | | 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 | Tcl_Obj * Tcl_NewDoubleObj(dblValue) register double dblValue; /* Double used to initialize the object. */ { register Tcl_Obj *objPtr; TclNewDoubleObj(objPtr, dblValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_DbNewDoubleObj -- * * This procedure is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new double objects. It is the * same as the Tcl_NewDoubleObj procedure above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] * command will report the correct file name and line number when * reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewDoubleObj. * * Results: * The newly created object is returned. This object will have an invalid * string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewDoubleObj(dblValue, file, line) register double dblValue; /* Double used to initialize the object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; objPtr->typePtr = &tclDoubleType; return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewDoubleObj(dblValue, file, line) register double dblValue; /* Double used to initialize the object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ { return Tcl_NewDoubleObj(dblValue); } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetDoubleObj -- * * Modify an object to be a double object and to have the specified * double value. * * Results: * None. * * Side effects: * The object's old string rep, if any, is freed. Also, any old internal * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetDoubleObj(objPtr, dblValue) register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ register double dblValue; /* Double used to set the object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetDoubleObj called with shared object"); } TclSetDoubleObj(objPtr, dblValue); } /* *---------------------------------------------------------------------- * * Tcl_GetDoubleFromObj -- * * Attempt to return a double from the Tcl object "objPtr". If the object * is not already a double, an attempt will be made to convert it to one. * * Results: * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * If the object is not already a double, the conversion will free any * old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetDoubleFromObj(interp, objPtr, dblPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object from which to get a double. */ register double *dblPtr; /* Place to store resulting double. */ { do { if (objPtr->typePtr == &tclDoubleType) { if (TclIsNaN(objPtr->internalRep.doubleValue)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "floating point value is Not a Number", -1)); } return TCL_ERROR; } *dblPtr = (double) objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { *dblPtr = objPtr->internalRep.longValue; return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { mp_int big; UNPACK_BIGNUM( objPtr, big ); *dblPtr = TclBignumToDouble( &big ); return TCL_OK; } #ifndef NO_WIDE_TYPE if (objPtr->typePtr == &tclWideIntType) { *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; } #endif } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * SetDoubleFromAny -- * |
︙ | ︙ | |||
1661 1662 1663 1664 1665 1666 1667 | */ static int SetDoubleFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { | < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < | < < < | < < < | < < < < | < < < < < < < < < < < < < | | | | | 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 | */ static int SetDoubleFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { return TclParseNumber( interp, objPtr, "floating-point number", NULL, -1, NULL, 0); } /* *---------------------------------------------------------------------- * * UpdateStringOfDouble -- * * Update the string representation for a double-precision floating point * object. This must obey the current tcl_precision value for * double-to-string conversions. Note: This procedure does not free an * existing old string rep so storage will be lost if this has not * already been done. * * Results: * None. * * Side effects: * The object's string is set to a valid string that results from the * double-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfDouble(objPtr) register Tcl_Obj *objPtr; /* Double obj with string rep to update. */ |
︙ | ︙ | |||
1770 1771 1772 1773 1774 1775 1776 | * * If a client is compiled with TCL_MEM_DEBUG defined, calls to * Tcl_NewIntObj to create a new integer object end up calling the * debugging procedure Tcl_DbNewLongObj instead. * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewIntObj result in a call to one of the two | | | | | | | | | 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 | * * If a client is compiled with TCL_MEM_DEBUG defined, calls to * Tcl_NewIntObj to create a new integer object end up calling the * debugging procedure Tcl_DbNewLongObj instead. * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewIntObj result in a call to one of the two * Tcl_NewIntObj implementations below. We provide two implementations so * that the Tcl core can be compiled to do memory debugging of the core * even if a client does not request it for itself. * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj * checks whether the current value of the long can be represented by an * int. * * Results: * The newly created object is returned. This object will have an invalid * string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1807 1808 1809 1810 1811 1812 1813 | Tcl_Obj * Tcl_NewIntObj(intValue) register int intValue; /* Int used to initialize the new object. */ { register Tcl_Obj *objPtr; | | < < < < | | | < < < | | | | | | | | < < < < | < < < < | | < | < | < < < < | < < < < | < < < < < | < < < < | < < < | > | < | | < < < < < < < < < < | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | 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 | Tcl_Obj * Tcl_NewIntObj(intValue) register int intValue; /* Int used to initialize the new object. */ { register Tcl_Obj *objPtr; TclNewIntObj(objPtr, intValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetIntObj -- * * Modify an object to be an integer and to have the specified integer * value. * * Results: * None. * * Side effects: * The object's old string rep, if any, is freed. Also, any old internal * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetIntObj(objPtr, intValue) register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ register int intValue; /* Integer used to set object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetIntObj called with shared object"); } TclSetIntObj(objPtr, intValue); } /* *---------------------------------------------------------------------- * * Tcl_GetIntFromObj -- * * Attempt to return an int from the Tcl object "objPtr". If the object * is not already an int, an attempt will be made to convert it to one. * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj * checks whether the current value of the long can be represented by an * int. * * Results: * The return value is a standard Tcl object result. If an error occurs * during conversion or if the long integer held by the object can not be * represented by an int, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * If the object is not already an int, the conversion will free any old * internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetIntFromObj(interp, objPtr, intPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object from which to get a int. */ register int *intPtr; /* Place to store resulting int. */ { long l; if (Tcl_GetLongFromObj(interp, objPtr, &l) != TCL_OK) { return TCL_ERROR; } if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { if (interp != NULL) { CONST char *s = "integer value too large to represent as non-long integer"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); } return TCL_ERROR; } *intPtr = (int)l; return TCL_OK; } /* *---------------------------------------------------------------------- * * SetIntFromAny -- * * Attempts to force the internal representation for a Tcl object to * tclIntType, specifically. * * Results: * The return value is a standard object Tcl result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * *---------------------------------------------------------------------- */ static int SetIntFromAny(interp, objPtr) Tcl_Interp* interp; /* Tcl interpreter */ Tcl_Obj* objPtr; /* Pointer to the object to convert */ { long l; return Tcl_GetLongFromObj(interp, objPtr, &l); } /* *---------------------------------------------------------------------- * * UpdateStringOfInt -- * * Update the string representation for an integer object. Note: This * procedure does not free an existing old string rep so storage will be * lost if this has not already been done. * * Results: * None. * * Side effects: * The object's string is set to a valid string that results from the * int-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfInt(objPtr) register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ |
︙ | ︙ | |||
2141 2142 2143 2144 2145 2146 2147 | /* *---------------------------------------------------------------------- * * Tcl_NewLongObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to | | | | | | | | 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 | /* *---------------------------------------------------------------------- * * Tcl_NewLongObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to * Tcl_NewLongObj to create a new long integer object end up calling the * debugging procedure Tcl_DbNewLongObj instead. * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewLongObj result in a call to one of the two * Tcl_NewLongObj implementations below. We provide two implementations * so that the Tcl core can be compiled to do memory debugging of the * core even if a client does not request it for itself. * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj * checks whether the current value of the long can be represented by an * int. * * Results: * The newly created object is returned. This object will have an invalid * string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2185 2186 2187 2188 2189 2190 2191 | Tcl_Obj * Tcl_NewLongObj(longValue) register long longValue; /* Long integer used to initialize the * new object. */ { register Tcl_Obj *objPtr; | | < < < < | | | | < | | | | | | | | | | | | | | | | | | | < | < < | | < | | | < < | < | < | | < | | | | | | > | | | | | < < < < < > < | | | > > > > | < < < < < < < < < < < < < < < < < < < < > | < | > > | > | < < < | < < | < < < | < | < < < < < < < | < < < | > > > > | | < | < < < | < | < < < < < < < < < < | | | < < < < < < < | | < < < | < < | < | | < | < | < < | < | < < < < | | < | > | > | | | | | < | | < | > > | | | | | | | 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 | Tcl_Obj * Tcl_NewLongObj(longValue) register long longValue; /* Long integer used to initialize the * new object. */ { register Tcl_Obj *objPtr; TclNewLongObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_DbNewLongObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or long integer * objects end up calling the debugging procedure Tcl_DbNewLongObj * instead. We provide two implementations of Tcl_DbNewLongObj so that * whether the Tcl core is compiled to do memory debugging of the core is * independent of whether a client requests debugging for itself. * * When the core is compiled with TCL_MEM_DEBUG defined, Tcl_DbNewLongObj * calls Tcl_DbCkalloc directly with the file name and line number from * its caller. This simplifies debugging since then the [memory active] * command will report the caller's file name and line number when * reporting objects that haven't been freed. * * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, * this procedure just returns the result of calling Tcl_NewLongObj. * * Results: * The newly created long integer object is returned. This object will * have an invalid string representation. The returned object has ref * count 0. * * Side effects: * Allocates memory. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewLongObj(longValue, file, line) register long longValue; /* Long integer used to initialize the new * object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; objPtr->internalRep.longValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewLongObj(longValue, file, line) register long longValue; /* Long integer used to initialize the new * object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ { return Tcl_NewLongObj(longValue); } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetLongObj -- * * Modify an object to be an integer object and to have the specified * long integer value. * * Results: * None. * * Side effects: * The object's old string rep, if any, is freed. Also, any old internal * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetLongObj(objPtr, longValue) register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ register long longValue; /* Long integer used to initialize the * object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetLongObj called with shared object"); } TclSetLongObj(objPtr, longValue); } /* *---------------------------------------------------------------------- * * Tcl_GetLongFromObj -- * * Attempt to return an long integer from the Tcl object "objPtr". If the * object is not already an int object, an attempt will be made to * convert it to one. * * Results: * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * If the object is not already an int object, the conversion will free * any old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetLongFromObj(interp, objPtr, longPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object from which to get a long. */ register long *longPtr; /* Place to store resulting long. */ { do { if (objPtr->typePtr == &tclIntType) { *longPtr = objPtr->internalRep.longValue; return TCL_OK; } #ifndef NO_WIDE_TYPE if (objPtr->typePtr == &tclWideIntType) { /* * We return any integer in the range -ULONG_MAX to ULONG_MAX * converted to a long, ignoring overflow. The rule preserves * existing semantics for conversion of integers on input, but * avoids inadvertent demotion of wide integers to 32-bit ones * in the internal rep. */ Tcl_WideInt w = objPtr->internalRep.wideValue; if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) { *longPtr = Tcl_WideAsLong(w); return TCL_OK; } goto tooLarge; } #endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_Obj* msg = Tcl_NewStringObj("expected integer but got \"", -1); Tcl_AppendObjToObj(msg, objPtr); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); } return TCL_ERROR; } if (objPtr->typePtr == &tclBignumType) { /* Must check for those bignum values that can fit in * a long, even when auto-narrowing is enabled. Only those * values in the signed long range get auto-narrowed to * tclIntType, while all the values in the unsigned long * range will fit in a long. */ mp_int big; UNPACK_BIGNUM(objPtr, big); if (big.used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) { unsigned long value = 0, numBytes = sizeof(long); long scratch; unsigned char *bytes = (unsigned char *)&scratch; if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { *longPtr = - (long) value; } else { *longPtr = (long) value; } return TCL_OK; } } #ifndef NO_WIDE_TYPE tooLarge: #endif if (interp != NULL) { char *s = "integer value too large to represent"; Tcl_Obj* msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL); } return TCL_ERROR; } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } #ifndef NO_WIDE_TYPE /* *---------------------------------------------------------------------- * * UpdateStringOfWideInt -- * * Update the string representation for a wide integer object. Note: * This procedure does not free an existing old string rep so storage * will be lost if this has not already been done. * * Results: * None. * * Side effects: * The object's string is set to a valid string that results from the * wideInt-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfWideInt(objPtr) register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ { char buffer[TCL_INTEGER_SPACE+2]; register unsigned len; register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; /* * Note that sprintf will generate a compiler warning under Mingw claiming * %I64 is an unknown format specifier. Just ignore this warning. We can't * use %L as the format specifier since that gets printed as a 32 bit * value. */ sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); len = strlen(buffer); objPtr->bytes = ckalloc((unsigned) len + 1); memcpy(objPtr->bytes, buffer, len + 1); objPtr->length = len; } #endif /* !NO_WIDE_TYPE */ /* *---------------------------------------------------------------------- * * Tcl_NewWideIntObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to * Tcl_NewWideIntObj to create a new 64-bit integer object end up calling * the debugging procedure Tcl_DbNewWideIntObj instead. * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewWideIntObj result in a call to one of the two * Tcl_NewWideIntObj implementations below. We provide two * implementations so that the Tcl core can be compiled to do memory * debugging of the core even if a client does not request it for itself. * * Results: * The newly created object is returned. This object will have an invalid * string representation. The returned object has ref count 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2562 2563 2564 2565 2566 2567 2568 | Tcl_NewWideIntObj(wideValue) register Tcl_WideInt wideValue; /* Wide integer used to initialize * the new object. */ { register Tcl_Obj *objPtr; TclNewObj(objPtr); | < | < < | | | | | < | | | | < | | | | | | | < | < < | | | | | | | | > > | > > | > > | | > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > | | | > > | > > > > | > | > > > > > > > | > > > > | | | | | | | | > | | | < > > | 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 | Tcl_NewWideIntObj(wideValue) register Tcl_WideInt wideValue; /* Wide integer used to initialize * the new object. */ { register Tcl_Obj *objPtr; TclNewObj(objPtr); Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_DbNewWideIntObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to * Tcl_NewWideIntObj to create new wide integer end up calling the * debugging procedure Tcl_DbNewWideIntObj instead. We provide two * implementations of Tcl_DbNewWideIntObj so that whether the Tcl core is * compiled to do memory debugging of the core is independent of whether * a client requests debugging for itself. * * When the core is compiled with TCL_MEM_DEBUG defined, * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file name * and line number from its caller. This simplifies debugging since then * the checkmem command will report the caller's file name and line * number when reporting objects that haven't been freed. * * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, * this procedure just returns the result of calling Tcl_NewWideIntObj. * * Results: * The newly created wide integer object is returned. This object will * have an invalid string representation. The returned object has ref * count 0. * * Side effects: * Allocates memory. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewWideIntObj(wideValue, file, line) register Tcl_WideInt wideValue; /* Wide integer used to initialize the * new object. */ CONST char *file; /* The name of the source file calling * this procedure; used for * debugging. */ int line; /* Line number in the source file; * used for debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewWideIntObj(wideValue, file, line) register Tcl_WideInt wideValue; /* Long integer used to initialize the * new object. */ CONST char *file; /* The name of the source file calling * this procedure; used for * debugging. */ int line; /* Line number in the source file; * used for debugging. */ { return Tcl_NewWideIntObj(wideValue); } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetWideIntObj -- * * Modify an object to be a wide integer object and to have the specified * wide integer value. * * Results: * None. * * Side effects: * The object's old string rep, if any, is freed. Also, any old internal * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetWideIntObj(objPtr, wideValue) register Tcl_Obj *objPtr; /* Object w. internal rep to init. */ register Tcl_WideInt wideValue; /* Wide integer used to initialize * the object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetWideIntObj called with shared object"); } if ((wideValue >= (Tcl_WideInt) LONG_MIN) && (wideValue <= (Tcl_WideInt) LONG_MAX)) { TclSetLongObj(objPtr, (long) wideValue); } else { #ifndef NO_WIDE_TYPE TclSetWideIntObj(objPtr, wideValue); #else mp_int big; TclBNInitBignumFromWideInt(&big, wideValue); Tcl_SetBignumObj(objPtr, &big); #endif } } /* *---------------------------------------------------------------------- * * Tcl_GetWideIntFromObj -- * * Attempt to return a wide integer from the Tcl object "objPtr". If the * object is not already a wide int object, an attempt will be made to * convert it to one. * * Results: * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * * Side effects: * If the object is not already an int object, the conversion will free * any old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* Object from which to get a wide int. */ register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */ { do { #ifndef NO_WIDE_TYPE if (objPtr->typePtr == &tclWideIntType) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } #endif if (objPtr->typePtr == &tclIntType) { *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_Obj* msg = Tcl_NewStringObj("expected integer but got \"", -1); Tcl_AppendObjToObj(msg, objPtr); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); } return TCL_ERROR; } if (objPtr->typePtr == &tclBignumType) { /* Must check for those bignum values that can fit in * a Tcl_WideInt, even when auto-narrowing is enabled. */ mp_int big; UNPACK_BIGNUM(objPtr, big); if (big.used <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { Tcl_WideUInt value = 0; unsigned long numBytes = sizeof(Tcl_WideInt); Tcl_WideInt scratch; unsigned char *bytes = (unsigned char *)&scratch; if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { *wideIntPtr = - (Tcl_WideInt) value; } else { *wideIntPtr = (Tcl_WideInt) value; } return TCL_OK; } } if (interp != NULL) { char *s = "integer value too large to represent"; Tcl_Obj* msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL); } return TCL_ERROR; } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * FreeBignum -- * * This procedure frees the internal rep of a bignum. * * Results: * None. * *---------------------------------------------------------------------- */ static void FreeBignum(Tcl_Obj *objPtr) { mp_int toFree; /* Bignum to free */ UNPACK_BIGNUM(objPtr, toFree); mp_clear(&toFree); if (objPtr->internalRep.ptrAndLongRep.value < 0) { ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr); } } /* *---------------------------------------------------------------------- * * DupBignum -- * * This procedure duplicates the internal rep of a bignum. * * Results: * None. * * Side effects: * The destination object receies a copy of the source object * *---------------------------------------------------------------------- */ static void DupBignum(srcPtr, copyPtr) Tcl_Obj* srcPtr; Tcl_Obj* copyPtr; { mp_int bignumVal; mp_int bignumCopy; copyPtr->typePtr = &tclBignumType; UNPACK_BIGNUM(srcPtr, bignumVal); if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { Tcl_Panic("initialization failure in DupBignum"); } PACK_BIGNUM(bignumCopy, copyPtr); } /* *---------------------------------------------------------------------- * * UpdateStringOfBignum -- * * This procedure updates the string representation of a bignum object. * * Results: * None. * * Side effects: * The object's string is set to whatever results from the bignum- * to-string conversion. * * The object's existing string representation is NOT freed; memory will leak * if the string rep is still valid at the time this procedure is called. */ static void UpdateStringOfBignum(Tcl_Obj* objPtr) { mp_int bignumVal; int size; int status; char* stringVal; UNPACK_BIGNUM(objPtr, bignumVal); status = mp_radix_size(&bignumVal, 10, &size); if (status != MP_OKAY) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } if (size == 3 #ifndef BIGNUM_AUTO_NARROW && bignumVal.used > 1 #endif ) { /* * mp_radix_size() returns 3 when more than INT_MAX bytes would * be needed to hold the string rep (because mp_radix_size * ignores integer overflow issues). When we know the string * rep will be more than 3, we can conclude the string rep would * overflow our string length limits. * * Note that so long as we enforce our bignums to the size that * fits in a packed bignum, this branch will never be taken. */ Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); } stringVal = Tcl_Alloc((size_t) size); status = mp_toradix_n(&bignumVal, stringVal, 10, size); if (status != MP_OKAY) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } objPtr->bytes = stringVal; objPtr->length = size - 1; /* size includes a trailing null byte */ } /* *---------------------------------------------------------------------- * * Tcl_NewBignumObj -- * * Creates an initializes a bignum object. * * Results: * Returns the newly created object. * * Side effects: * The bignum value is cleared, since ownership has transferred to Tcl. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewBignumObj Tcl_Obj* Tcl_NewBignumObj(mp_int* bignumValue) { return Tcl_DbNewBignumObj(bignumValue, "unknown", 0); } #else Tcl_Obj * Tcl_NewBignumObj(mp_int* bignumValue) { Tcl_Obj* objPtr; TclNewObj(objPtr); Tcl_SetBignumObj(objPtr, bignumValue); return objPtr; } #endif /* *---------------------------------------------------------------------- * * Tcl_DbNewBignumObj -- * * This procedure is normally called when debugging: that is, when * TCL_MEM_DEBUG is defined. It constructs a bignum object, recording * the creation point so that [memory active] can report it. * * Results: * Returns the newly created object. * * Side effects: * The bignum value is cleared, since ownership has transferred to Tcl. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj* Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line) { Tcl_Obj* objPtr; TclDbNewObj(objPtr, file, line); Tcl_SetBignumObj(objPtr, bignumValue); return objPtr; } #else Tcl_Obj* Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line) { return Tcl_NewBignumObj(bignumValue); } #endif /* *---------------------------------------------------------------------- * * GetBignumFromObj -- * * This procedure retrieves a 'bignum' value from a Tcl object, * converting the object if necessary. Either copies or transfers * the mp_int value depending on the copy flag value passed in. * * Results: * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise. * * Side effects: * A copy of bignum is stored in *bignumValue, which is expected to be * uninitialized or cleared. If conversion fails, and the 'interp' * argument is not NULL, an error message is stored in the interpreter * result. * *---------------------------------------------------------------------- */ int GetBignumFromObj( Tcl_Interp* interp, /* Tcl interpreter for error reporting */ Tcl_Obj* objPtr, /* Object to read */ int copy, /* Whether to copy the returned bignum value */ mp_int* bignumValue) /* Returned bignum value. */ { do { if (objPtr->typePtr == &tclBignumType) { if (copy) { mp_int temp; UNPACK_BIGNUM(objPtr, temp); mp_init_copy(bignumValue, &temp); } else { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_GetBignumAndClearObj called on shared Tcl_Obj"); } UNPACK_BIGNUM(objPtr, *bignumValue); objPtr->internalRep.ptrAndLongRep.ptr = NULL; objPtr->internalRep.ptrAndLongRep.value = 0; objPtr->typePtr = NULL; if (objPtr->bytes == NULL) { TclInitStringRep(objPtr, NULL, 0); } } return TCL_OK; } if (objPtr->typePtr == &tclIntType) { TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); return TCL_OK; } #ifndef NO_WIDE_TYPE if (objPtr->typePtr == &tclWideIntType) { TclBNInitBignumFromWideInt(bignumValue, objPtr->internalRep.wideValue); return TCL_OK; } #endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_Obj* msg = Tcl_NewStringObj("expected integer but got \"", -1); Tcl_AppendObjToObj(msg, objPtr); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); } return TCL_ERROR; } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Tcl_GetBignumFromObj -- * * This procedure retrieves a 'bignum' value from a Tcl object, * converting the object if necessary. * * Results: * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise. * * Side effects: * A copy of bignum is stored in *bignumValue, which is expected to be * uninitialized or cleared. If conversion fails, an the 'interp' * argument is not NULL, an error message is stored in the interpreter * result. * * It is expected that the caller will NOT have invoked mp_init on the * bignum value before passing it in. Tcl will initialize the mp_int * as it sets the value. The value is a copy of the value in objPtr, * so it becomes the responsibility of the caller to call mp_clear on * it. * *---------------------------------------------------------------------- */ int Tcl_GetBignumFromObj( Tcl_Interp* interp, /* Tcl interpreter for error reporting */ Tcl_Obj* objPtr, /* Object to read */ mp_int* bignumValue) /* Returned bignum value. */ { return GetBignumFromObj(interp, objPtr, 1, bignumValue); } /* *---------------------------------------------------------------------- * * Tcl_GetBignumAndClearObj -- * * This procedure retrieves a 'bignum' value from a Tcl object, * converting the object if necessary. * * Results: * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise. * * Side effects: * A copy of bignum is stored in *bignumValue, which is expected to be * uninitialized or cleared. If conversion fails, an the 'interp' * argument is not NULL, an error message is stored in the interpreter * result. * * It is expected that the caller will NOT have invoked mp_init on the * bignum value before passing it in. Tcl will initialize the mp_int * as it sets the value. The value is transferred from the internals * of objPtr to the caller, passing responsibility of the caller to * call mp_clear on it. The objPtr is cleared to hold an empty value. * *---------------------------------------------------------------------- */ int Tcl_GetBignumAndClearObj( Tcl_Interp* interp, /* Tcl interpreter for error reporting */ Tcl_Obj* objPtr, /* Object to read */ mp_int* bignumValue) /* Returned bignum value. */ { return GetBignumFromObj(interp, objPtr, 0, bignumValue); } /* *---------------------------------------------------------------------- * * Tcl_SetBignumObj -- * * This procedure sets the value of a Tcl_Obj to a large integer. * * Results: * None. * * Side effects: * Object value is stored. The bignum value is cleared, since ownership * has transferred to Tcl. * *---------------------------------------------------------------------- */ void Tcl_SetBignumObj( Tcl_Obj* objPtr, /* Object to set */ mp_int* bignumValue) /* Value to store */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetBignumObj called with shared object"); } #ifdef BIGNUM_AUTO_NARROW if (bignumValue->used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) { unsigned long value = 0, numBytes = sizeof(long); long scratch; unsigned char *bytes = (unsigned char *)&scratch; if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { goto tooLargeForLong; } while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) { goto tooLargeForLong; } if (bignumValue->sign) { TclSetLongObj(objPtr, -(long)value); } else { TclSetLongObj(objPtr, (long)value); } mp_clear(bignumValue); return; } tooLargeForLong: #ifndef NO_WIDE_TYPE if (bignumValue->used <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { Tcl_WideUInt value = 0; unsigned long numBytes = sizeof(Tcl_WideInt); Tcl_WideInt scratch; unsigned char *bytes = (unsigned char *)&scratch; if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { goto tooLargeForWide; } while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) { goto tooLargeForWide; } if (bignumValue->sign) { TclSetWideIntObj(objPtr, -(Tcl_WideInt)value); } else { TclSetWideIntObj(objPtr, (Tcl_WideInt)value); } mp_clear(bignumValue); return; } tooLargeForWide: #endif #endif TclInvalidateStringRep(objPtr); TclFreeIntRep(objPtr); TclSetBignumIntRep(objPtr, bignumValue); } void TclSetBignumIntRep(objPtr, bignumValue) Tcl_Obj *objPtr; mp_int *bignumValue; { objPtr->typePtr = &tclBignumType; PACK_BIGNUM(*bignumValue, objPtr); /* * Clear the mp_int value. * Don't call mp_clear() because it would free the digit array * we just packed into the Tcl_Obj. */ bignumValue->dp = NULL; bignumValue->alloc = bignumValue->used = 0; bignumValue->sign = MP_NEG; } /* *---------------------------------------------------------------------- * * TclGetNumberFromObj -- * * Results: * * Side effects: * *---------------------------------------------------------------------- */ int TclGetNumberFromObj(interp, objPtr, clientDataPtr, typePtr) Tcl_Interp *interp; Tcl_Obj *objPtr; ClientData *clientDataPtr; int *typePtr; { do { if (objPtr->typePtr == &tclDoubleType) { if (TclIsNaN(objPtr->internalRep.doubleValue)) { *typePtr = TCL_NUMBER_NAN; } else { *typePtr = TCL_NUMBER_DOUBLE; } *clientDataPtr = &(objPtr->internalRep.doubleValue); return TCL_OK; } if (objPtr->typePtr == &tclIntType) { *typePtr = TCL_NUMBER_LONG; *clientDataPtr = &(objPtr->internalRep.longValue); return TCL_OK; } #ifndef NO_WIDE_TYPE if (objPtr->typePtr == &tclWideIntType) { *typePtr = TCL_NUMBER_WIDE; *clientDataPtr = &(objPtr->internalRep.wideValue); return TCL_OK; } #endif if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, (int)sizeof(mp_int)); UNPACK_BIGNUM( objPtr, *bigPtr ); *typePtr = TCL_NUMBER_BIG; *clientDataPtr = bigPtr; return TCL_OK; } } while (TCL_OK == TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0)); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Tcl_DbIncrRefCount -- * * This procedure is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. This checks to see whether or not the memory * has been freed before incrementing the ref count. * * When TCL_MEM_DEBUG is not defined, this procedure just increments the * reference count of the object. * * Results: * None. * * Side effects: * The object's ref count is incremented. * *---------------------------------------------------------------------- */ void Tcl_DbIncrRefCount(objPtr, file, line) register Tcl_Obj *objPtr; /* The object we are registering a reference * to. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("Trying to increment refCount of previously disposed object."); } # ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local * storage can be finalized before the last Tcl_Obj is freed. */ if (!TclInExit()) { Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); if (!hPtr) { Tcl_Panic("%s%s", |
︙ | ︙ | |||
2785 2786 2787 2788 2789 2790 2791 | /* *---------------------------------------------------------------------- * * Tcl_DbDecrRefCount -- * * This procedure is normally called when debugging: i.e., when | | | | | | | > | | | < > > | | 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 | /* *---------------------------------------------------------------------- * * Tcl_DbDecrRefCount -- * * This procedure is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. This checks to see whether or not the memory * has been freed before decrementing the ref count. * * When TCL_MEM_DEBUG is not defined, this procedure just decrements the * reference count of the object. * * Results: * None. * * Side effects: * The object's ref count is incremented. * *---------------------------------------------------------------------- */ void Tcl_DbDecrRefCount(objPtr, file, line) register Tcl_Obj *objPtr; /* The object we are releasing a reference * to. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("Trying to decrement refCount of previously disposed object."); } # ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local * storage can be finalized before the last Tcl_Obj is freed. */ if (!TclInExit()) { Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); if (!hPtr) { Tcl_Panic("%s%s", "Trying to decr ref count of ", "Tcl_Obj allocated in another thread"); } /* If the Tcl_Obj is going to be deleted, remove the entry */ if ((((objPtr)->refCount) - 1) <= 0) { Tcl_DeleteHashEntry(hPtr); } |
︙ | ︙ | |||
2855 2856 2857 2858 2859 2860 2861 | /* *---------------------------------------------------------------------- * * Tcl_DbIsShared -- * * This procedure is normally called when debugging: i.e., when | | | | | | | > | | | < > > > | | | > | | 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 | /* *---------------------------------------------------------------------- * * Tcl_DbIsShared -- * * This procedure is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It tests whether the object has a ref count * greater than one. * * When TCL_MEM_DEBUG is not defined, this procedure just tests if the * object has a ref count greater than one. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_DbIsShared(objPtr, file, line) register Tcl_Obj *objPtr; /* The object to test for being shared. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("Trying to check whether previously disposed object is shared."); } # ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local * storage can be finalized before the last Tcl_Obj is freed. */ if (!TclInExit()) { Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); if (!hPtr) { Tcl_Panic("%s%s", "Trying to check shared status of", "Tcl_Obj allocated in another thread"); } } # endif #endif #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); if ((objPtr)->refCount <= 1) { tclObjsShared[1]++; } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) { tclObjsShared[(objPtr)->refCount]++; } else { tclObjsShared[0]++; } Tcl_MutexUnlock(&tclObjMutex); #endif return ((objPtr)->refCount > 1); } /* *---------------------------------------------------------------------- * * Tcl_InitObjHashTable -- * * Given storage for a hash table, set up the fields to prepare the hash * table for use, the keys are Tcl_Obj *. * * Results: * None. * * Side effects: * TablePtr is now ready to be passed to Tcl_FindHashEntry and * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitObjHashTable(tablePtr) register Tcl_HashTable *tablePtr; /* Pointer to table record, which is supplied * by the caller. */ { Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS, &tclObjHashKeyType); } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
2988 2989 2990 2991 2992 2993 2994 | *---------------------------------------------------------------------- * * CompareObjKeys -- * * Compares two Tcl_Obj * keys. * * Results: | | | > > > | 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 | *---------------------------------------------------------------------- * * CompareObjKeys -- * * Compares two Tcl_Obj * keys. * * Results: * The return value is 0 if they are different and 1 if they are the * same. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int CompareObjKeys(keyPtr, hPtr) VOID *keyPtr; /* New key to compare. */ Tcl_HashEntry *hPtr; /* Existing key to compare. */ { Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr; Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; register CONST char *p1, *p2; register int l1, l2; /* * If the object pointers are the same then they match. */ if (objPtr1 == objPtr2) { return 1; } /* * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being * in a register. */ p1 = TclGetString(objPtr1); l1 = objPtr1->length; p2 = TclGetString(objPtr2); l2 = objPtr2->length; /* * Only compare if the string representations are of the same length. */ if (l1 == l2) { for (;; p1++, p2++, l1--) { if (*p1 != *p2) { break; } if (l1 == 0) { return 1; |
︙ | ︙ | |||
3075 3076 3077 3078 3079 3080 3081 | * * HashObjKey -- * * Compute a one-word summary of the string representation of the * Tcl_Obj, which can be used to generate a hash index. * * Results: | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | * * HashObjKey -- * * Compute a one-word summary of the string representation of the * Tcl_Obj, which can be used to generate a hash index. * * Results: * The return value is a one-word summary of the information in the * string representation of the Tcl_Obj. * * Side effects: * None. * *---------------------------------------------------------------------- */ static unsigned int HashObjKey(tablePtr, keyPtr) Tcl_HashTable *tablePtr; /* Hash table. */ VOID *keyPtr; /* Key from which to compute hash value. */ { Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; CONST char *string = TclGetString(objPtr); int length = objPtr->length; unsigned int result = 0; int i; /* * I tried a zillion different hash functions and asked many other people * for advice. Many people had their own favorite functions, all * different, but no-one had much idea why they were good ones. I chose * the one below (multiply by 9 and add new character) because of the * following reasons: * * 1. Multiplying by 10 is perfect for keys that are decimal strings, and * multiplying by 9 is just about as good. * 2. Times-9 is (shift-left-3) plus (old). This means that each * character's bits hang around in the low-order bits of the hash value * for ever, plus they spread fairly rapidly up to the high-order bits * to fill out the hash value. This seems works well both for decimal * and *non-decimal strings. */ for (i=0 ; i<length ; i++) { result += (result << 3) + string[i]; } return result; } /* *---------------------------------------------------------------------- * * Tcl_GetCommandFromObj -- * * Returns the command specified by the name in a Tcl_Obj. * * Results: * Returns a token for the command if it is found. Otherwise, if it can't * be found or there is an error, returns NULL. * * Side effects: * May update the internal representation for the object, caching the * command reference so that the next time this procedure is called with * the same object, the command can be found quickly. * *---------------------------------------------------------------------- */ 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; char *name; /* * If the variable name is fully qualified, do as if the lookup were done * from the global namespace; this helps avoid repeated lookups of fully * qualified names. It costs close to nothing, and may be very helpful for * OO applications which pass along a command name ("this"), [Patch * 456668] */ savedFramePtr = iPtr->varFramePtr; name = Tcl_GetString(objPtr); if ((*name++ == ':') && (*name == ':')) { iPtr->varFramePtr = NULL; } /* * Get the internal representation, converting to a command type if * needed. The internal representation is a ResolvedCmdName that points to * the actual command. */ if (objPtr->typePtr != &tclCmdNameType) { result = tclCmdNameType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { iPtr->varFramePtr = savedFramePtr; return (Tcl_Command) NULL; |
︙ | ︙ | |||
3196 3197 3198 3199 3200 3201 3202 | } else { currNsPtr = iPtr->globalNsPtr; } /* * Check the context namespace and the namespace epoch of the resolved * symbol to make sure that it is fresh. If not, then force another | | | | | | | 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 | } else { currNsPtr = iPtr->globalNsPtr; } /* * Check the context namespace and the namespace epoch of the resolved * symbol to make sure that it is fresh. If not, then force another * conversion to the command type, to discard the old rep and create a new * one. Note that we verify that the namespace id of the context namespace * is the same as the one we cached; this insures that the namespace * wasn't deleted and a new one created at the same address with the same * command epoch. */ cmdPtr = NULL; if ((resPtr != NULL) && (resPtr->refNsPtr == currNsPtr) && (resPtr->refNsId == currNsPtr->nsId) && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) { |
︙ | ︙ | |||
3242 3243 3244 3245 3246 3247 3248 | * Command structure. * * Results: * None. * * Side effects: * The object's old internal rep is freed. It's string rep is not | | | | | > > > > > > > > > > > > > > > > | 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 | * Command structure. * * Results: * None. * * Side effects: * The object's old internal rep is freed. It's string rep is not * changed. The refcount in the Command structure is incremented to keep * it from being freed if the command is later deleted until * TclExecuteByteCode has a chance to recognize that it was deleted. * *---------------------------------------------------------------------- */ void TclSetCmdNameObj(interp, objPtr, cmdPtr) Tcl_Interp *interp; /* Points to interpreter containing command * that should be cached in objPtr. */ register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to a * CmdName object. */ Command *cmdPtr; /* Points to Command structure that the * CmdName object should refer to. */ { Interp *iPtr = (Interp *) interp; register ResolvedCmdName *resPtr; register Namespace *currNsPtr; CallFrame *savedFramePtr; char *name; if (objPtr->typePtr == &tclCmdNameType) { return; } /* * If the variable name is fully qualified, do as if the lookup were done * from the global namespace; this helps avoid repeated lookups of fully * qualified names. It costs close to nothing, and may be very helpful for * OO applications which pass along a command name ("this"), [Patch * 456668] (Copied over from Tcl_GetCommandFromObj) */ savedFramePtr = iPtr->varFramePtr; name = Tcl_GetString(objPtr); if ((*name++ == ':') && (*name == ':')) { iPtr->varFramePtr = NULL; } /* * Get the current namespace. */ if (iPtr->varFramePtr != NULL) { currNsPtr = iPtr->varFramePtr->nsPtr; |
︙ | ︙ | |||
3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 | resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; } /* *---------------------------------------------------------------------- * * FreeCmdNameInternalRep -- * * Frees the resources associated with a cmdName object's internal * representation. * * Results: * None. * * Side effects: * Decrements the ref count of any cached ResolvedCmdName structure | > > | | | | | | | | | | | | | | | | | 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 | resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; iPtr->varFramePtr = savedFramePtr; } /* *---------------------------------------------------------------------- * * FreeCmdNameInternalRep -- * * Frees the resources associated with a cmdName object's internal * representation. * * Results: * None. * * Side effects: * Decrements the ref count of any cached ResolvedCmdName structure * pointed to by the cmdName's internal representation. If this is the * last use of the ResolvedCmdName, it is freed. This in turn decrements * the ref count of the Command structure pointed to by the * ResolvedSymbol, which may free the Command structure. * *---------------------------------------------------------------------- */ static void FreeCmdNameInternalRep(objPtr) register Tcl_Obj *objPtr; /* CmdName object with internal * representation to free. */ { register ResolvedCmdName *resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; if (resPtr != NULL) { /* * Decrement the reference count of the ResolvedCmdName structure. If * there are no more uses, free the ResolvedCmdName structure. */ resPtr->refCount--; if (resPtr->refCount == 0) { /* * Now free the cached command, unless it is still in its hash * table or if there are other references to it from other cmdName * objects. */ Command *cmdPtr = resPtr->cmdPtr; TclCleanupCommand(cmdPtr); ckfree((char *) resPtr); } } } /* *---------------------------------------------------------------------- * * DupCmdNameInternalRep -- * * Initialize the internal representation of an cmdName Tcl_Obj to a copy * of the internal representation of an existing cmdName object. * * Results: * None. * * Side effects: * "copyPtr"s internal rep is set to point to the ResolvedCmdName * structure corresponding to "srcPtr"s internal rep. Increments the ref * count of the ResolvedCmdName structure pointed to by the cmdName's * internal representation. * *---------------------------------------------------------------------- */ static void DupCmdNameInternalRep(srcPtr, copyPtr) Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { register ResolvedCmdName *resPtr = (ResolvedCmdName *) srcPtr->internalRep.twoPtrValue.ptr1; copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; if (resPtr != NULL) { resPtr->refCount++; } copyPtr->typePtr = &tclCmdNameType; |
︙ | ︙ | |||
3390 3391 3392 3393 3394 3395 3396 | * * Results: * The return value is a standard Tcl result. The conversion always * succeeds and TCL_OK is returned. * * Side effects: * A pointer to a ResolvedCmdName structure that holds a cached pointer | | | | | | 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 | * * Results: * The return value is a standard Tcl result. The conversion always * succeeds and TCL_OK is returned. * * Side effects: * A pointer to a ResolvedCmdName structure that holds a cached pointer * to the command with a name that matches objPtr's string rep is stored * as objPtr's internal representation. This ResolvedCmdName pointer will * be NULL if no matching command was found. The ref count of the cached * Command's structure (if any) is also incremented. * *---------------------------------------------------------------------- */ static int SetCmdNameFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ |
︙ | ︙ | |||
3454 3455 3456 3457 3458 3459 3460 | resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; } else { resPtr = NULL; /* no command named "name" was found */ } /* | | | | | > > > > > > > > | 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 | resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; } else { resPtr = NULL; /* no command named "name" was found */ } /* * Free the old internalRep before setting the new one. We do this as late * as possible to allow the conversion code, in particular * GetStringFromObj, to use that old internalRep. If no Command structure * was found, leave NULL as the cached value. */ TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclPanic.c.
|
| | | | | | | | | | | | < | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | /* * tclPanic.c -- * * Source code for the "Tcl_Panic" library procedure for Tcl; individual * applications will probably call Tcl_SetPanicProc() to set an * application-specific panic procedure. * * Copyright (c) 1988-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclPanic.c,v 1.5.2.2 2005/09/15 20:58:40 dgp Exp $ */ #include "tclInt.h" /* * The panicProc variable contains a pointer to an application specific panic * procedure. */ static Tcl_PanicProc *panicProc = NULL; /* * The platformPanicProc variable contains a pointer to a platform specific * panic procedure, if any. (TclpPanic may be NULL via a macro.) */ static Tcl_PanicProc *CONST platformPanicProc = TclpPanic; /* *---------------------------------------------------------------------- * * Tcl_SetPanicProc -- * * Replace the default panic behavior with the specified function. * * Results: * None. * * Side effects: * Sets the panicProc variable. * |
︙ | ︙ | |||
69 70 71 72 73 74 75 | * Side effects: * The process dies, entering the debugger if possible. * *---------------------------------------------------------------------- */ void | | | | 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 | * Side effects: * The process dies, entering the debugger if possible. * *---------------------------------------------------------------------- */ void Tcl_PanicVA(format, argList) CONST char *format; /* Format string, suitable for passing to * fprintf. */ va_list argList; /* Variable argument list. */ { char *arg1, *arg2, *arg3, *arg4; /* Additional arguments (variable in * number) to pass to fprintf. */ char *arg5, *arg6, *arg7, *arg8; arg1 = va_arg(argList, char *); arg2 = va_arg(argList, char *); arg3 = va_arg(argList, char *); arg4 = va_arg(argList, char *); arg5 = va_arg(argList, char *); arg6 = va_arg(argList, char *); arg7 = va_arg(argList, char *); arg8 = va_arg(argList, char *); if (panicProc != NULL) { (void) (*panicProc)(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); } else if (platformPanicProc != NULL) { (void) (*platformPanicProc)(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); } else { |
︙ | ︙ | |||
118 119 120 121 122 123 124 | * * Side effects: * The process dies, entering the debugger if possible. * *---------------------------------------------------------------------- */ | | | < | > > > > > > > > | 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 | * * Side effects: * The process dies, entering the debugger if possible. * *---------------------------------------------------------------------- */ /* ARGSUSED */ void Tcl_Panic(CONST char *format, ...) { va_list argList; va_start(argList, format); Tcl_PanicVA(format, argList); va_end (argList); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclParse.c.
|
| | | | | < | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | /* * tclParse.c -- * * This file contains functions 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.39.2.4 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.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: */ |
︙ | ︙ | |||
166 167 168 169 170 171 172 | TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, }; /* | | | | | | | | > | | < | < | | | | | | < | | | | < | | | | | | | | | < | | | | | | | | | > | | | | 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 | TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, }; /* * Prototypes for local functions 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, int flags, Tcl_Parse *parsePtr)); /* *---------------------------------------------------------------------- * * TclParseInit -- * * Initialize the fields of a Tcl_Parse struct. * * Results: * None. * * Side effects: * The Tcl_Parse struct pointed to by parsePtr gets initialized. * *---------------------------------------------------------------------- */ void TclParseInit(interp, string, numBytes, parsePtr) Tcl_Interp *interp; /* Interpreter to use for error reporting */ CONST char *string; /* String to be parsed. */ int numBytes; /* Total number of bytes in string. If < 0, * the script consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr; /* Points to struct to initialize */ { parsePtr->numWords = 0; parsePtr->tokenPtr = parsePtr->staticTokens; parsePtr->numTokens = 0; parsePtr->tokensAvailable = NUM_STATIC_TOKENS; parsePtr->string = string; parsePtr->end = string + numBytes; parsePtr->term = parsePtr->end; parsePtr->interp = interp; parsePtr->incomplete = 0; parsePtr->errorType = TCL_PARSE_SUCCESS; } /* *---------------------------------------------------------------------- * * Tcl_ParseCommand -- * * Given a string, this function parses the first Tcl command in the * string and returns information about the structure of the command. * * 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 command that was parsed. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the command, then additional space is malloc-ed. If the function * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int Tcl_ParseCommand(interp, start, numBytes, nested, parsePtr) Tcl_Interp *interp; /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ CONST char *start; /* 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 ((start == 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(start); } TclParseInit(interp, start, numBytes, parsePtr); parsePtr->commentStart = NULL; parsePtr->commentSize = 0; parsePtr->commandStart = NULL; parsePtr->commandSize = 0; 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(start, numBytes, parsePtr); src = (start + 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. */ parsePtr->commandStart = src; while (1) { int expandWord = 0; /* |
︙ | ︙ | |||
328 329 330 331 332 333 334 | /* * 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); | | > | | | > | > | | | < | < | | | | > > | > > > > > > > | | | | | | | | | | > | | < | | | < | > | | | | | | | | | | > | | | | < | > | 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 | /* * 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) { parsePtr->term = src; 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 four forms: something * enclosed in quotes, something enclosed in braces, and expanding * word, or an unquoted word (anything else). */ parseWord: if (*src == '"') { if (Tcl_ParseQuotedString(interp, src, numBytes, parsePtr, 1, &termPtr) != TCL_OK) { goto error; } src = termPtr; numBytes = parsePtr->end - src; } else if (*src == '{') { static char expPfx[] = "expand"; CONST size_t expPfxLen = sizeof(expPfx) - 1; int expIdx = wordIndex + 1; Tcl_Token *expPtr; if (Tcl_ParseBraces(interp, src, numBytes, parsePtr, 1, &termPtr) != TCL_OK) { goto error; } src = termPtr; numBytes = parsePtr->end - src; /* * Check whether the braces contained the word expansion prefix. */ expPtr = &parsePtr->tokenPtr[expIdx]; if ( (0 == expandWord) /* Haven't seen prefix already */ && (1 == parsePtr->numTokens - expIdx) /* Only one token */ && (((expPfxLen == (size_t) expPtr->size) /* Same length as prefix */ && (0 == strncmp(expPfx,expPtr->start,expPfxLen))) #ifdef ALLOW_EMPTY_EXPAND /* * Allow {} in addition to {expand} */ || (0 == (size_t) expPtr->size) #endif ) /* Is the prefix */ && (numBytes > 0) && (TclParseWhiteSpace(termPtr, numBytes, parsePtr, &type) == 0) && (type != TYPE_COMMAND_END) /* Non-whitespace follows */ ) { expandWord = 1; parsePtr->numTokens--; goto parseWord; } } else { /* * This is an unquoted word. Call ParseTokens and let it do all of * the work. */ if (ParseTokens(src, numBytes, TYPE_SPACE|terminators, TCL_SUBST_ALL, 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. */ tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->size = src - tokenPtr->start; tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1); if ((tokenPtr->numComponents == 1) && (tokenPtr[1].type == TCL_TOKEN_TEXT)) { tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; } if (expandWord) { tokenPtr->type = TCL_TOKEN_EXPAND_WORD; } /* * 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) { parsePtr->term = src; 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); parsePtr->commandSize = parsePtr->end - 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; |
︙ | ︙ | |||
534 535 536 537 538 539 540 | } /* *---------------------------------------------------------------------- * * TclParseHex -- * | | < | | | | | | | > | | < | | 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 | } /* *---------------------------------------------------------------------- * * 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); |
︙ | ︙ | |||
591 592 593 594 595 596 597 | } /* *---------------------------------------------------------------------- * * TclParseBackslash -- * | | | | | | | < > | | | | | | | | | | > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | > > | | > | > | | | | | | > | > | | | | | | > | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | > | | | | | | > | | | | > | | | | | | | | | | | > | | > | > > > | > | | | | > | > > | | | | < | | | | | | | < | | | | | | | | | | | | | | | | | > | > | | > | > | | | > | | 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 | } /* *---------------------------------------------------------------------- * * 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, so 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 function 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 function 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 is * not NULL, then an error message is left in the interpreter's result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ParseTokens(src, numBytes, mask, flags, parsePtr) register CONST char *src; /* First character to parse. */ register int numBytes; /* Max number of bytes to scan. */ int flags; /* OR-ed bits indicating what substitutions to perform: TCL_SUBST_COMMANDS, TCL_SUBST_VARIABLES, and TCL_SUBST_BACKSLASHES */ 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; int noSubstCmds = !(flags & TCL_SUBST_COMMANDS); int noSubstVars = !(flags & TCL_SUBST_VARIABLES); int noSubstBS = !(flags & TCL_SUBST_BACKSLASHES); 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 == '$') { if (noSubstVars) { tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; src++; numBytes--; continue; } /* * 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 == '[') { if (noSubstCmds) { tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; src++; numBytes--; continue; } /* * 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; |
︙ | ︙ | |||
950 951 952 953 954 955 956 | if (nested.tokenPtr != nested.staticTokens) { ckfree((char *) nested.tokenPtr); } /* * Check for the closing ']' that ends the command | | | | > | > > > | > > > | | | | > | | | < > | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | < | | | | < | | | | | | | | | | | | < | > | | | | | | < | | | | | | | > | | > > | > | | > | > > | > | | | | < | | | | | | | | | | | < | | | | < | | | | | | | | | | | | | | | | | | | | | < | | | | < | | | | | | | | | | | | | | | < | < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | < | | | | < | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | < | | | | | | | | > | > > | | | | | | | | | > | | | | | > | | | | | | | | | | > | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | > | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | > > > | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | < | | < | | | | | | | | | | | > > > > | > > | | | > | | | > | > | > > | | | | | | | | | | | | | | | | | | | | | | > | | > > | | | | | | | | | | | | > | > | | | | > | > > | | | | | | | | | 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 | if (nested.tokenPtr != nested.staticTokens) { ckfree((char *) nested.tokenPtr); } /* * Check for the closing ']' that ends the command * substitution. It must have been the last character of the * parsed command. */ if ((nested.term < parsePtr->end) && (*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 == '\\') { if (noSubstBS) { tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; src++; numBytes--; continue; } /* * 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 { Tcl_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 function is invoked to free any dynamic storage that may have * been allocated by a previous call to Tcl_ParseCommand. * * Results: * None. * * Side effects: * If there is any dynamically allocated memory in *parsePtr, it is * freed. * *---------------------------------------------------------------------- */ void Tcl_FreeParse(parsePtr) Tcl_Parse *parsePtr; /* Structure that was filled in by a previous * call to Tcl_ParseCommand. */ { if (parsePtr->tokenPtr != parsePtr->staticTokens) { ckfree((char *) parsePtr->tokenPtr); parsePtr->tokenPtr = parsePtr->staticTokens; } } /* *---------------------------------------------------------------------- * * TclExpandTokenArray -- * * This function is invoked when the current space for tokens in a * Tcl_Parse structure fills up; it allocates memory to grow the token * array * * Results: * None. * * Side effects: * Memory is allocated for a new larger token array; the memory for the * old array is freed, if it had been dynamically allocated. * *---------------------------------------------------------------------- */ void TclExpandTokenArray(parsePtr) Tcl_Parse *parsePtr; /* Parse structure whose token space has * overflowed. */ { int newCount; Tcl_Token *newPtr; newCount = parsePtr->tokensAvailable*2; newPtr = (Tcl_Token *) ckalloc((unsigned) (newCount * sizeof(Tcl_Token))); memcpy((VOID *) newPtr, (VOID *) parsePtr->tokenPtr, (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 that was parsed. The "size" field of the first new * token gives the total number of bytes in the variable name. Other * fields in parsePtr are undefined. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the command, then additional space is malloc-ed. If the function * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) Tcl_Interp *interp; /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ CONST char *start; /* Start of variable substitution string. * 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) || (start == NULL)) { return TCL_ERROR; } if (numBytes < 0) { numBytes = strlen(start); } if (!append) { TclParseInit(interp, start, numBytes, parsePtr); } /* * Generate one token for the variable, an additional token for the name, * plus any number of additional tokens for the index, if there is one. */ src = start; if ((parsePtr->numTokens + 2) > parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } 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; /* * The name of the variable can have three forms: * 1. The $ sign is followed by an open curly brace. Then the variable * name is everything up to the next close curly brace, and the * variable is a scalar variable. * 2. The $ sign is not followed by an open curly brace. Then the * variable name is everything up to the next character that isn't a * letter, digit, or underscore. :: sequences are also considered part * of the variable name, in order to support namespaces. If the * following character is an open parenthesis, then the information * 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 (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, TCL_SUBST_ALL, parsePtr)) { 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; goto error; } src = parsePtr->term + 1; } } tokenPtr = &parsePtr->tokenPtr[varIndex]; tokenPtr->size = src - tokenPtr->start; tokenPtr->numComponents = parsePtr->numTokens - (varIndex + 1); return TCL_OK; /* * The dollar sign isn't followed by a variable name. Replace the * TCL_TOKEN_VARIABLE token with a TCL_TOKEN_TEXT token for the dollar * sign. */ justADollarSign: tokenPtr = &parsePtr->tokenPtr[varIndex]; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; 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. * * Results: * The return value is the contents of the variable given by the leading * characters of string. If termPtr isn't NULL, *termPtr gets filled in * with the address of the character just after the last one in the * variable specifier. If the variable doesn't exist, then the return * value is NULL and an error message will be left in interp's result. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_ParseVar(interp, start, termPtr) Tcl_Interp *interp; /* Context for looking up variable. */ register CONST char *start; /* Start of variable substitution. * 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; if (Tcl_ParseVarName(interp, start, -1, &parse, 0) != TCL_OK) { return NULL; } if (termPtr != NULL) { *termPtr = start + parse.tokenPtr->size; } if (parse.numTokens == 1) { /* * There isn't a variable name after all: the $ is just a $. */ return "$"; } code = TclSubstTokens(interp, parse.tokenPtr, parse.numTokens, NULL); if (code != TCL_OK) { return NULL; } objPtr = Tcl_GetObjResult(interp); /* * At this point we should have an object containing the value of a * variable. Just return the string from that object. * * This should have returned the object for the user to manage, but * instead we have some weak reference to the string value in the object, * which is why we make sure the object exists after resetting the result. * This isn't ideal, but it's the best we can do with the current * documented interface. -- hobbs */ 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 function 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 parsePtr are undefined. * termPtr is set to point to the character just after the last one in * the braced string. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the command, then additional space is malloc-ed. If the function * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int Tcl_ParseBraces(interp, start, numBytes, parsePtr, append, termPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ CONST char *start; /* Start of string enclosed 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) || (start == NULL)) { return TCL_ERROR; } if (numBytes < 0) { numBytes = strlen(start); } if (!append) { TclParseInit(interp, start, numBytes, parsePtr); } src = start; 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) { goto missingBraceError; } 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; } } missingBraceError: parsePtr->errorType = TCL_PARSE_MISSING_BRACE; parsePtr->term = start; 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. */ { register int openBrace = 0; for (; src > start; 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; } /* *---------------------------------------------------------------------- * * Tcl_ParseQuotedString -- * * Given a double-quoted string such as a quoted Tcl command argument or * a quoted value in a Tcl expression, this function 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 parsePtr are undefined. * termPtr is set to point to the character just after the quoted * string's terminating close-quote. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the command, then additional space is malloc-ed. If the function * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int Tcl_ParseQuotedString(interp, start, numBytes, parsePtr, append, termPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting; if * NULL, then no error message is provided. */ CONST char *start; /* Start of 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) || (start == NULL)) { return TCL_ERROR; } if (numBytes < 0) { numBytes = strlen(start); } if (!append) { TclParseInit(interp, start, numBytes, parsePtr); } if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL, parsePtr)) { goto error; } if (*parsePtr->term != '"') { if (interp != NULL) { Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC); } parsePtr->errorType = TCL_PARSE_MISSING_QUOTE; parsePtr->term = start; parsePtr->incomplete = 1; goto error; } if (termPtr != NULL) { *termPtr = (parsePtr->term + 1); } return TCL_OK; error: Tcl_FreeParse(parsePtr); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Tcl_SubstObj -- * * This function performs the substitutions specified on the given string * as described in the user documentation for the "subst" Tcl command. * * Results: * A Tcl_Obj* containing the substituted string, or NULL to indicate that * an error occurred. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_SubstObj(interp, objPtr, flags) Tcl_Interp *interp; /* Interpreter in which substitution occurs */ Tcl_Obj *objPtr; /* The value to be substituted. */ int flags; /* What substitutions to do. */ { int length, tokensLeft, code; Tcl_Parse parse; Tcl_Token *endTokenPtr; Tcl_Obj *result; Tcl_Obj *errMsg = NULL; CONST char *p = Tcl_GetStringFromObj(objPtr, &length); TclParseInit(interp, p, length, &parse); /* * First parse the string rep of objPtr, as if it were enclosed as a * "-quoted word in a normal Tcl command. Honor flags that selectively * inhibit types of substitution. */ if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, &parse)) { /* * There was a parse error. Save the error message for possible * reporting later. */ errMsg = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errMsg); /* * We need to re-parse to get the portion of the string we can [subst] * before the parse error. Sadly, all the Tcl_Token's created by the * first parse attempt are gone, freed according to the public spec * for the Tcl_Parse* routines. The only clue we have is parse.term, * which points to either the unmatched opener, or to characters that * follow a close brace or close quote. * * Call ParseTokens again, working on the string up to parse.term. * Keep repeating until we get a good parse on a prefix. */ do { parse.numTokens = 0; parse.tokensAvailable = NUM_STATIC_TOKENS; parse.end = parse.term; parse.incomplete = 0; parse.errorType = TCL_PARSE_SUCCESS; } while (TCL_OK != ParseTokens(p, parse.end - p, 0, flags, &parse)); /* * The good parse will have to be followed by {, (, or [. */ switch (*parse.term) { case '{': /* * Parse error was a missing } in a ${varname} variable * substitution at the toplevel. We will subst everything up to * that broken variable substitution before reporting the parse * error. Substituting the leftover '$' will have no side-effects, * so the current token stream is fine. */ break; case '(': /* * Parse error was during the parsing of the index part of an * array variable substitution at the toplevel. */ if (*(parse.term - 1) == '$') { /* * Special case where removing the array index left us with * just a dollar sign (array variable with name the empty * string as its name), instead of with a scalar variable * reference. * * As in the previous case, existing token stream is OK. */ } else { /* * The current parse includes a successful parse of a scalar * variable substitution where there should have been an array * variable substitution. We remove that mistaken part of the * parse before moving on. A scalar variable substitution is * two tokens. */ Tcl_Token *varTokenPtr = parse.tokenPtr + parse.numTokens - 2; if (varTokenPtr->type != TCL_TOKEN_VARIABLE) { Tcl_Panic("Tcl_SubstObj: programming error"); } if (varTokenPtr[1].type != TCL_TOKEN_TEXT) { Tcl_Panic("Tcl_SubstObj: programming error"); } parse.numTokens -= 2; } break; case '[': /* * Parse error occurred during parsing of a toplevel command * substitution. */ parse.end = p + length; p = parse.term + 1; length = parse.end - p; if (length == 0) { /* * No commands, just an unmatched [. As in previous cases, * existing token stream is OK. */ } else { /* * We want to add the parsing of as many commands as we can * within that substitution until we reach the actual parse * error. We'll do additional parsing to determine what * length to claim for the final TCL_TOKEN_COMMAND token. */ Tcl_Token *tokenPtr; Tcl_Parse nested; CONST char *lastTerm = parse.term; while (TCL_OK == Tcl_ParseCommand(NULL, p, length, 0, &nested)) { Tcl_FreeParse(&nested); p = nested.term + (nested.term < nested.end); length = nested.end - p; if ((length == 0) && (nested.term == nested.end)) { /* * If we run out of string, blame the missing close * bracket on the last command, and do not evaluate it * during substitution. */ break; } lastTerm = nested.term; } if (lastTerm == parse.term) { /* * Parse error in first command. No commands to subst, * add no more tokens. */ break; } /* * Create a command substitution token for whatever commands * got parsed. */ if (parse.numTokens == parse.tokensAvailable) { TclExpandTokenArray(&parse); } tokenPtr = &parse.tokenPtr[parse.numTokens]; tokenPtr->start = parse.term; tokenPtr->numComponents = 0; tokenPtr->type = TCL_TOKEN_COMMAND; tokenPtr->size = lastTerm - tokenPtr->start + 1; parse.numTokens++; } break; default: Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]); } } /* * Next, substitute the parsed tokens just as in normal Tcl evaluation. */ endTokenPtr = parse.tokenPtr + parse.numTokens; tokensLeft = parse.numTokens; code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, &tokensLeft); if (code == TCL_OK) { Tcl_FreeParse(&parse); if (errMsg != NULL) { Tcl_SetObjResult(interp, errMsg); Tcl_DecrRefCount(errMsg); return NULL; } return Tcl_GetObjResult(interp); } result = Tcl_NewObj(); while (1) { switch (code) { case TCL_ERROR: Tcl_FreeParse(&parse); Tcl_DecrRefCount(result); if (errMsg != NULL) { Tcl_DecrRefCount(errMsg); } return NULL; case TCL_BREAK: tokensLeft = 0; /* Halt substitution */ default: Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp)); } if (tokensLeft == 0) { Tcl_FreeParse(&parse); if (errMsg != NULL) { if (code != TCL_BREAK) { Tcl_DecrRefCount(result); Tcl_SetObjResult(interp, errMsg); Tcl_DecrRefCount(errMsg); return NULL; } Tcl_DecrRefCount(errMsg); } return result; } code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, &tokensLeft); } } /* *---------------------------------------------------------------------- * * TclSubstTokens -- * * Accepts an array of count Tcl_Token's, and creates a result value in * the interp from concatenating the results of performing Tcl * substitution on each Tcl_Token. Substitution is interrupted if any * non-TCL_OK completion code arises. * * Results: * The return value is a standard Tcl completion code. The result in * interp is the substituted value, or an error message if TCL_ERROR is * returned. If tokensLeftPtr is not NULL, then it points to an int where * the number of tokens remaining to be processed is written. * * Side effects: * Can be anything, depending on the types of substitution done. * *---------------------------------------------------------------------- */ int TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr) Tcl_Interp *interp; /* Interpreter in which to lookup variables, * execute nested commands, and report * errors. */ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens to * evaluate and concatenate. */ int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ int *tokensLeftPtr; /* If not NULL, points to memory where an * integer representing the number of tokens * left to be substituted will be written */ { Tcl_Obj *result; int code = TCL_OK; /* * Each pass through this loop will substitute one token, and its * components, if any. The only thing tricky here is that we go to some * effort to pass Tcl_Obj's through untouched, to avoid string copying and * Tcl_Obj creation if possible, to aid performance and limit shimmering. * * Further optimization opportunities might be to check for the equivalent * of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) and omit them. */ result = NULL; for (; count>0 && code==TCL_OK ; count--, tokenPtr++) { Tcl_Obj *appendObj = NULL; CONST char *append = NULL; int appendByteLength = 0; char utfCharBytes[TCL_UTF_MAX]; switch (tokenPtr->type) { case TCL_TOKEN_TEXT: append = tokenPtr->start; appendByteLength = tokenPtr->size; break; case TCL_TOKEN_BS: appendByteLength = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, utfCharBytes); append = utfCharBytes; break; case TCL_TOKEN_COMMAND: { Interp *iPtr = (Interp *) interp; iPtr->numLevels++; code = TclInterpReady(interp); if (code == TCL_OK) { code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, 0); } iPtr->numLevels--; appendObj = Tcl_GetObjResult(interp); break; } case TCL_TOKEN_VARIABLE: { Tcl_Obj *arrayIndex = NULL; Tcl_Obj *varName = NULL; if (tokenPtr->numComponents > 1) { /* * Subst the index part of an array variable reference. */ code = TclSubstTokens(interp, tokenPtr+2, tokenPtr->numComponents - 1, NULL); arrayIndex = Tcl_GetObjResult(interp); Tcl_IncrRefCount(arrayIndex); } if (code == TCL_OK) { varName = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); appendObj = Tcl_ObjGetVar2(interp, varName, arrayIndex, TCL_LEAVE_ERR_MSG); Tcl_DecrRefCount(varName); if (appendObj == NULL) { code = TCL_ERROR; } } switch (code) { case TCL_OK: /* Got value */ case TCL_ERROR: /* Already have error message */ case TCL_BREAK: /* Will not substitute anyway */ case TCL_CONTINUE: /* Will not substitute anyway */ break; default: /* * All other return codes, we will subst the result from the * code-throwing evaluation. */ appendObj = Tcl_GetObjResult(interp); } if (arrayIndex != NULL) { Tcl_DecrRefCount(arrayIndex); } count -= tokenPtr->numComponents; tokenPtr += tokenPtr->numComponents; break; } default: Tcl_Panic("unexpected token type in TclSubstTokens: %d", tokenPtr->type); } if ((code == TCL_BREAK) || (code == TCL_CONTINUE)) { /* * Inhibit substitution. */ continue; } if (result == NULL) { /* * First pass through. If we have a Tcl_Obj, just use it. If not, * create one from our string. */ if (appendObj != NULL) { result = appendObj; } else { result = Tcl_NewStringObj(append, appendByteLength); } Tcl_IncrRefCount(result); } else { /* * Subsequent passes. Append to result. */ if (Tcl_IsShared(result)) { Tcl_DecrRefCount(result); result = Tcl_DuplicateObj(result); Tcl_IncrRefCount(result); } if (appendObj != NULL) { Tcl_AppendObjToObj(result, appendObj); } else { Tcl_AppendToObj(result, append, appendByteLength); } } } if (code != TCL_ERROR) { /* Keep error message in result! */ if (result != NULL) { Tcl_SetObjResult(interp, result); } else { Tcl_ResetResult(interp); } } if (tokensLeftPtr != NULL) { *tokensLeftPtr = count; } if (result != NULL) { Tcl_DecrRefCount(result); } return code; } /* *---------------------------------------------------------------------- * * CommandComplete -- * * This function is shared by TclCommandComplete and * Tcl_ObjCommandComplete; it does all the real work of seeing whether a * script is complete * * Results: * 1 is returned if the script is complete, 0 if there are open * delimiters such as " or (. 1 is also returned if there is a parse * error in the script other than unmatched delimiters. * * 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; |
︙ | ︙ | |||
2145 2146 2147 2148 2149 2150 2151 | result = 0; } else { result = 1; } Tcl_FreeParse(&parse); return result; } | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > | 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 | result = 0; } else { result = 1; } Tcl_FreeParse(&parse); return result; } /* *---------------------------------------------------------------------- * * Tcl_CommandComplete -- * * Given a partial or complete Tcl script, this function determines * whether the script is complete in the sense of having matched braces * and quotes and brackets. * * Results: * 1 is returned if the script is complete, 0 otherwise. 1 is also * returned if there is a parse error in the script other than unmatched * delimiters. * * Side effects: * 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 function * determines whether the command is complete in the sense of having * matched braces and quotes and brackets. * * Results: * 1 is returned if the command is complete, 0 otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ 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. * * Results: * Returns 1 if the variable is a local scalar. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclIsLocalScalar(src, len) CONST char *src; int len; { CONST char *p; CONST char *lastChar = src + (len - 1); for (p=src ; p<=lastChar ; p++) { if ((CHAR_TYPE(*p) != TYPE_NORMAL) && (CHAR_TYPE(*p) != TYPE_COMMAND_END)) { /* * TCL_COMMAND_END is returned for the last character of the * string. By this point we know it isn't an array or namespace * reference. */ return 0; } if (*p == '(') { if (*lastChar == ')') { /* we have an array element */ return 0; } } else if (*p == ':') { if ((p != lastChar) && *(p+1) == ':') { /* qualified name */ return 0; } } } return 1; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclParseExpr.c.
|
| | | | | < | | | < < < < < < < < < < < < < < < | < | | < | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | /* * tclParseExpr.c -- * * This file contains functions 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.23.2.12 2005/08/23 18:28:51 kennykb Exp $ */ #include "tclInt.h" /* * Boolean variable that controls whether expression parse tracing is enabled. */ #ifdef TCL_COMPILE_DEBUG static int traceParseExpr = 0; #endif /* TCL_COMPILE_DEBUG */ /* * The ParseInfo structure holds state while parsing an expression. A pointer * to an ParseInfo record is passed among the routines in this module. */ 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. * * Basic lexemes: */ #define LITERAL 0 #define FUNC_NAME 1 #define OPEN_BRACKET 2 |
︙ | ︙ | |||
137 138 139 140 141 142 143 | * List containment operators */ #define IN_LIST 37 #define NOT_IN_LIST 38 /* | | | | | < < | | | | | | | | > > > | | | | | < | | | | < | | | < | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | 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 | * List containment operators */ #define IN_LIST 37 #define NOT_IN_LIST 38 /* * Mapping from lexemes to strings; used for debugging messages. These entries * must match the order and number of the lexeme definitions above. */ static char *lexemeStrings[] = { "LITERAL", "FUNCNAME", "[", "{", "(", ")", "$", "\"", ",", "END", "UNKNOWN", "UNKNOWN_CHAR", "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=", ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":", "!", "~", "eq", "ne", "**", "in", "ni" }; /* * Declarations for local functions 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 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 ParseExponentialExpr _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. */ #ifdef TCL_COMPILE_DEBUG #define HERE(production, level) \ if (traceParseExpr) { \ fprintf(stderr, "%*s%s: lexeme=%s, next=\"%.20s\"\n", \ (level), " ", (production), \ lexemeStrings[infoPtr->lexeme], infoPtr->next); \ } #else #define HERE(production, level) #endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_ParseExpr -- * * Given a string, this function parses the first Tcl expression in the * string and returns information about the structure of the expression. * This function is the top-level interface to the the expression parsing * module. No more than numBytes bytes will be scanned. * * Note that this parser is a LL(1) parser; the operator precedence rules * are completely hard coded in the recursive structure of the parser * itself. * * 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. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the expression, then additional space is malloc-ed. If the * function returns TCL_OK then the caller must eventually invoke * Tcl_FreeParse to release any additional space that was allocated. * *---------------------------------------------------------------------- */ int Tcl_ParseExpr(interp, start, numBytes, parsePtr) Tcl_Interp *interp; /* Used for error reporting. */ CONST char *start; /* Start of 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 = (start? strlen(start) : 0); } #ifdef TCL_COMPILE_DEBUG if (traceParseExpr) { fprintf(stderr, "Tcl_ParseExpr: string=\"%.*s\"\n", numBytes, start); } #endif /* TCL_COMPILE_DEBUG */ TclParseInit(interp, start, numBytes, parsePtr); /* * Initialize the ParseInfo structure that holds state while parsing the * expression. */ info.parsePtr = parsePtr; info.lexeme = UNKNOWN; info.start = NULL; info.size = 0; info.next = start; info.prevEnd = start; info.originalExpr = start; info.lastChar = (start + numBytes); /* just after last char of expr */ /* * Get the first lexeme then parse the expression. */ code = GetLexeme(&info); if (code != TCL_OK) { goto error; } code = ParseCondExpr(&info); 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 function 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 function * call since such a function would only return the result of calling * ParseCondExpr. Other recursive-descent functions 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int 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) { return code; } if (infoPtr->lexeme == QUESTY) { /* * Emit two tokens: one TCL_TOKEN_SUB_EXPR token for the entire * conditional expression, and a TCL_TOKEN_OPERATOR token for the "?" * operator. Note that these two tokens must be inserted before the * LOR operand tokens generated above. */ if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } firstTokenPtr = &parsePtr->tokenPtr[firstIndex]; tokenPtr = (firstTokenPtr + 2); numToMove = (parsePtr->numTokens - firstIndex); memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr, (size_t) (numToMove * sizeof(Tcl_Token))); parsePtr->numTokens += 2; tokenPtr = firstTokenPtr; tokenPtr->type = TCL_TOKEN_SUB_EXPR; tokenPtr->start = srcStart; tokenPtr++; tokenPtr->type = TCL_TOKEN_OPERATOR; tokenPtr->start = infoPtr->start; tokenPtr->size = 1; tokenPtr->numComponents = 0; /* * Skip over the '?'. */ code = GetLexeme(infoPtr); if (code != TCL_OK) { return code; } /* * Parse the "then" expression. */ |
︙ | ︙ | |||
412 413 414 415 416 417 418 | } /* *---------------------------------------------------------------------- * * ParseLorExpr -- * | | | | | | < | | | | | 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 | } /* *---------------------------------------------------------------------- * * ParseLorExpr -- * * This function parses a Tcl logical or expression: * lorExpr ::= landExpr {'||' landExpr} * * 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ 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) { return code; } while (infoPtr->lexeme == OR) { operator = infoPtr->start; |
︙ | ︙ | |||
462 463 464 465 466 467 468 | } /* * Generate tokens for the LOR subexpression and the '||' operator. */ PrependSubExprTokens(operator, 2, srcStart, | | | | | | | < | | | | 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 | } /* * Generate tokens for the LOR subexpression and the '||' operator. */ PrependSubExprTokens(operator, 2, srcStart, (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseLandExpr -- * * This function parses a Tcl logical and expression: * landExpr ::= bitOrExpr {'&&' bitOrExpr} * * 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ 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) { return code; } while (infoPtr->lexeme == AND) { operator = infoPtr->start; |
︙ | ︙ | |||
522 523 524 525 526 527 528 | } /* * Generate tokens for the LAND subexpression and the '&&' operator. */ PrependSubExprTokens(operator, 2, srcStart, | | | | | | | < | | | | | | | | | | | < | | | | | | | | | | | < | | | | | | | | | | | < | | | | 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 | } /* * Generate tokens for the LAND subexpression and the '&&' operator. */ PrependSubExprTokens(operator, 2, srcStart, (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseBitOrExpr -- * * This function parses a Tcl bitwise or expression: * bitOrExpr ::= bitXorExpr {'|' bitXorExpr} * * 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ 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) { return code; } while (infoPtr->lexeme == BIT_OR) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over the '|' */ if (code != TCL_OK) { return code; } code = ParseBitXorExpr(infoPtr); if (code != TCL_OK) { return code; } /* * Generate tokens for the BITOR subexpression and the '|' operator. */ PrependSubExprTokens(operator, 1, srcStart, (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseBitXorExpr -- * * This function parses a Tcl bitwise exclusive or expression: * bitXorExpr ::= bitAndExpr {'^' bitAndExpr} * * 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ 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) { return code; } while (infoPtr->lexeme == BIT_XOR) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over the '^' */ if (code != TCL_OK) { return code; } code = ParseBitAndExpr(infoPtr); if (code != TCL_OK) { return code; } /* * Generate tokens for the XOR subexpression and the '^' operator. */ PrependSubExprTokens(operator, 1, srcStart, (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseBitAndExpr -- * * This function parses a Tcl bitwise and expression: * bitAndExpr ::= equalityExpr {'&' equalityExpr} * * 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ 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) { return code; } while (infoPtr->lexeme == BIT_AND) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over the '&' */ if (code != TCL_OK) { return code; } code = ParseEqualityExpr(infoPtr); if (code != TCL_OK) { return code; } /* * Generate tokens for the BITAND subexpression and '&' operator. */ PrependSubExprTokens(operator, 1, srcStart, (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseEqualityExpr -- * * This function parses a Tcl equality (inequality) expression: * equalityExpr ::= relationalExpr * {('==' | '!=' | 'ne' | 'eq') relationalExpr} * * 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ 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) { return code; } lexeme = infoPtr->lexeme; while (lexeme == EQUAL || lexeme == NEQ || lexeme == NOT_IN_LIST || |
︙ | ︙ | |||
768 769 770 771 772 773 774 | /* * Generate tokens for the subexpression and '==', '!=', 'eq' or 'ne' * operator. */ PrependSubExprTokens(operator, 2, srcStart, | | | | | | | < | | | | | | | | | | < | | | | | | | | | | < | | | | 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 | /* * Generate tokens for the subexpression and '==', '!=', 'eq' or 'ne' * operator. */ PrependSubExprTokens(operator, 2, srcStart, (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseRelationalExpr -- * * This function parses a Tcl relational expression: * relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr} * * 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ 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) { return code; } lexeme = infoPtr->lexeme; while ((lexeme == LESS) || (lexeme == GREATER) || (lexeme == LEQ) || (lexeme == GEQ)) { operator = infoPtr->start; if ((lexeme == LEQ) || (lexeme == GEQ)) { operatorSize = 2; } else { operatorSize = 1; } code = GetLexeme(infoPtr); /* skip over the operator */ if (code != TCL_OK) { return code; } code = ParseShiftExpr(infoPtr); if (code != TCL_OK) { return code; } /* * Generate tokens for the subexpression and the operator. */ PrependSubExprTokens(operator, operatorSize, srcStart, (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseShiftExpr -- * * This function parses a Tcl shift expression: * shiftExpr ::= addExpr {('<<' | '>>') addExpr} * * 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ 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) { return code; } lexeme = infoPtr->lexeme; while ((lexeme == LEFT_SHIFT) || (lexeme == RIGHT_SHIFT)) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over << or >> */ if (code != TCL_OK) { return code; } code = ParseAddExpr(infoPtr); if (code != TCL_OK) { return code; } /* * Generate tokens for the subexpression and '<<' or '>>' operator. */ PrependSubExprTokens(operator, 2, srcStart, (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseAddExpr -- * * This function parses a Tcl addition expression: * addExpr ::= multiplyExpr {('+' | '-') multiplyExpr} * * 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ 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) { return code; } lexeme = infoPtr->lexeme; while ((lexeme == PLUS) || (lexeme == MINUS)) { |
︙ | ︙ | |||
960 961 962 963 964 965 966 | } /* * Generate tokens for the subexpression and '+' or '-' operator. */ PrependSubExprTokens(operator, 1, srcStart, | | | | | | | < | | | | | | | | | | < | | | 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 | } /* * Generate tokens for the subexpression and '+' or '-' operator. */ PrependSubExprTokens(operator, 1, srcStart, (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseMultiplyExpr -- * * This function parses a Tcl multiply expression: * multiplyExpr ::= exponentialExpr {('*' | '/' | '%') exponentialExpr} * * 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ 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 = ParseExponentialExpr(infoPtr); if (code != TCL_OK) { return code; } lexeme = infoPtr->lexeme; while ((lexeme == MULT) || (lexeme == DIVIDE) || (lexeme == MOD)) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over * or / or % */ if (code != TCL_OK) { return code; } code = ParseExponentialExpr(infoPtr); if (code != TCL_OK) { return code; } /* * Generate tokens for the subexpression and * or / or % operator. */ PrependSubExprTokens(operator, 1, srcStart, (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseExponentialExpr -- * * This function parses a Tcl exponential expression: * exponentialExpr ::= unaryExpr {'**' unaryExpr} * * 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParseExponentialExpr(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("exponentiateExpr", 12); srcStart = infoPtr->start; |
︙ | ︙ | |||
1089 1090 1091 1092 1093 1094 1095 | PrependSubExprTokens(operator, 2, srcStart, (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; } | < | | | | | < | | | | | | | | | | < | | | 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 | PrependSubExprTokens(operator, 2, srcStart, (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); lexeme = infoPtr->lexeme; } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParseUnaryExpr -- * * This function parses a Tcl unary expression: * unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr * * 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ 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", 13); srcStart = infoPtr->start; firstIndex = parsePtr->numTokens; lexeme = infoPtr->lexeme; if ((lexeme == PLUS) || (lexeme == MINUS) || (lexeme == BIT_NOT) || (lexeme == NOT)) { operator = infoPtr->start; code = GetLexeme(infoPtr); /* skip over the unary operator */ if (code != TCL_OK) { return code; } code = ParseUnaryExpr(infoPtr); if (code != TCL_OK) { return code; } /* * Generate tokens for the subexpression and the operator. */ PrependSubExprTokens(operator, 1, srcStart, (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); } else { /* must be a primaryExpr */ code = ParsePrimaryExpr(infoPtr); if (code != TCL_OK) { return code; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * ParsePrimaryExpr -- * * This function parses a Tcl primary expression: * primaryExpr ::= literal | varReference | quotedString | * '[' command ']' | mathFuncCall | '(' condExpr ')' * * 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 * contains an error message. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed. * *---------------------------------------------------------------------- */ static int ParsePrimaryExpr(infoPtr) 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; |
︙ | ︙ | |||
1228 1229 1230 1231 1232 1233 1234 | exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->type = TCL_TOKEN_SUB_EXPR; exprTokenPtr->start = infoPtr->start; parsePtr->numTokens++; /* * Process the primary then finish setting the fields of the | | | | | > | | | | | | | | | | | | | | | | | 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 | exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->type = TCL_TOKEN_SUB_EXPR; exprTokenPtr->start = infoPtr->start; parsePtr->numTokens++; /* * Process the primary then finish setting the fields of the * TCL_TOKEN_SUB_EXPR token. Note that we can't use the pointer now stored * in "exprTokenPtr" in the code below since the token array might be * reallocated. */ firstIndex = parsePtr->numTokens; switch (lexeme) { case LITERAL: /* * Int or double number. */ tokenizeLiteral: if (parsePtr->numTokens == parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = infoPtr->start; tokenPtr->size = infoPtr->size; tokenPtr->numComponents = 0; parsePtr->numTokens++; exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->size = infoPtr->size; exprTokenPtr->numComponents = 1; break; case DOLLAR: /* * $var variable reference. */ dollarPtr = (infoPtr->next - 1); code = Tcl_ParseVarName(interp, dollarPtr, (infoPtr->lastChar - dollarPtr), parsePtr, 1); if (code != TCL_OK) { return code; } infoPtr->next = dollarPtr + parsePtr->tokenPtr[firstIndex].size; exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->size = parsePtr->tokenPtr[firstIndex].size; exprTokenPtr->numComponents = (parsePtr->tokenPtr[firstIndex].numComponents + 1); break; case QUOTE: /* * '"' string '"' */ stringStart = infoPtr->next; code = Tcl_ParseQuotedString(interp, infoPtr->start, (infoPtr->lastChar - stringStart), parsePtr, 1, &termPtr); if (code != TCL_OK) { return code; } infoPtr->next = termPtr; exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->size = (termPtr - exprTokenPtr->start); exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex; /* * If parsing the quoted string resulted in more than one token, * insert a TCL_TOKEN_WORD token before them. This indicates that the * quoted string represents a concatenation of multiple tokens. */ if (exprTokenPtr->numComponents > 1) { if (parsePtr->numTokens >= parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } tokenPtr = &parsePtr->tokenPtr[firstIndex]; numToMove = (parsePtr->numTokens - firstIndex); memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr, (size_t) (numToMove * sizeof(Tcl_Token))); parsePtr->numTokens++; exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->numComponents++; tokenPtr->type = TCL_TOKEN_WORD; tokenPtr->start = exprTokenPtr->start; tokenPtr->size = exprTokenPtr->size; tokenPtr->numComponents = (exprTokenPtr->numComponents - 1); } break; case OPEN_BRACKET: /* * '[' command {command} ']' */ if (parsePtr->numTokens == parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; tokenPtr->type = TCL_TOKEN_COMMAND; tokenPtr->start = infoPtr->start; tokenPtr->numComponents = 0; parsePtr->numTokens++; /* * Call Tcl_ParseCommand repeatedly to parse the nested command(s) to * find their end, then throw away that parse information. */ src = infoPtr->next; while (1) { if (Tcl_ParseCommand(interp, src, (parsePtr->end - src), 1, &nested) != TCL_OK) { parsePtr->term = nested.term; parsePtr->errorType = nested.errorType; parsePtr->incomplete = nested.incomplete; return TCL_ERROR; } src = (nested.commandStart + nested.commandSize); /* * This is equivalent to Tcl_FreeParse(&nested), but presumably * inlined here for sake of runtime optimization */ if (nested.tokenPtr != nested.staticTokens) { ckfree((char *) nested.tokenPtr); } /* * Check for the closing ']' that ends the command substitution. * It must have been the last character of the parsed command. */ if ((nested.term < parsePtr->end) && (*nested.term == ']') && !nested.incomplete) { break; } if (src == parsePtr->end) { if (parsePtr->interp != NULL) { Tcl_SetResult(interp, "missing close-bracket", TCL_STATIC); |
︙ | ︙ | |||
1390 1391 1392 1393 1394 1395 1396 | case OPEN_BRACE: /* * '{' string '}' */ code = Tcl_ParseBraces(interp, infoPtr->start, | | < | | | | | > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | > > | | > | | | | | | | | | | | | | | | | | < < | | | > > | > > | | | | < | < < < | < < | < < < | < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < | < < < < < < | < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | > | | | | > | | | | | | | | | < < < < < < < < | | < < < < | | | < < < < < < < < < < | < < < < < < | < < < < < < < < < < < < < < < | | | | | | > | > > > > | | > | > > | | | | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | | | | | | > > > > > > > > | 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 | case OPEN_BRACE: /* * '{' string '}' */ code = Tcl_ParseBraces(interp, infoPtr->start, (infoPtr->lastChar - infoPtr->start), parsePtr, 1, &termPtr); if (code != TCL_OK) { return code; } infoPtr->next = termPtr; exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->size = (termPtr - infoPtr->start); exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex; /* * If parsing the braced string resulted in more than one token, * insert a TCL_TOKEN_WORD token before them. This indicates that the * braced string represents a concatenation of multiple tokens. */ if (exprTokenPtr->numComponents > 1) { if (parsePtr->numTokens >= parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } tokenPtr = &parsePtr->tokenPtr[firstIndex]; numToMove = (parsePtr->numTokens - firstIndex); memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr, (size_t) (numToMove * sizeof(Tcl_Token))); parsePtr->numTokens++; exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->numComponents++; tokenPtr->type = TCL_TOKEN_WORD; tokenPtr->start = exprTokenPtr->start; tokenPtr->size = exprTokenPtr->size; tokenPtr->numComponents = exprTokenPtr->numComponents-1; } break; case STREQ: case STRNEQ: case IN_LIST: case NOT_IN_LIST: case FUNC_NAME: { /* * math_func '(' expr {',' expr} ')' */ ParseInfo savedInfo = *infoPtr; code = GetLexeme(infoPtr); /* skip over function name */ if (code != TCL_OK) { return code; } if (infoPtr->lexeme != OPEN_PAREN) { int code; Tcl_Obj *errMsg, *objPtr = Tcl_NewStringObj(savedInfo.start, savedInfo.size); /* * Check for boolean literals (true, false, yes, no, on, off). */ Tcl_IncrRefCount(objPtr); code = Tcl_ConvertToType(NULL, objPtr, &tclBooleanType); Tcl_DecrRefCount(objPtr); if (code == TCL_OK) { *infoPtr = savedInfo; goto tokenizeLiteral; } /* * Either there's a math function without a (, or a variable name * without a '$'. */ errMsg = Tcl_NewStringObj( "syntax error in expression \"", -1 ); TclAppendLimitedToObj(errMsg, infoPtr->originalExpr, (int) (infoPtr->lastChar - infoPtr->originalExpr), 63, NULL); Tcl_AppendToObj(errMsg, "\": the word \"", -1); Tcl_AppendToObj(errMsg, savedInfo.start, savedInfo.size); Tcl_AppendToObj(errMsg, "\" requires a preceding $ if it's a variable ", -1); Tcl_AppendToObj(errMsg, "or function arguments if it's a function", -1); Tcl_SetObjResult(infoPtr->parsePtr->interp, errMsg); infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX; infoPtr->parsePtr->term = infoPtr->start; return TCL_ERROR; } if (parsePtr->numTokens == parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; tokenPtr->type = TCL_TOKEN_OPERATOR; tokenPtr->start = savedInfo.start; tokenPtr->size = savedInfo.size; tokenPtr->numComponents = 0; parsePtr->numTokens++; code = GetLexeme(infoPtr); /* skip over '(' */ if (code != TCL_OK) { return code; } while (infoPtr->lexeme != CLOSE_PAREN) { code = ParseCondExpr(infoPtr); if (code != TCL_OK) { return code; } if (infoPtr->lexeme == COMMA) { code = GetLexeme(infoPtr); /* skip over , */ if (code != TCL_OK) { return code; } } else if (infoPtr->lexeme != CLOSE_PAREN) { LogSyntaxError(infoPtr, "missing close parenthesis at end of function call"); return TCL_ERROR; } } exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; exprTokenPtr->size = (infoPtr->next - exprTokenPtr->start); exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex; break; } case COMMA: LogSyntaxError(infoPtr, "commas can only separate function arguments"); return TCL_ERROR; case END: LogSyntaxError(infoPtr, "premature end of expression"); return TCL_ERROR; case UNKNOWN: LogSyntaxError(infoPtr, "single equality character not legal in expressions"); return TCL_ERROR; case UNKNOWN_CHAR: LogSyntaxError(infoPtr, "character not legal in expressions"); return TCL_ERROR; case QUESTY: LogSyntaxError(infoPtr, "unexpected ternary 'then' separator"); return TCL_ERROR; case COLON: LogSyntaxError(infoPtr, "unexpected ternary 'else' separator"); return TCL_ERROR; case CLOSE_PAREN: LogSyntaxError(infoPtr, "unexpected close parenthesis"); return TCL_ERROR; default: { char buf[64]; sprintf(buf, "unexpected operator %s", lexemeStrings[lexeme]); LogSyntaxError(infoPtr, buf); return TCL_ERROR; } } /* * Advance to the next lexeme before returning. */ code = GetLexeme(infoPtr); if (code != TCL_OK) { return code; } parsePtr->term = infoPtr->next; return TCL_OK; } /* *---------------------------------------------------------------------- * * GetLexeme -- * * Lexical scanner for Tcl expressions: scans a single operator or other * syntactic element from an expression string. * * Results: * TCL_OK is returned unless an error occurred. In that case a standard * Tcl error code is returned and, if infoPtr->parsePtr->interp is * non-NULL, the interpreter's result is set to hold an error message. * TCL_ERROR is returned if an integer overflow, or a floating-point * overflow or underflow occurred while reading in a number. If the * lexical analysis is successful, infoPtr->lexeme refers to the next * symbol in the expression string, and infoPtr->next is advanced past * the lexeme. Also, if the lexeme is a LITERAL or FUNC_NAME, then * infoPtr->start is set to the first character of the lexeme; otherwise * it is set NULL. * * Side effects: * If there is insufficient space in parsePtr to hold all the information * about the subexpression, then additional space is malloc-ed.. * *---------------------------------------------------------------------- */ 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_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; CONST char* end2; int code = TclParseNumber(NULL, NULL, NULL, src, (unsigned)(end-src), &end2, 0); if ( code == TCL_OK ) { length = end2-src; if ( length > 0 ) { infoPtr->lexeme = LITERAL; infoPtr->start = src; infoPtr->size = length; infoPtr->next = (src + length); parsePtr->term = infoPtr->next; return TCL_OK; } } } /* * Not an integer or double literal. Initialize the lexeme's fields * assuming the common case of a single character lexeme. */ infoPtr->start = src; infoPtr->size = 1; infoPtr->next = src+1; parsePtr->term = infoPtr->next; switch (*src) { case '[': infoPtr->lexeme = OPEN_BRACKET; return TCL_OK; case '{': infoPtr->lexeme = OPEN_BRACE; return TCL_OK; case '(': infoPtr->lexeme = OPEN_PAREN; return TCL_OK; case ')': infoPtr->lexeme = CLOSE_PAREN; return TCL_OK; case '$': infoPtr->lexeme = DOLLAR; return TCL_OK; case '\"': infoPtr->lexeme = QUOTE; return TCL_OK; case ',': infoPtr->lexeme = COMMA; return TCL_OK; case '*': infoPtr->lexeme = MULT; if ((infoPtr->lastChar - src)>1 && src[1]=='*') { infoPtr->lexeme = EXPON; infoPtr->size = 2; infoPtr->next = src+2; parsePtr->term = infoPtr->next; } return TCL_OK; case '/': infoPtr->lexeme = DIVIDE; return TCL_OK; case '%': infoPtr->lexeme = MOD; return TCL_OK; case '+': infoPtr->lexeme = PLUS; return TCL_OK; case '-': infoPtr->lexeme = MINUS; return TCL_OK; case '?': infoPtr->lexeme = QUESTY; 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->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { 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->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { infoPtr->lexeme = STRNEQ; infoPtr->size = 2; infoPtr->next = src+2; parsePtr->term = infoPtr->next; return TCL_OK; } else if ((src[1] == 'i') && ((infoPtr->lastChar - src) > 1) && (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { infoPtr->lexeme = NOT_IN_LIST; infoPtr->size = 2; infoPtr->next = src+2; parsePtr->term = infoPtr->next; return TCL_OK; } else { goto checkFuncName; } case 'i': if ((src[1] == 'n') && ((infoPtr->lastChar - src) > 1) && (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) { infoPtr->lexeme = IN_LIST; 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; return TCL_OK; } infoPtr->lexeme = UNKNOWN_CHAR; return TCL_OK; } } #if 0 /* *---------------------------------------------------------------------- * * 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; } /* * Recognize the 0 as valid integer, but x is left behind. */ return 1; } 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; } #endif /* *---------------------------------------------------------------------- * * PrependSubExprTokens -- * * This function 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. */ { Tcl_Parse *parsePtr = infoPtr->parsePtr; Tcl_Token *tokenPtr, *firstTokenPtr; int numToMove; if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } firstTokenPtr = &parsePtr->tokenPtr[firstIndex]; tokenPtr = (firstTokenPtr + 2); numToMove = (parsePtr->numTokens - firstIndex); memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr, (size_t) (numToMove * sizeof(Tcl_Token))); parsePtr->numTokens += 2; tokenPtr = firstTokenPtr; tokenPtr->type = TCL_TOKEN_SUB_EXPR; tokenPtr->start = src; tokenPtr->size = srcBytes; tokenPtr->numComponents = parsePtr->numTokens - (firstIndex + 1); tokenPtr++; tokenPtr->type = TCL_TOKEN_OPERATOR; tokenPtr->start = op; tokenPtr->size = opBytes; tokenPtr->numComponents = 0; } /* *---------------------------------------------------------------------- * * LogSyntaxError -- * * This function is invoked after an error occurs when parsing an * expression. It sets the interpreter result to an error message * describing the error. * * Results: * None. * * Side effects: * Sets the interpreter result to an error message describing the * expression that was being parsed when the error occurred, and why the * parser considers that to be a syntax error at all. * *---------------------------------------------------------------------- */ 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. */ { Tcl_Obj *result = Tcl_NewStringObj("syntax error in expression \"", -1); TclAppendLimitedToObj(result, infoPtr->originalExpr, (int)(infoPtr->lastChar - infoPtr->originalExpr), 63, NULL); Tcl_AppendStringsToObj(result, "\": ", extraInfo, (char *) NULL); Tcl_SetObjResult(infoPtr->parsePtr->interp, result); infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX; infoPtr->parsePtr->term = infoPtr->start; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclPathObj.c.
|
| | | | | | | | | | | | | | | | | < | | | | | | | | | | | < | | > | | | | | | | < | | | | | < | | | | | | | < | | | | | | | | | | | | | < | | | | | | < | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | < | > | | | | | | < | | | > | > > > > | > > | | | | < | | | < | > | | | > > | > > > > | > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 | /* * tclPathObj.c -- * * This file contains the implementation of Tcl's "path" object type used * to represent and manipulate a general (virtual) filesystem entity in * an efficient manner. * * Copyright (c) 2003 Vince Darley. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclPathObj.c,v 1.38.2.5 2005/08/15 18:13:59 dgp Exp $ */ #include "tclInt.h" #include "tclFileSystem.h" /* * Prototypes for functions defined later in this file. */ static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *pathPtr)); static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *pathPtr)); static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); static int FindSplitPos _ANSI_ARGS_((CONST char *path, int separator)); static int IsSeparatorOrNull _ANSI_ARGS_((int ch)); static Tcl_Obj* GetExtension _ANSI_ARGS_((Tcl_Obj *pathPtr)); /* * Define the 'path' object type, which Tcl uses to represent file paths * internally. */ Tcl_ObjType tclFsPathType = { "path", /* name */ FreeFsPathInternalRep, /* freeIntRepProc */ DupFsPathInternalRep, /* dupIntRepProc */ UpdateStringOfFsPath, /* updateStringProc */ SetFsPathFromAny /* setFromAnyProc */ }; /* * struct FsPath -- * * Internal representation of a Tcl_Obj of "path" type. This can be used to * represent relative or absolute paths, and has certain optimisations when * used to represent paths which are already normalized and absolute. * * Note that both 'translatedPathPtr' and 'normPathPtr' can be a circular * reference to the container Tcl_Obj of this FsPath. * * There are two cases, with the first being the most common: * * (i) flags == 0, => Ordinary path. * * translatedPathPtr contains the translated path (which may be a circular * reference to the object itself). If it is NULL then the path is pure * normalized (and the normPathPtr will be a circular reference). cwdPtr is * null for an absolute path, and non-null for a relative path (unless the cwd * has never been set, in which case the cwdPtr may also be null for a * relative path). * * (ii) flags != 0, => Special path, see TclNewFSPathObj * * Now, this is a path like 'file join $dir $tail' where, cwdPtr is the $dir * and normPathPtr is the $tail. * */ typedef struct FsPath { Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. If this * is NULL, then this is a pure normalized, * absolute path object, in which the parent * Tcl_Obj's string rep is already both * translated and normalized. */ Tcl_Obj *normPathPtr; /* Normalized absolute path, without ., .. or * ~user sequences. If the Tcl_Obj containing * this FsPath is already normalized, this may * be a circular reference back to the * container. If that is NOT the case, we have * a refCount on the object. */ Tcl_Obj *cwdPtr; /* If null, path is absolute, else this points * to the cwd object used for this path. We * have a refCount on the object. */ int flags; /* Flags to describe interpretation - see * below. */ ClientData nativePathPtr; /* Native representation of this path, which * is filesystem dependent. */ int filesystemEpoch; /* Used to ensure the path representation was * generated during the correct filesystem * epoch. The epoch changes when * filesystem-mounts are changed. */ struct FilesystemRecord *fsRecPtr; /* Pointer to the filesystem record entry to * use for this path. */ } FsPath; /* * Flag values for FsPath->flags. */ #define TCLPATH_APPENDED 1 /* * Define some macros to give us convenient access to path-object specific * fields. */ #define PATHOBJ(pathPtr) (pathPtr->internalRep.otherValuePtr) #define PATHFLAGS(pathPtr) \ (((FsPath*)(pathPtr->internalRep.otherValuePtr))->flags) /* *--------------------------------------------------------------------------- * * TclFSNormalizeAbsolutePath -- * * Takes an absolute path specification and computes a 'normalized' path * from it. * * A normalized path is one which has all '../', './' removed. Also it * is one which is in the 'standard' format for the native platform. On * Unix, this means the path must be free of symbolic links/aliases, and * on Windows it means we want the long form, with that long form's * case-dependence (which gives us a unique, case-dependent path). * * The behaviour of this function if passed a non-absolute path is NOT * defined. * * pathPtr may have a refCount of zero, or may be a shared object. * * Results: * The result is returned in a Tcl_Obj with a refCount of 1, which is * therefore owned by the caller. It must be freed (with * Tcl_DecrRefCount) by the caller when no longer needed. * * Side effects: * None (beyond the memory allocation for the result). * * Special note: * This code was originally based on code from Matt Newman and * Jean-Claude Wippler, but has since been totally rewritten by Vince * Darley to deal with symbolic links. * *--------------------------------------------------------------------------- */ Tcl_Obj* TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) Tcl_Interp* interp; /* Interpreter to use */ Tcl_Obj *pathPtr; /* Absolute path to normalize */ ClientData *clientDataPtr; /* If non-NULL, then may be set to the * fs-specific clientData for this path. This * will happen when that extra information can * be calculated efficiently as a side-effect * of normalization. */ { ClientData clientData = NULL; CONST char *dirSep, *oldDirSep; int first = 1; /* Set to zero once we've passed the first * directory separator - we can't use '..' to * remove the volume in a path. */ Tcl_Obj *retVal = NULL; dirSep = TclGetString(pathPtr); if (tclPlatform == TCL_PLATFORM_WINDOWS) { if (dirSep[0] != 0 && dirSep[1] == ':' && (dirSep[2] == '/' || dirSep[2] == '\\')) { /* Do nothing */ } else if ((dirSep[0] == '/' || dirSep[0] == '\\') && (dirSep[1] == '/' || dirSep[1] == '\\')) { /* * UNC style path, where we must skip over the first separator, * since the first two segments are actually inseparable. */ dirSep += 2; dirSep += FindSplitPos(dirSep, '/'); if (*dirSep != 0) { dirSep++; } } } /* * Scan forward from one directory separator to the next, checking for * '..' and '.' sequences which must be handled specially. In particular * handling of '..' can be complicated if the directory before is a link, * since we will have to expand the link to be able to back up one level. */ while (*dirSep != 0) { oldDirSep = dirSep; if (!first) { dirSep++; } dirSep += FindSplitPos(dirSep, '/'); if (dirSep[0] == 0 || dirSep[1] == 0) { if (retVal != NULL) { Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep); } break; } if (dirSep[1] == '.') { if (retVal != NULL) { Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep); oldDirSep = dirSep; } again: if (IsSeparatorOrNull(dirSep[2])) { /* * Need to skip '.' in the path. */ if (retVal == NULL) { CONST char *path = TclGetString(pathPtr); retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } dirSep += 2; oldDirSep = dirSep; if (dirSep[0] != 0 && dirSep[1] == '.') { goto again; } continue; } if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) { Tcl_Obj *link; int curLen; char *linkStr; /* * Have '..' so need to skip previous directory. */ if (retVal == NULL) { CONST char *path = TclGetString(pathPtr); retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) { link = Tcl_FSLink(retVal, NULL, 0); if (link != NULL) { /* * Got a link. Need to check if the link is relative * or absolute, for those platforms where relative * links exist. */ if (tclPlatform != TCL_PLATFORM_WINDOWS && Tcl_FSGetPathType(link) == TCL_PATH_RELATIVE) { /* * We need to follow this link which is relative * to retVal's directory. This means concatenating * the link onto the directory of the path so far. */ CONST char *path = Tcl_GetStringFromObj(retVal, &curLen); while (--curLen >= 0) { if (IsSeparatorOrNull(path[curLen])) { break; } } if (Tcl_IsShared(retVal)) { TclDecrRefCount(retVal); retVal = Tcl_DuplicateObj(retVal); Tcl_IncrRefCount(retVal); } /* * We want the trailing slash. */ Tcl_SetObjLength(retVal, curLen+1); Tcl_AppendObjToObj(retVal, link); TclDecrRefCount(link); linkStr = Tcl_GetStringFromObj(retVal, &curLen); } else { /* * Absolute link. */ TclDecrRefCount(retVal); retVal = link; linkStr = Tcl_GetStringFromObj(retVal, &curLen); /* * Convert to forward-slashes on windows. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { int i; for (i = 0; i < curLen; i++) { if (linkStr[i] == '\\') { linkStr[i] = '/'; } } } } } else { linkStr = Tcl_GetStringFromObj(retVal, &curLen); } /* * Either way, we now remove the last path element. */ while (--curLen >= 0) { if (IsSeparatorOrNull(linkStr[curLen])) { Tcl_SetObjLength(retVal, curLen); break; } |
︙ | ︙ | |||
322 323 324 325 326 327 328 | } } first = 0; if (retVal != NULL) { Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep); } } | | | | | | | | | | | | | | | > | | > | | | | < | | | | | | | | < > > | > > | | | 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 | } } first = 0; if (retVal != NULL) { Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep); } } /* * If we didn't make any changes, just use the input path. */ if (retVal == NULL) { retVal = pathPtr; Tcl_IncrRefCount(retVal); if (Tcl_IsShared(retVal)) { /* * Unfortunately, the platform-specific normalization code which * will be called below has no way of dealing with the case where * an object is shared. It is expecting to modify an object in * place. So, we must duplicate this here to ensure an object * with a single ref-count. * * If that changes in the future (e.g. the normalize proc is given * one object and is able to return a different one), then we * could remove this code. */ TclDecrRefCount(retVal); retVal = Tcl_DuplicateObj(pathPtr); Tcl_IncrRefCount(retVal); } } /* * Ensure a windows drive like C:/ has a trailing separator */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { int len; CONST char *path = Tcl_GetStringFromObj(retVal, &len); if (len == 2 && path[0] != 0 && path[1] == ':') { if (Tcl_IsShared(retVal)) { TclDecrRefCount(retVal); retVal = Tcl_DuplicateObj(retVal); Tcl_IncrRefCount(retVal); } Tcl_AppendToObj(retVal, "/", 1); } } /* * Now we have an absolute path, with no '..', '.' sequences, but it still * may not be in 'unique' form, depending on the platform. For instance, * Unix is case-sensitive, so the path is ok. Windows is case-insensitive, * and also has the weird 'longname/shortname' thing (e.g. C:/Program * Files/ and C:/Progra~1/ are equivalent). * * Virtual file systems which may be registered may have other criteria * for normalizing a path. */ TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData); /* * Since we know it is a normalized path, we can actually convert this * object into an FsPath for greater efficiency */ TclFSMakePathFromNormalized(interp, retVal, clientData); if (clientDataPtr != NULL) { *clientDataPtr = clientData; } /* * This has a refCount of 1 for the caller, unlike many Tcl_Obj APIs. */ return retVal; } /* *---------------------------------------------------------------------- * * Tcl_FSGetPathType -- * * Determines whether a given path is relative to the current directory, * relative to the current volume, or absolute. * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or * TCL_PATH_VOLUME_RELATIVE. * * Side effects: * None. |
︙ | ︙ | |||
424 425 426 427 428 429 430 | } /* *---------------------------------------------------------------------- * * TclFSGetPathType -- * | | | | | | < | | | | > | | | | | | | | | | < | | | | | | | | | | | | | < | | | | | > | | | | | | | | | < | | | | | | | < | | | | | > | | | | | | | | | | | | < | < | | > | | | | | | | | > | | | | | < | | | | | | | | | < | | | | | | > > > > > > > > > | | | | | | | | < < > | | | | | | | | | | | < | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | > | | > | > > > > | | | > | | | | | | | < | | | | > | | | | > | | | | | | | < | | | | | > | | | | < < | | | | | | | | > | | | | | | | < > | > > | | | | | | | | | | | | | < | > | | | | | | | | | | | | | | | | | > | | | | > | | | | < | | | | | | | | | | < | | | | 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 | } /* *---------------------------------------------------------------------- * * TclFSGetPathType -- * * Determines whether a given path is relative to the current directory, * relative to the current volume, or absolute. If the caller wishes to * know which filesystem claimed the path (in the case for which the path * is absolute), then a reference to a filesystem pointer can be passed * in (but passing NULL is acceptable). * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and * only if it is non-NULL and the function's return value is * TCL_PATH_ABSOLUTE. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_PathType TclFSGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr) Tcl_Obj *pathPtr; Tcl_Filesystem **filesystemPtrPtr; int *driveNameLengthPtr; { if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) { return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, NULL); } else { FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (fsPathPtr->cwdPtr != NULL) { if (PATHFLAGS(pathPtr) == 0) { return TCL_PATH_RELATIVE; } return TclFSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr, driveNameLengthPtr); } else { return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, NULL); } } } /* *--------------------------------------------------------------------------- * * TclPathPart * * This function calculates the requested part of the given path, which * can be: * * - the directory above ('file dirname') * - the tail ('file tail') * - the extension ('file extension') * - the root ('file root') * * The 'portion' parameter dictates which of these to calculate. There * are a number of special cases both to be more efficient, and because * the behaviour when given a path with only a single element is defined * to require the expansion of that single element, where possible. * * Should look into integrating 'FileBasename' in tclFCmd.c into this * function. * * Results: * NULL if an error occurred, otherwise a Tcl_Obj owned by the caller * (i.e. most likely with refCount 1). * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_Obj* TclPathPart(interp, pathPtr, portion) Tcl_Interp *interp; /* Used for error reporting */ Tcl_Obj *pathPtr; /* Path to take dirname of */ Tcl_PathPart portion; /* Requested portion of name */ { if (pathPtr->typePtr == &tclFsPathType) { FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (TclFSEpochOk(fsPathPtr->filesystemEpoch) && (PATHFLAGS(pathPtr) != 0)) { switch (portion) { case TCL_PATH_DIRNAME: { /* * Check if the joined-on bit has any directory delimiters in * it. If so, the 'dirname' would be a joining of the main * part with the dirname of the joined-on bit. We could handle * that special case here, but we don't, and instead just use * the standardPath code. */ CONST char *rest = TclGetString(fsPathPtr->normPathPtr); if (strchr(rest, '/') != NULL) { goto standardPath; } if (tclPlatform == TCL_PLATFORM_WINDOWS && strchr(rest, '\\') != NULL) { goto standardPath; } /* * The joined-on path is simple, so we can just return here. */ Tcl_IncrRefCount(fsPathPtr->cwdPtr); return fsPathPtr->cwdPtr; } case TCL_PATH_TAIL: { /* * Check if the joined-on bit has any directory delimiters in * it. If so, the 'tail' would be only the part following the * last delimiter. We could handle that special case here, but * we don't, and instead just use the standardPath code. */ CONST char *rest = TclGetString(fsPathPtr->normPathPtr); if (strchr(rest, '/') != NULL) { goto standardPath; } if (tclPlatform == TCL_PLATFORM_WINDOWS && strchr(rest, '\\') != NULL) { goto standardPath; } Tcl_IncrRefCount(fsPathPtr->normPathPtr); return fsPathPtr->normPathPtr; } case TCL_PATH_EXTENSION: return GetExtension(fsPathPtr->normPathPtr); case TCL_PATH_ROOT: { CONST char *fileName, *extension; int length; fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { /* * There is no extension so the root is the same as the * path we were given. */ Tcl_IncrRefCount(pathPtr); return pathPtr; } else { /* * Duplicate the object we were given and then trim off * the extension of the tail component of the path. */ FsPath *fsDupPtr; Tcl_Obj *root = Tcl_DuplicateObj(pathPtr); Tcl_IncrRefCount(root); fsDupPtr = (FsPath*) PATHOBJ(root); if (Tcl_IsShared(fsDupPtr->normPathPtr)) { TclDecrRefCount(fsDupPtr->normPathPtr); fsDupPtr->normPathPtr = Tcl_NewStringObj(fileName, (int)(length - strlen(extension))); Tcl_IncrRefCount(fsDupPtr->normPathPtr); } else { Tcl_SetObjLength(fsDupPtr->normPathPtr, (int)(length - strlen(extension))); } /* * Must also trim the string representation if we have it. */ if (root->bytes != NULL && root->length > 0) { root->length -= strlen(extension); root->bytes[root->length] = 0; } return root; } } default: /* We should never get here */ Tcl_Panic("Bad portion to TclPathPart"); /* For less clever compilers */ return NULL; } } else if (fsPathPtr->cwdPtr != NULL) { /* Relative path */ goto standardPath; } else { /* Absolute path */ goto standardPath; } } else { int splitElements; Tcl_Obj *splitPtr; Tcl_Obj *resultPtr; standardPath: resultPtr = NULL; if (portion == TCL_PATH_EXTENSION) { return GetExtension(pathPtr); } else if (portion == TCL_PATH_ROOT) { int length; CONST char *fileName, *extension; fileName = Tcl_GetStringFromObj(pathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { Tcl_IncrRefCount(pathPtr); return pathPtr; } else { Tcl_Obj *root = Tcl_NewStringObj(fileName, (int) (length - strlen(extension))); Tcl_IncrRefCount(root); return root; } } /* * The behaviour we want here is slightly different to the standard * Tcl_FSSplitPath in the handling of home directories; * Tcl_FSSplitPath preserves the "~" while this code computes the * actual full path name, if we had just a single component. */ splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); if (splitElements == 1 && TclGetString(pathPtr)[0] == '~') { Tcl_Obj *norm; TclDecrRefCount(splitPtr); norm = Tcl_FSGetNormalizedPath(interp, pathPtr); if (norm == NULL) { return NULL; } splitPtr = Tcl_FSSplitPath(norm, &splitElements); Tcl_IncrRefCount(splitPtr); } if (portion == TCL_PATH_TAIL) { /* * Return the last component, unless it is the only component, and * it is the root of an absolute path. */ if ((splitElements > 0) && ((splitElements > 1) || (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) { Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &resultPtr); } else { resultPtr = Tcl_NewObj(); } } else { /* * Return all but the last component. If there is only one * component, return it if the path was non-relative, otherwise * return the current directory. */ if (splitElements > 1) { resultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1); } else if (splitElements == 0 || (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) { resultPtr = Tcl_NewStringObj(".", 1); } else { Tcl_ListObjIndex(NULL, splitPtr, 0, &resultPtr); } } Tcl_IncrRefCount(resultPtr); TclDecrRefCount(splitPtr); return resultPtr; } } /* * Simple helper function */ static Tcl_Obj* GetExtension(pathPtr) Tcl_Obj *pathPtr; { CONST char *tail, *extension; Tcl_Obj *ret; tail = TclGetString(pathPtr); extension = TclGetExtension(tail); if (extension == NULL) { ret = Tcl_NewObj(); } else { ret = Tcl_NewStringObj(extension, -1); } Tcl_IncrRefCount(ret); return ret; } /* *--------------------------------------------------------------------------- * * Tcl_FSJoinPath -- * * This function takes the given Tcl_Obj, which should be a valid list, * and returns the path object given by considering the first 'elements' * elements as valid path segments (each path segment may be a complete * path, a partial path or just a single possible directory or file * name). If any path segment is actually an absolute path, then all * prior path segments are discarded. * * If elements < 0, we use the entire list that was given. * * It is possible that the returned object is actually an element of the * given list, so the caller should be careful to store a refCount to it * before freeing the list. * * Results: * Returns object with refCount of zero, (or if non-zero, it has * references elsewhere in Tcl). Either way, the caller must increment * its refCount before use. Note that in the case where the caller has * asked to join zero elements of the list, the return value will be an * empty-string Tcl_Obj. * * If the given listObj was invalid, then the calling routine has a bug, * and this function will just return NULL. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_Obj* Tcl_FSJoinPath(listObj, elements) Tcl_Obj *listObj; /* Path elements to join, may have a zero * reference count. */ int elements; /* Number of elements to use (-1 = all) */ { Tcl_Obj *res; int i; Tcl_Filesystem *fsPtr = NULL; if (elements < 0) { if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) { return NULL; } } else { /* * Just make sure it is a valid list. */ int listTest; if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) { return NULL; } /* * Correct this if it is too large, otherwise we will waste our time * joining null elements to the path. */ if (elements > listTest) { elements = listTest; } } res = NULL; for (i = 0; i < elements; i++) { Tcl_Obj *elt; int driveNameLength; Tcl_PathType type; char *strElt; int strEltLen; int length; char *ptr; Tcl_Obj *driveName = NULL; Tcl_ListObjIndex(NULL, listObj, i, &elt); /* * This is a special case where we can be much more efficient, where * we are joining a single relative path onto an object that is * already of path type. The 'TclNewFSPathObj' call below creates an * object which can be normalized more efficiently. Currently we only * use the special case when we have exactly two elements, but we * could expand that in the future. */ if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType) && !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) { Tcl_Obj *tail; Tcl_PathType type; Tcl_ListObjIndex(NULL, listObj, i+1, &tail); type = TclGetPathType(tail, NULL, NULL, NULL); if (type == TCL_PATH_RELATIVE) { CONST char *str; int len; str = Tcl_GetStringFromObj(tail, &len); if (len == 0) { /* * This happens if we try to handle the root volume '/'. * There's no need to return a special path object, when * the base itself is just fine! */ if (res != NULL) { TclDecrRefCount(res); } return elt; } /* * If it doesn't begin with '.' and is a unix path or it a * windows path without backslashes, then we can be very * efficient here. (In fact even a windows path with * backslashes can be joined efficiently, but the path object * would not have forward slashes only, and this would * therefore contradict our 'file join' documentation). */ if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS) || (strchr(str, '\\') == NULL))) { /* * Finally, on Windows, 'file join' is defined to convert * all backslashes to forward slashes, so the base part * cannot have backslashes either. */ if ((tclPlatform != TCL_PLATFORM_WINDOWS) || (strchr(Tcl_GetString(elt), '\\') == NULL)) { if (res != NULL) { TclDecrRefCount(res); } return TclNewFSPathObj(elt, str, len); } } /* * Otherwise we don't have an easy join, and we must let the * more general code below handle things */ } else if (tclPlatform == TCL_PLATFORM_UNIX) { if (res != NULL) { TclDecrRefCount(res); } return tail; } else { CONST char *str; int len; str = Tcl_GetStringFromObj(tail, &len); if (tclPlatform == TCL_PLATFORM_WINDOWS) { if (strchr(str, '\\') == NULL) { if (res != NULL) { TclDecrRefCount(res); } return tail; } } } } strElt = Tcl_GetStringFromObj(elt, &strEltLen); type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName); if (type != TCL_PATH_RELATIVE) { /* * Zero out the current result. */ if (res != NULL) { TclDecrRefCount(res); } if (driveName != NULL) { /* * We've been given a separate drive-name object, because the * prefix in 'elt' is not in a suitable format for us (e.g. it * may contain irrelevant multiple separators, like * C://///foo). */ res = Tcl_DuplicateObj(driveName); TclDecrRefCount(driveName); /* * Do not set driveName to NULL, because we will check its * value below (but we won't access the contents, since those * have been cleaned-up). */ } else { res = Tcl_NewStringObj(strElt, driveNameLength); } strElt += driveNameLength; } /* * Optimisation block: if this is the last element to be examined, and * it is absolute or the only element, and the drive-prefix was ok (if * there is one), it might be that the path is already in a suitable * form to be returned. Then we can short-cut the rest of this * function. */ if ((driveName == NULL) && (i == (elements - 1)) && (type != TCL_PATH_RELATIVE || res == NULL)) { /* * It's the last path segment. Perform a quick check if the path * is already in a suitable form. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { if (strchr(strElt, '\\') != NULL) { goto noQuickReturn; } } ptr = strElt; while (*ptr != '\0') { if (*ptr == '/' && (ptr[1] == '/' || ptr[1] == '\0')) { /* * We have a repeated file separator, which means the path * is not in normalized form */ goto noQuickReturn; } ptr++; } if (res != NULL) { TclDecrRefCount(res); } /* * This element is just what we want to return already - no * further manipulation is requred. */ return elt; } /* * The path element was not of a suitable form to be returned as is. * We need to perform a more complex operation here. */ noQuickReturn: if (res == NULL) { res = Tcl_NewObj(); ptr = Tcl_GetStringFromObj(res, &length); } else { ptr = Tcl_GetStringFromObj(res, &length); } /* * Strip off any './' before a tilde, unless this is the beginning of * the path. */ if (length > 0 && strEltLen > 0 && (strElt[0] == '.') && (strElt[1] == '/') && (strElt[2] == '~')) { strElt += 2; } /* * A NULL value for fsPtr at this stage basically means we're trying * to join a relative path onto something which is also relative (or * empty). There's nothing particularly wrong with that. */ if (*strElt == '\0') { continue; } if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) { TclpNativeJoinPath(res, strElt); } else { char separator = '/'; int needsSep = 0; if (fsPtr->filesystemSeparatorProc != NULL) { Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res); if (sep != NULL) { separator = TclGetString(sep)[0]; } } |
︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 | } } length = ptr - TclGetString(res); Tcl_SetObjLength(res, length); } } if (res == NULL) { | | | | | < | | | < | | | | | | | | | | | < | | > | | | | | | | < | | < | | | | | 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 | } } length = ptr - TclGetString(res); Tcl_SetObjLength(res, length); } } if (res == NULL) { res = Tcl_NewObj(); } return res; } /* *--------------------------------------------------------------------------- * * Tcl_FSConvertToPathType -- * * This function tries to convert the given Tcl_Obj to a valid Tcl path * type, taking account of the fact that the cwd may have changed even if * this object is already supposedly of the correct type. * * The filename may begin with "~" (to indicate current user's home * directory) or "~<user>" (to indicate any user's home directory). * * Results: * Standard Tcl error code. * * Side effects: * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- */ int Tcl_FSConvertToPathType(interp, pathPtr) Tcl_Interp *interp; /* Interpreter in which to store error message * (if necessary). */ Tcl_Obj *pathPtr; /* Object to convert to a valid, current path * type. */ { /* * While it is bad practice to examine an object's type directly, this is * actually the best thing to do here. The reason is that if we are * converting this object to FsPath type for the first time, we don't need * to worry whether the 'cwd' has changed. On the other hand, if this * object is already of FsPath type, and is a relative path, we do have to * worry about the cwd. If the cwd has changed, we must recompute the * path. */ if (pathPtr->typePtr == &tclFsPathType) { FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (!TclFSEpochOk(fsPathPtr->filesystemEpoch)) { if (pathPtr->bytes == NULL) { UpdateStringOfFsPath(pathPtr); } FreeFsPathInternalRep(pathPtr); pathPtr->typePtr = NULL; return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); } return TCL_OK; /* * We used to have more complex code here: * * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) { * return TCL_OK; * } else { * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { * return TCL_OK; * } else { * if (pathPtr->bytes == NULL) { * UpdateStringOfFsPath(pathPtr); * } * FreeFsPathInternalRep(pathPtr); * pathPtr->typePtr = NULL; * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); * } * } * * But we no longer believe this is necessary. */ } else { return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); } } /* * Helper function for normalization. */ static int IsSeparatorOrNull(ch) int ch; { if (ch == 0) { return 1; } switch (tclPlatform) { case TCL_PLATFORM_UNIX: return (ch == '/' ? 1 : 0); case TCL_PLATFORM_WINDOWS: return ((ch == '/' || ch == '\\') ? 1 : 0); } return 0; } /* * Helper function for SetFsPathFromAny. Returns position of first directory * delimiter in the path. If no separator is found, then returns the position * of the end of the string. */ static int FindSplitPos(path, separator) CONST char *path; int separator; { |
︙ | ︙ | |||
1167 1168 1169 1170 1171 1172 1173 | } /* *--------------------------------------------------------------------------- * * TclNewFSPathObj -- * | | | | | | | < | | | | | > | > > | 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 | } /* *--------------------------------------------------------------------------- * * TclNewFSPathObj -- * * Creates a path object whose string representation is '[file join * dirPtr addStrRep]', but does so in a way that allows for more * efficient creation and caching of normalized paths, and more efficient * 'file dirname', 'file tail', etc. * * Assumptions: * 'dirPtr' must be an absolute path. 'len' may not be zero. * * Results: * The new Tcl object, with refCount zero. * * Side effects: * Memory is allocated. 'dirPtr' gets an additional refCount. * *--------------------------------------------------------------------------- */ Tcl_Obj* TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len) { FsPath *fsPathPtr; Tcl_Obj *pathPtr; ThreadSpecificData *tsdPtr; tsdPtr = TCL_TSD_INIT(&tclFsDataKey); pathPtr = Tcl_NewObj(); fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); /* * Set up the path. */ fsPathPtr->translatedPathPtr = NULL; fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len); Tcl_IncrRefCount(fsPathPtr->normPathPtr); fsPathPtr->cwdPtr = dirPtr; Tcl_IncrRefCount(dirPtr); fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsRecPtr = NULL; |
︙ | ︙ | |||
1221 1222 1223 1224 1225 1226 1227 | } /* *--------------------------------------------------------------------------- * * TclFSMakePathRelative -- * | | | | | | | | > > > > > > | | < | | > > | > > > > > > > > > > > > > > > > | > > | | | | | | | | < | | | | | | | | | | | < | | | | | | | | > | > > | > > | > > > > | > > | | | | | < | | | | | | | | | | | | > | | > > | > > | | | | < | | | | | | | < > > | > > | | | | < | > | | | | | | | | | | | | | | < | | | | | | | | | | < | | | | | | | < | | | | | | | > > | > > > > | > > | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | < | | | < | | > > | > > | > | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | < | | | | | < | | | | | | | | | | | | | < | 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 | } /* *--------------------------------------------------------------------------- * * TclFSMakePathRelative -- * * Only for internal use. * * Takes a path and a directory, where we _assume_ both path and * directory are absolute, normalized and that the path lies inside the * directory. Returns a Tcl_Obj representing filename of the path * relative to the directory. * * In the case where the resulting path would start with a '~', we take * special care to return an ordinary string. This means to use that * path (and not have it interpreted as a user name), one must prepend * './'. This may seem strange, but that is how 'glob' is currently * defined. * * Results: * NULL on error, otherwise a valid object, typically with refCount of * zero, which it is assumed the caller will increment. * * Side effects: * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- */ Tcl_Obj* TclFSMakePathRelative(interp, pathPtr, cwdPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *pathPtr; /* The path we have. */ Tcl_Obj *cwdPtr; /* Make it relative to this. */ { int cwdLen, len; CONST char *tempStr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (pathPtr->typePtr == &tclFsPathType) { FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) { pathPtr = fsPathPtr->normPathPtr; /* * Free old representation. */ if (pathPtr->typePtr != NULL) { if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't find object", "string representation", (char *) NULL); } return NULL; } pathPtr->typePtr->updateStringProc(pathPtr); } TclFreeIntRep(pathPtr); } /* * Now pathPtr is a string object. */ if (Tcl_GetString(pathPtr)[0] == '~') { /* * If the first character of the path is a tilde, we must just * return the path as is, to agree with the defined behaviour * of 'glob'. */ return pathPtr; } fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); /* * Circular reference, by design. */ fsPathPtr->translatedPathPtr = pathPtr; fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = cwdPtr; Tcl_IncrRefCount(cwdPtr); fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsRecPtr = NULL; fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; PATHOBJ(pathPtr) = (VOID *) fsPathPtr; PATHFLAGS(pathPtr) = 0; pathPtr->typePtr = &tclFsPathType; return pathPtr; } } /* * We know the cwd is a normalised object which does not end in a * directory delimiter, unless the cwd is the name of a volume, in which * case it will end in a delimiter! We handle this situation here. A * better test than the '!= sep' might be to simply check if 'cwd' is a * root volume. * * Note that if we get this wrong, we will strip off either too much or * too little below, leading to wrong answers returned by glob. */ tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); /* * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the * Windows special case? Perhaps we should just check if cwd is a root * volume. */ switch (tclPlatform) { case TCL_PLATFORM_UNIX: if (tempStr[cwdLen-1] != '/') { cwdLen++; } break; case TCL_PLATFORM_WINDOWS: if (tempStr[cwdLen-1] != '/' && tempStr[cwdLen-1] != '\\') { cwdLen++; } break; } tempStr = Tcl_GetStringFromObj(pathPtr, &len); return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen); } /* *--------------------------------------------------------------------------- * * TclFSMakePathFromNormalized -- * * Like SetFsPathFromAny, but assumes the given object is an absolute * normalized path. Only for internal use. * * Results: * Standard Tcl error code. * * Side effects: * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- */ int TclFSMakePathFromNormalized(interp, pathPtr, nativeRep) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *pathPtr; /* The object to convert. */ ClientData nativeRep; /* The native rep for the object, if known * else NULL. */ { FsPath *fsPathPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (pathPtr->typePtr == &tclFsPathType) { return TCL_OK; } /* * Free old representation */ if (pathPtr->typePtr != NULL) { if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't find object", "string representation", (char *) NULL); } return TCL_ERROR; } pathPtr->typePtr->updateStringProc(pathPtr); } TclFreeIntRep(pathPtr); } fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); /* * It's a pure normalized absolute path. */ fsPathPtr->translatedPathPtr = NULL; /* * Circular reference by design. */ fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = nativeRep; fsPathPtr->fsRecPtr = NULL; fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; PATHOBJ(pathPtr) = (VOID *) fsPathPtr; PATHFLAGS(pathPtr) = 0; pathPtr->typePtr = &tclFsPathType; return TCL_OK; } /* *--------------------------------------------------------------------------- * * Tcl_FSNewNativePath -- * * This function performs the something like the reverse of the usual * obj->path->nativerep conversions. If some code retrieves a path in * native form (from, e.g. readlink or a native dialog), and that path is * to be used at the Tcl level, then calling this function is an * efficient way of creating the appropriate path object type. * * Any memory which is allocated for 'clientData' should be retained * until clientData is passed to the filesystem's freeInternalRepProc * when it can be freed. The built in platform-specific filesystems use * 'ckalloc' to allocate clientData, and ckfree to free it. * * Results: * NULL or a valid path object pointer, with refCount zero. * * Side effects: * New memory may be allocated. * *--------------------------------------------------------------------------- */ Tcl_Obj * Tcl_FSNewNativePath(fromFilesystem, clientData) Tcl_Filesystem* fromFilesystem; ClientData clientData; { Tcl_Obj *pathPtr; FsPath *fsPathPtr; FilesystemRecord *fsFromPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); pathPtr = TclFSInternalToNormalized(fromFilesystem, clientData, &fsFromPtr); if (pathPtr == NULL) { return NULL; } /* * Free old representation; shouldn't normally be any, but best to be * safe. */ if (pathPtr->typePtr != NULL) { if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { return NULL; } pathPtr->typePtr->updateStringProc(pathPtr); } TclFreeIntRep(pathPtr); } fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; /* * Circular reference, by design. */ fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = clientData; fsPathPtr->fsRecPtr = fsFromPtr; fsPathPtr->fsRecPtr->fileRefCount++; fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; PATHOBJ(pathPtr) = (VOID *) fsPathPtr; PATHFLAGS(pathPtr) = 0; pathPtr->typePtr = &tclFsPathType; return pathPtr; } /* *--------------------------------------------------------------------------- * * Tcl_FSGetTranslatedPath -- * * This function attempts to extract the translated path from the given * Tcl_Obj. If the translation succeeds (i.e. the object is a valid * path), then it is returned. Otherwise NULL will be returned, and an * error message may be left in the interpreter (if it is non-NULL) * * Results: * NULL or a valid Tcl_Obj pointer. * * Side effects: * Only those of 'Tcl_FSConvertToPathType' * *--------------------------------------------------------------------------- */ Tcl_Obj* Tcl_FSGetTranslatedPath(interp, pathPtr) Tcl_Interp *interp; Tcl_Obj* pathPtr; { Tcl_Obj *retObj = NULL; FsPath *srcFsPathPtr; if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return NULL; } srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (srcFsPathPtr->translatedPathPtr == NULL) { if (PATHFLAGS(pathPtr) != 0) { retObj = Tcl_FSGetNormalizedPath(interp, pathPtr); } else { /* * It is a pure absolute, normalized path object. This is * something like being a 'pure list'. The object's string, * translatedPath and normalizedPath are all identical. */ retObj = srcFsPathPtr->normPathPtr; } } else { /* * It is an ordinary path object. */ retObj = srcFsPathPtr->translatedPathPtr; } Tcl_IncrRefCount(retObj); return retObj; } /* *--------------------------------------------------------------------------- * * Tcl_FSGetTranslatedStringPath -- * * This function attempts to extract the translated path from the given * Tcl_Obj. If the translation succeeds (i.e. the object is a valid * path), then the path is returned. Otherwise NULL will be returned, and * an error message may be left in the interpreter (if it is non-NULL) * * Results: * NULL or a valid string. * * Side effects: * Only those of 'Tcl_FSConvertToPathType' * *--------------------------------------------------------------------------- */ CONST char* Tcl_FSGetTranslatedStringPath(interp, pathPtr) Tcl_Interp *interp; Tcl_Obj* pathPtr; { Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (transPtr != NULL) { int len; CONST char *result, *orig; orig = Tcl_GetStringFromObj(transPtr, &len); result = (char*) ckalloc((unsigned)(len+1)); memcpy((VOID*) result, (VOID*) orig, (size_t) (len+1)); TclDecrRefCount(transPtr); return result; } return NULL; } /* *--------------------------------------------------------------------------- * * Tcl_FSGetNormalizedPath -- * * This important function attempts to extract from the given Tcl_Obj a * unique normalised path representation, whose string value can be used * as a unique identifier for the file. * * Results: * NULL or a valid path object pointer. * * Side effects: * New memory may be allocated. The Tcl 'errno' may be modified in the * process of trying to examine various path possibilities. * *--------------------------------------------------------------------------- */ Tcl_Obj* Tcl_FSGetNormalizedPath(interp, pathPtr) Tcl_Interp *interp; Tcl_Obj* pathPtr; { FsPath *fsPathPtr; if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return NULL; } fsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0) { /* * This is a special path object which is the result of something like * 'file join' */ Tcl_Obj *dir, *copy; int cwdLen; int pathType; CONST char *cwdStr; ClientData clientData = NULL; pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); if (dir == NULL) { return NULL; } if (pathPtr->bytes == NULL) { UpdateStringOfFsPath(pathPtr); } copy = Tcl_DuplicateObj(dir); Tcl_IncrRefCount(copy); Tcl_IncrRefCount(dir); /* * We now own a reference on both 'dir' and 'copy' */ cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); /* * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about * the Windows special case? Perhaps we should just check if cwd is a * root volume. We should never get cwdLen == 0 in this code path. */ switch (tclPlatform) { case TCL_PLATFORM_UNIX: if (cwdStr[cwdLen-1] != '/') { Tcl_AppendToObj(copy, "/", 1); cwdLen++; } break; case TCL_PLATFORM_WINDOWS: if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') { Tcl_AppendToObj(copy, "/", 1); cwdLen++; } break; } Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); /* * Normalize the combined string, but only starting after the end of * the previously normalized 'dir'. This should be much faster! We * use 'cwdLen-1' so that we are already pointing at the dir-separator * that we know about. The normalization code will actually start off * directly after that separator. */ TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); /* * Now we need to construct the new path object */ if (pathType == TCL_PATH_RELATIVE) { FsPath* origDirFsPathPtr; Tcl_Obj *origDir = fsPathPtr->cwdPtr; origDirFsPathPtr = (FsPath*) PATHOBJ(origDir); fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr; Tcl_IncrRefCount(fsPathPtr->cwdPtr); TclDecrRefCount(fsPathPtr->normPathPtr); fsPathPtr->normPathPtr = copy; /* * That's our reference to copy used. */ TclDecrRefCount(dir); TclDecrRefCount(origDir); } else { TclDecrRefCount(fsPathPtr->cwdPtr); fsPathPtr->cwdPtr = NULL; TclDecrRefCount(fsPathPtr->normPathPtr); fsPathPtr->normPathPtr = copy; /* * That's our reference to copy used. */ TclDecrRefCount(dir); } if (clientData != NULL) { fsPathPtr->nativePathPtr = clientData; } PATHFLAGS(pathPtr) = 0; } /* * Ensure cwd hasn't changed. */ if (fsPathPtr->cwdPtr != NULL) { if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { if (pathPtr->bytes == NULL) { UpdateStringOfFsPath(pathPtr); } FreeFsPathInternalRep(pathPtr); pathPtr->typePtr = NULL; if (Tcl_ConvertToType(interp, pathPtr, &tclFsPathType) != TCL_OK) { return NULL; } fsPathPtr = (FsPath*) PATHOBJ(pathPtr); } else if (fsPathPtr->normPathPtr == NULL) { int cwdLen; Tcl_Obj *copy; CONST char *cwdStr; ClientData clientData = NULL; copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); Tcl_IncrRefCount(copy); cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); /* * Should we perhaps use 'Tcl_FSPathSeparator'? But then what * about the Windows special case? Perhaps we should just check * if cwd is a root volume. We should never get cwdLen == 0 in * this code path. */ switch (tclPlatform) { case TCL_PLATFORM_UNIX: if (cwdStr[cwdLen-1] != '/') { Tcl_AppendToObj(copy, "/", 1); cwdLen++; } break; case TCL_PLATFORM_WINDOWS: if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') { Tcl_AppendToObj(copy, "/", 1); cwdLen++; } break; } Tcl_AppendObjToObj(copy, pathPtr); /* * Normalize the combined string, but only starting after the end * of the previously normalized 'dir'. This should be much faster! */ TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); fsPathPtr->normPathPtr = copy; if (clientData != NULL) { fsPathPtr->nativePathPtr = clientData; } } } if (fsPathPtr->normPathPtr == NULL) { ClientData clientData = NULL; Tcl_Obj *useThisCwd = NULL; /* * Since normPathPtr is NULL, but this is a valid path object, we know * that the translatedPathPtr cannot be NULL. */ Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr; CONST char *path = TclGetString(absolutePath); /* * We have to be a little bit careful here to avoid infinite loops * we're asking Tcl_FSGetPathType to return the path's type, but that * call can actually result in a lot of other filesystem action, which * might loop back through here. */ if (path[0] != '\0') { /* * We don't ask for the type of 'pathPtr' here, because that is * not correct for our purposes when we have a path like '~'. Tcl * has a bit of a contradiction in that '~' paths are defined as * 'absolute', but in reality can be just about anything, * depending on how env(HOME) is set. */ Tcl_PathType type = Tcl_FSGetPathType(absolutePath); if (type == TCL_PATH_RELATIVE) { useThisCwd = Tcl_FSGetCwd(interp); if (useThisCwd == NULL) { return NULL; } absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); Tcl_IncrRefCount(absolutePath); /* * We have a refCount on the cwd. */ #ifdef __WIN32__ } else if (type == TCL_PATH_VOLUME_RELATIVE) { /* * Only Windows has volume-relative paths. */ absolutePath = TclWinVolumeRelativeNormalize(interp, path, &useThisCwd); if (absolutePath == NULL) { return NULL; } #endif /* __WIN32__ */ } } /* * Already has refCount incremented. */ fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, absolutePath, (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); if (0 && (clientData != NULL)) { fsPathPtr->nativePathPtr = (*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData); } /* * Check if path is pure normalized (this can only be the case if it * is an absolute path). */ if (useThisCwd == NULL) { if (!strcmp(TclGetString(fsPathPtr->normPathPtr), TclGetString(pathPtr))) { /* * The path was already normalized. Get rid of the duplicate. */ TclDecrRefCount(fsPathPtr->normPathPtr); /* * We do *not* increment the refCount for this circular * reference. */ fsPathPtr->normPathPtr = pathPtr; } } else { /* * We just need to free an object we allocated above for relative * paths (this was returned by Tcl_FSJoinToPath above), and then * of course store the cwd. */ TclDecrRefCount(absolutePath); fsPathPtr->cwdPtr = useThisCwd; } } return fsPathPtr->normPathPtr; } /* *--------------------------------------------------------------------------- * * Tcl_FSGetInternalRep -- * * Extract the internal representation of a given path object, in the * given filesystem. If the path object belongs to a different * filesystem, we return NULL. * * If the internal representation is currently NULL, we attempt to * generate it, by calling the filesystem's * 'Tcl_FSCreateInternalRepProc'. * * Results: * NULL or a valid internal representation. * * Side effects: * An attempt may be made to convert the object. * *--------------------------------------------------------------------------- */ ClientData Tcl_FSGetInternalRep(pathPtr, fsPtr) Tcl_Obj* pathPtr; Tcl_Filesystem *fsPtr; { FsPath* srcFsPathPtr; if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) { return NULL; } srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); /* * We will only return the native representation for the caller's * filesystem. Otherwise we will simply return NULL. This means that * there must be a unique bi-directional mapping between paths and * filesystems, and that this mapping will not allow 'remapped' files -- * files which are in one filesystem but mapped into another. Another way * of putting this is that 'stacked' filesystems are not allowed. We * recognise that this is a potentially useful feature for the future. * * Even something simple like a 'pass through' filesystem which logs all * activity and passes the calls onto the native system would be nice, but * not easily achievable with the current implementation. */ if (srcFsPathPtr->fsRecPtr == NULL) { /* * This only usually happens in wrappers like TclpStat which create a * string object and pass it to TclpObjStat. Code which calls the * Tcl_FS.. functions should always have a filesystem already set. * Whether this code path is legal or not depends on whether we decide * to allow external code to call the native filesystem directly. It * is at least safer to allow this sub-optimal routing. */ Tcl_FSGetFileSystemForPath(pathPtr); /* * If we fail through here, then the path is probably not a valid path * in the filesystsem, and is most likely to be a use of the empty * path "" via a direct call to one of the objectified interfaces * (e.g. from the Tcl testsuite). */ srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (srcFsPathPtr->fsRecPtr == NULL) { return NULL; } } /* * There is still one possibility we should consider; if the file belongs * to a different filesystem, perhaps it is actually linked through to a * file in our own filesystem which we do care about. The way we can * check for this is we ask what filesystem this path belongs to. */ if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) { Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathPtr); if (actualFs == fsPtr) { return Tcl_FSGetInternalRep(pathPtr, fsPtr); |
︙ | ︙ | |||
1963 1964 1965 1966 1967 1968 1969 | } /* *--------------------------------------------------------------------------- * * TclFSEnsureEpochOk -- * | | | | < | | | | | | | < | | 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 | } /* *--------------------------------------------------------------------------- * * TclFSEnsureEpochOk -- * * This will ensure the pathPtr is up to date and can be converted into a * "path" type, and that we are able to generate a complete normalized * path which is used to determine the filesystem match. * * Results: * Standard Tcl return code. * * Side effects: * An attempt may be made to convert the object. * *--------------------------------------------------------------------------- */ int TclFSEnsureEpochOk(pathPtr, fsPtrPtr) Tcl_Obj* pathPtr; Tcl_Filesystem **fsPtrPtr; { FsPath* srcFsPathPtr; if (pathPtr->typePtr != &tclFsPathType) { return TCL_OK; } srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); /* * Check if the filesystem has changed in some way since this object's * internal representation was calculated. */ if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) { /* * We have to discard the stale representation and recalculate it. */ if (pathPtr->bytes == NULL) { UpdateStringOfFsPath(pathPtr); } FreeFsPathInternalRep(pathPtr); pathPtr->typePtr = NULL; if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return TCL_ERROR; } srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); } /* * Check whether the object is already assigned to a fs. */ if (srcFsPathPtr->fsRecPtr != NULL) { *fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr; } return TCL_OK; } |
︙ | ︙ | |||
2038 2039 2040 2041 2042 2043 2044 | * * Side effects: * ??? * *--------------------------------------------------------------------------- */ | | | | > | > > | | | | | | | | | | | | | | | < | | | | | | | < | | | | | | < | | | | | | | | > | < > > | | | < > > > | > > | | | < | | 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 | * * Side effects: * ??? * *--------------------------------------------------------------------------- */ void TclFSSetPathDetails(pathPtr, fsRecPtr, clientData) Tcl_Obj *pathPtr; FilesystemRecord *fsRecPtr; ClientData clientData; { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); FsPath* srcFsPathPtr; /* * Make sure pathPtr is of the correct type. */ if (pathPtr->typePtr != &tclFsPathType) { if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return; } } srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); srcFsPathPtr->fsRecPtr = fsRecPtr; srcFsPathPtr->nativePathPtr = clientData; srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; fsRecPtr->fileRefCount++; } /* *--------------------------------------------------------------------------- * * Tcl_FSEqualPaths -- * * This function tests whether the two paths given are equal path * objects. If either or both is NULL, 0 is always returned. * * Results: * 1 or 0. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int Tcl_FSEqualPaths(firstPtr, secondPtr) Tcl_Obj* firstPtr; Tcl_Obj* secondPtr; { char *firstStr, *secondStr; int firstLen, secondLen, tempErrno; if (firstPtr == secondPtr) { return 1; } if (firstPtr == NULL || secondPtr == NULL) { return 0; } firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) { return 1; } /* * Try the most thorough, correct method of comparing fully normalized * paths. */ tempErrno = Tcl_GetErrno(); firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr); secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr); Tcl_SetErrno(tempErrno); if (firstPtr == NULL || secondPtr == NULL) { return 0; } firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); return (firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0); } /* *--------------------------------------------------------------------------- * * SetFsPathFromAny -- * * This function tries to convert the given Tcl_Obj to a valid Tcl path * type. * * The filename may begin with "~" (to indicate current user's home * directory) or "~<user>" (to indicate any user's home directory). * * Results: * Standard Tcl error code. * * Side effects: * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- */ static int SetFsPathFromAny(interp, pathPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *pathPtr; /* The object to convert. */ { int len; FsPath *fsPathPtr; Tcl_Obj *transPtr; char *name; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (pathPtr->typePtr == &tclFsPathType) { return TCL_OK; } /* * First step is to translate the filename. This is similar to * Tcl_TranslateFilename, but shouldn't convert everything to windows * backslashes on that platform. The current implementation of this piece * is a slightly optimised version of the various Tilde/Split/Join stuff * to avoid multiple split/join operations. * * We remove any trailing directory separator. * * However, the split/join routines are quite complex, and one has to make * sure not to break anything on Unix or Win (fCmd.test, fileName.test and * cmdAH.test exercise most of the code). */ name = Tcl_GetStringFromObj(pathPtr, &len); /* * Handle tilde substitutions, if needed. */ if (name[0] == '~') { char *expandedUser; Tcl_DString temp; int split; char separator='/'; split = FindSplitPos(name, separator); if (split != len) { /* We have multiple pieces '~user/foo/bar...' */ name[split] = '\0'; } /* * Do some tilde substitution. */ if (name[1] == '\0') { /* * We have just '~' */ CONST char *dir; Tcl_DString dirString; if (split != len) { name[split] = separator; } dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't find HOME environment ", "variable to expand path", (char *) NULL); } return TCL_ERROR; } Tcl_DStringInit(&temp); Tcl_JoinPath(1, &dir, &temp); Tcl_DStringFree(&dirString); } else { /* * We have a user name '~user' */ Tcl_DStringInit(&temp); if (TclpGetUserHome(name+1, &temp) == NULL) { if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "user \"", (name+1), "\" doesn't exist", (char *) NULL); } Tcl_DStringFree(&temp); if (split != len) { name[split] = separator; } return TCL_ERROR; } if (split != len) { name[split] = separator; } } expandedUser = Tcl_DStringValue(&temp); transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp)); if (split != len) { /* * Join up the tilde substitution with the rest. */ if (name[split+1] == separator) { /* * Somewhat tricky case like ~//foo/bar. Make use of * Split/Join machinery to get it right. Assumes all paths * beginning with ~ are part of the native filesystem. */ int objc; Tcl_Obj **objv; Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL); Tcl_ListObjGetElements(NULL, parts, &objc, &objv); /* * Skip '~'. It's replaced by its expansion. */ objc--; objv++; while (objc--) { TclpNativeJoinPath(transPtr, TclGetString(*objv++)); } TclDecrRefCount(parts); } else { /* * Simple case. "rest" is relative path. Just join it. The * "rest" object will be freed when Tcl_FSJoinToPath returns * (unless something else claims a refCount on it). */ Tcl_Obj *joined; Tcl_Obj *rest = Tcl_NewStringObj(name+split+1, -1); Tcl_IncrRefCount(transPtr); joined = Tcl_FSJoinToPath(transPtr, 1, &rest); |
︙ | ︙ | |||
2291 2292 2293 2294 2295 2296 2297 | #if defined(__CYGWIN__) && defined(__WIN32__) { extern int cygwin_conv_to_win32_path(CONST char *, char *); char winbuf[MAX_PATH+1]; /* | | | < | | | | < | | | | 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 | #if defined(__CYGWIN__) && defined(__WIN32__) { extern int cygwin_conv_to_win32_path(CONST char *, char *); char winbuf[MAX_PATH+1]; /* * In the Cygwin world, call conv_to_win32_path in order to use the * mount table to translate the file name into something Windows will * understand. Take care when converting empty strings! */ name = Tcl_GetStringFromObj(transPtr, &len); if (len > 0) { cygwin_conv_to_win32_path(name, winbuf); TclWinNoBackslash(winbuf); Tcl_SetStringObj(transPtr, winbuf, -1); } } #endif /* __CYGWIN__ && __WIN32__ */ /* * Now we have a translated filename in 'transPtr'. This will have forward * slashes on Windows, and will not contain any ~user sequences. */ fsPathPtr = (FsPath *) ckalloc((unsigned)sizeof(FsPath)); fsPathPtr->translatedPathPtr = transPtr; if (transPtr != pathPtr) { Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); } fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsRecPtr = NULL; fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; |
︙ | ︙ | |||
2338 2339 2340 2341 2342 2343 2344 | pathPtr->typePtr = &tclFsPathType; return TCL_OK; } static void FreeFsPathInternalRep(pathPtr) | | | 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 | pathPtr->typePtr = &tclFsPathType; return TCL_OK; } static void FreeFsPathInternalRep(pathPtr) Tcl_Obj *pathPtr; /* Path object with internal rep to free. */ { FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr); if (fsPathPtr->translatedPathPtr != NULL) { if (fsPathPtr->translatedPathPtr != pathPtr) { TclDecrRefCount(fsPathPtr->translatedPathPtr); } |
︙ | ︙ | |||
2367 2368 2369 2370 2371 2372 2373 | (*freeProc)(fsPathPtr->nativePathPtr); fsPathPtr->nativePathPtr = NULL; } } if (fsPathPtr->fsRecPtr != NULL) { fsPathPtr->fsRecPtr->fileRefCount--; if (fsPathPtr->fsRecPtr->fileRefCount <= 0) { | > | > > | | 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 | (*freeProc)(fsPathPtr->nativePathPtr); fsPathPtr->nativePathPtr = NULL; } } if (fsPathPtr->fsRecPtr != NULL) { fsPathPtr->fsRecPtr->fileRefCount--; if (fsPathPtr->fsRecPtr->fileRefCount <= 0) { /* * It has been unregistered already. */ ckfree((char *) fsPathPtr->fsRecPtr); } } ckfree((char*) fsPathPtr); } static void |
︙ | ︙ | |||
2393 2394 2395 2396 2397 2398 2399 | copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; if (copyFsPathPtr->translatedPathPtr != copyPtr) { Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); } } else { copyFsPathPtr->translatedPathPtr = NULL; } | | | | | | | 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 | copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; if (copyFsPathPtr->translatedPathPtr != copyPtr) { Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); } } else { copyFsPathPtr->translatedPathPtr = NULL; } if (srcFsPathPtr->normPathPtr != NULL) { copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; if (copyFsPathPtr->normPathPtr != copyPtr) { Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); } } else { copyFsPathPtr->normPathPtr = NULL; } if (srcFsPathPtr->cwdPtr != NULL) { copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); } else { copyFsPathPtr->cwdPtr = NULL; } copyFsPathPtr->flags = srcFsPathPtr->flags; if (srcFsPathPtr->fsRecPtr != NULL && srcFsPathPtr->nativePathPtr != NULL) { Tcl_FSDupInternalRepProc *dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc; if (dupProc != NULL) { copyFsPathPtr->nativePathPtr = (*dupProc)(srcFsPathPtr->nativePathPtr); } else { copyFsPathPtr->nativePathPtr = NULL; } } else { copyFsPathPtr->nativePathPtr = NULL; } |
︙ | ︙ | |||
2439 2440 2441 2442 2443 2444 2445 | } /* *--------------------------------------------------------------------------- * * UpdateStringOfFsPath -- * | | | | | | | | | < | | | | | | | | | | | | | | | < | | | | | | > | | < | | | | < | | | | | < | | < > | > > | > | | | | > > | > | | < > > > > > > > > > | 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 | } /* *--------------------------------------------------------------------------- * * UpdateStringOfFsPath -- * * Gives an object a valid string rep. * * Results: * None. * * Side effects: * Memory may be allocated. * *--------------------------------------------------------------------------- */ static void UpdateStringOfFsPath(pathPtr) register Tcl_Obj *pathPtr; /* path obj with string rep to update. */ { FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr); CONST char *cwdStr; int cwdLen; Tcl_Obj *copy; if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) { Tcl_Panic("Called UpdateStringOfFsPath with invalid object"); } copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); Tcl_IncrRefCount(copy); cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); /* * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the * Windows special case? Perhaps we should just check if cwd is a root * volume. We should never get cwdLen == 0 in this code path. */ switch (tclPlatform) { case TCL_PLATFORM_UNIX: if (cwdStr[cwdLen-1] != '/') { Tcl_AppendToObj(copy, "/", 1); cwdLen++; } break; case TCL_PLATFORM_WINDOWS: /* * We need the extra 'cwdLen != 2', and ':' checks because a volume * relative path doesn't get a '/'. For example 'glob C:*cat*.exe' * will return 'C:cat32.exe' */ if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') { if (cwdLen != 2 || cwdStr[1] != ':') { Tcl_AppendToObj(copy, "/", 1); cwdLen++; } } break; } Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; copy->bytes = tclEmptyStringRep; copy->length = 0; TclDecrRefCount(copy); } /* *--------------------------------------------------------------------------- * * TclNativePathInFilesystem -- * * Any path object is acceptable to the native filesystem, by default (we * will throw errors when illegal paths are actually tried to be used). * * However, this behavior means the native filesystem must be the last * filesystem in the lookup list (otherwise it will claim all files * belong to it, and other filesystems will never get a look in). * * Results: * TCL_OK, to indicate 'yes', -1 to indicate no. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int TclNativePathInFilesystem(pathPtr, clientDataPtr) Tcl_Obj *pathPtr; ClientData *clientDataPtr; { /* * A special case is required to handle the empty path "". This is a valid * path (i.e. the user should be able to do 'file exists ""' without * throwing an error), but equally the path doesn't exist. Those are the * semantics of Tcl (at present anyway), so we have to abide by them here. */ if (pathPtr->typePtr == &tclFsPathType) { if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { /* * We reject the empty path "". */ return -1; } /* * Otherwise there is no way this path can be empty. */ } else { /* * It is somewhat unusual to reach this code path without the object * being of tclFsPathType. However, we do our best to deal with the * situation. */ int len; Tcl_GetStringFromObj(pathPtr, &len); if (len == 0) { /* * We reject the empty path "". */ return -1; } } /* * Path is of correct type, or is of non-zero length, so we accept it. */ return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclPipe.c.
1 2 3 | /* * tclPipe.c -- * | | | < | | | | | | | < | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | /* * tclPipe.c -- * * This file contains the generic portion of the command channel driver * as well as various utility routines used in managing subprocesses. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclPipe.c,v 1.10.2.2 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.h" /* * A linked list of the following structures is used to keep track of child * processes that have been detached but haven't exited yet, so we can make * sure that they're properly "reaped" (officially waited for) and don't lie * around as zombies cluttering the system. */ typedef struct Detached { Tcl_Pid pid; /* Id of process that's been detached but * isn't known to have exited. */ struct Detached *nextPtr; /* Next in list of all detached processes. */ } Detached; static Detached *detList = NULL;/* List of all detached proceses. */ TCL_DECLARE_MUTEX(pipeMutex) /* Guard access to detList. */ /* * Declarations for local functions defined in this file: */ static TclFile FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, CONST char *spec, int atOk, CONST char *arg, CONST char *nextArg, int flags, int *skipPtr, int *closePtr, int *releasePtr)); /* *---------------------------------------------------------------------- * * FileForRedirect -- * * This function does much of the work of parsing redirection operators. * It handles "@" if specified and allowed, and a file name, and opens * the file if necessary. * * Results: * The return value is the descriptor number for the file. If an error * occurs then NULL is returned and an error message is left in the * interp's result. Several arguments are side-effected; see the argument * list below for details. * * Side effects: * None. * *---------------------------------------------------------------------- */ static TclFile FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr, releasePtr) Tcl_Interp *interp; /* Intepreter to use for error reporting. */ CONST char *spec; /* Points to character just after redirection * character. */ int atOK; /* Non-zero means that '@' notation can be * used to specify a channel, zero means that * it isn't. */ CONST char *arg; /* Pointer to entire argument containing spec: * used for error reporting. */ CONST char *nextArg; /* Next argument in argc/argv array, if needed * for file name or channel name. May be * NULL. */ int flags; /* Flags to use for opening file or to specify * mode for channel. */ int *skipPtr; /* Filled with 1 if redirection target was in * spec, 2 if it was in nextArg. */ int *closePtr; /* Filled with one if the caller should close * the file when done with it, zero * otherwise. */ int *releasePtr; { int writing = (flags & O_WRONLY); Tcl_Channel chan; TclFile file; |
︙ | ︙ | |||
109 110 111 112 113 114 115 | Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan), "\" wasn't opened for ", ((writing) ? "writing" : "reading"), (char *) NULL); return NULL; } *releasePtr = 1; if (writing) { | < | | < | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan), "\" wasn't opened for ", ((writing) ? "writing" : "reading"), (char *) NULL); return NULL; } *releasePtr = 1; if (writing) { /* * Be sure to flush output to the file, so that anything written * by the child appears after stuff we've already written. */ Tcl_Flush(chan); } } else { CONST char *name; Tcl_DString nameString; |
︙ | ︙ | |||
146 147 148 149 150 151 152 | Tcl_PosixError(interp), (char *) NULL); return NULL; } *closePtr = 1; } return file; | | | | | < | | | 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 | Tcl_PosixError(interp), (char *) NULL); return NULL; } *closePtr = 1; } return file; badLastArg: Tcl_AppendResult(interp, "can't specify \"", arg, "\" as last word in command", (char *) NULL); return NULL; } /* *---------------------------------------------------------------------- * * Tcl_DetachPids -- * * This function is called to indicate that one or more child processes * have been placed in background and will never be waited for; they * should eventually be reaped by Tcl_ReapDetachedProcs. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_DetachPids(numPids, pidPtr) int numPids; /* Number of pids to detach: gives size of * array pointed to by pidPtr. */ Tcl_Pid *pidPtr; /* Array of pids to detach. */ { register Detached *detPtr; int i; Tcl_MutexLock(&pipeMutex); for (i = 0; i < numPids; i++) { |
︙ | ︙ | |||
196 197 198 199 200 201 202 | } /* *---------------------------------------------------------------------- * * Tcl_ReapDetachedProcs -- * | | | | | | < | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 | } /* *---------------------------------------------------------------------- * * Tcl_ReapDetachedProcs -- * * This function checks to see if any detached processes have exited and, * if so, it "reaps" them by officially waiting on them. It should be * called "occasionally" to make sure that all detached processes are * eventually reaped. * * Results: * None. * * Side effects: * Processes are waited on, so that they can be reaped by the system. * *---------------------------------------------------------------------- */ void Tcl_ReapDetachedProcs() { |
︙ | ︙ | |||
244 245 246 247 248 249 250 | } /* *---------------------------------------------------------------------- * * TclCleanupChildren -- * | | | | | | | | | | | | | | < > | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TclCleanupChildren -- * * This is a utility function used to wait for child processes to exit, * record information about abnormal exits, and then collect any stderr * output generated by them. * * Results: * The return value is a standard Tcl result. If anything at weird * happened with the child processes, TCL_ERROR is returned and a message * is left in the interp's result. * * Side effects: * If the last character of the interp's result is a newline, then it is * removed unless keepNewline is non-zero. File errorId gets closed, and * pidPtr is freed back to the storage allocator. * *---------------------------------------------------------------------- */ int TclCleanupChildren(interp, numPids, pidPtr, errorChan) Tcl_Interp *interp; /* Used for error messages. */ int numPids; /* Number of entries in pidPtr array. */ Tcl_Pid *pidPtr; /* Array of process ids of children. */ Tcl_Channel errorChan; /* Channel for file containing stderr output * from pipeline. NULL means there isn't any * stderr output. */ { int result = TCL_OK; int i, abnormalExit, anyErrorInfo; Tcl_Pid pid; WAIT_STATUS_TYPE waitStatus; CONST char *msg; unsigned long resolvedPid; abnormalExit = 0; for (i = 0; i < numPids; i++) { /* * We need to get the resolved pid before we wait on it as the windows * implimentation of Tcl_WaitPid deletes the information such that any * following calls to TclpGetPid fail. */ resolvedPid = TclpGetPid(pidPtr[i]); pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0); if (pid == (Tcl_Pid) -1) { result = TCL_ERROR; if (interp != (Tcl_Interp *) NULL) { msg = Tcl_PosixError(interp); if (errno == ECHILD) { /* * This changeup in message suggested by Mark Diekhans to * remind people that ECHILD errors can occur on some * systems if SIGCHLD isn't in its default state. */ msg = "child process lost (is SIGCHLD ignored or trapped?)"; } Tcl_AppendResult(interp, "error waiting for process to exit: ", msg, (char *) NULL); } continue; } /* * Create error messages for unusual process exits. An extra newline * gets appended to each error message, but it gets removed below (in * the same fashion that an extra newline in the command's output is * removed). */ if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE]; result = TCL_ERROR; sprintf(msg1, "%lu", resolvedPid); |
︙ | ︙ | |||
359 360 361 362 363 364 365 | (char *) NULL); } } } } /* | | | < < | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 | (char *) NULL); } } } } /* * Read the standard error file. If there's anything there, then return an * error and add the file's contents to the result string. */ anyErrorInfo = 0; if (errorChan != NULL) { /* * Make sure we start at the beginning of the file. */ if (interp != NULL) { int count; Tcl_Obj *objPtr; |
︙ | ︙ | |||
396 397 398 399 400 401 402 | Tcl_DecrRefCount(objPtr); } } Tcl_Close(NULL, errorChan); } /* | | | | | | | | | < | | | | | | | | < | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | > | | | | | | | | > | 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 | Tcl_DecrRefCount(objPtr); } } Tcl_Close(NULL, errorChan); } /* * If a child exited abnormally but didn't output any error information at * all, generate an error message here. */ if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) { Tcl_AppendResult(interp, "child process exited abnormally", (char *) NULL); } return result; } /* *---------------------------------------------------------------------- * * TclCreatePipeline -- * * Given an argc/argv array, instantiate a pipeline of processes as * described by the argv. * * This function is unofficially exported for use by BLT. * * Results: * The return value is a count of the number of new processes created, or * -1 if an error occurred while creating the pipeline. *pidArrayPtr is * filled in with the address of a dynamically allocated array giving the * ids of all of the processes. It is up to the caller to free this array * when it isn't needed anymore. If inPipePtr is non-NULL, *inPipePtr is * filled in with the file id for the input pipe for the pipeline (if * any): the caller must eventually close this file. If outPipePtr isn't * NULL, then *outPipePtr is filled in with the file id for the output * pipe from the pipeline: the caller must close this file. If errFilePtr * isn't NULL, then *errFilePtr is filled with a file id that may be used * to read error output after the pipeline completes. * * Side effects: * Processes and pipes are created. * *---------------------------------------------------------------------- */ int TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ int argc; /* Number of entries in argv. */ CONST char **argv; /* Array of strings describing commands in * pipeline plus I/O redirection with <, <<, * >, etc. Argv[argc] must be NULL. */ Tcl_Pid **pidArrayPtr; /* Word at *pidArrayPtr gets filled in with * address of array of pids for processes in * pipeline (first pid is first process in * pipeline). */ TclFile *inPipePtr; /* If non-NULL, input to the pipeline comes * from a pipe (unless overridden by * redirection in the command). The file id * with which to write to this pipe is stored * at *inPipePtr. NULL means command specified * its own input source. */ TclFile *outPipePtr; /* If non-NULL, output to the pipeline goes to * a pipe, unless overriden by redirection in * the command. The file id with which to read * frome this pipe is stored at *outPipePtr. * NULL means command specified its own output * sink. */ TclFile *errFilePtr; /* If non-NULL, all stderr output from the * pipeline will go to a temporary file * created here, and a descriptor to read the * file will be left at *errFilePtr. The file * will be removed already, so closing this * descriptor will be the end of the file. If * this is NULL, then all stderr output goes * to our stderr. If the pipeline specifies * redirection then the file will still be * created but it will never get any data. */ { Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all the * pids of child processes. */ int numPids; /* Actual number of processes that exist at * *pidPtr right now. */ int cmdCount; /* Count of number of distinct commands found * in argc/argv. */ CONST char *inputLiteral = NULL; /* If non-null, then this points to a string * containing input data (specified via <<) to * be piped to the first process in the * pipeline. */ TclFile inputFile = NULL; /* If != NULL, gives file to use as input for * first process in pipeline (specified via < * or <@). */ int inputClose = 0; /* If non-zero, then inputFile should be * closed when cleaning up. */ int inputRelease = 0; TclFile outputFile = NULL; /* Writable file for output from last command * in pipeline (could be file or pipe). NULL * means use stdout. */ int outputClose = 0; /* If non-zero, then outputFile should be * closed when cleaning up. */ int outputRelease = 0; TclFile errorFile = NULL; /* Writable file for error output from all * commands in pipeline. NULL means use * stderr. */ int errorClose = 0; /* If non-zero, then errorFile should be * closed when cleaning up. */ int errorRelease = 0; CONST char *p; CONST char *nextArg; int skip, lastBar, lastArg, i, j, atOK, flags, errorToOutput = 0; Tcl_DString execBuffer; TclFile pipeIn; TclFile curInFile, curOutFile, curErrFile; Tcl_Channel channel; if (inPipePtr != NULL) { |
︙ | ︙ | |||
527 528 529 530 531 532 533 | pipeIn = NULL; curInFile = NULL; curOutFile = NULL; numPids = 0; /* | | | | | | | < | | | > | < | 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 | pipeIn = NULL; curInFile = NULL; curOutFile = NULL; numPids = 0; /* * First, scan through all the arguments to figure out the structure of * the pipeline. Process all of the input and output redirection arguments * and remove them from the argument list in the pipeline. Count the * number of distinct processes (it's the number of "|" arguments plus * one) but don't remove the "|" arguments because they'll be used in the * second pass to seperate the individual child processes. Cannot start * the child processes in this pass because the redirection symbols may * appear anywhere in the command line - e.g., the '<' that specifies the * input to the entire pipe may appear at the very end of the argument * list. */ lastBar = -1; cmdCount = 1; for (i = 0; i < argc; i++) { errorToOutput = 0; skip = 0; p = argv[i]; switch (*p++) { case '|': if (*p == '&') { p++; } if (*p == '\0') { if ((i == (lastBar + 1)) || (i == (argc - 1))) { Tcl_SetResult(interp, "illegal use of | or |& in command", TCL_STATIC); goto error; } } lastBar = i; cmdCount++; break; |
︙ | ︙ | |||
576 577 578 579 580 581 582 | TclpReleaseFile(inputFile); } if (*p == '<') { inputFile = NULL; inputLiteral = p + 1; skip = 1; if (*inputLiteral == '\0') { | | > | | > > > > > > | | | > | | | 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 | TclpReleaseFile(inputFile); } if (*p == '<') { inputFile = NULL; inputLiteral = p + 1; skip = 1; if (*inputLiteral == '\0') { inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1]; if (inputLiteral == NULL) { Tcl_AppendResult(interp, "can't specify \"", argv[i], "\" as last word in command", (char *) NULL); goto error; } skip = 2; } } else { nextArg = ((i + 1) == argc) ? NULL : argv[i + 1]; inputLiteral = NULL; inputFile = FileForRedirect(interp, p, 1, argv[i], nextArg, O_RDONLY, &skip, &inputClose, &inputRelease); if (inputFile == NULL) { goto error; } } break; case '>': atOK = 1; flags = O_WRONLY | O_CREAT | O_TRUNC; if (*p == '>') { p++; atOK = 0; /* * Note that the O_APPEND flag only has an effect on POSIX * platforms. On Windows, we just have to carry on regardless. */ flags = O_WRONLY | O_CREAT | O_APPEND; } if (*p == '&') { if (errorClose != 0) { errorClose = 0; TclpCloseFile(errorFile); } errorToOutput = 1; p++; } /* * Close the old output file, but only if the error file is not * also using it. */ if (outputClose != 0) { outputClose = 0; if (errorFile == outputFile) { errorClose = 1; } else { TclpCloseFile(outputFile); } } if (outputRelease != 0) { outputRelease = 0; if (errorFile == outputFile) { errorRelease = 1; } else { TclpReleaseFile(outputFile); } } nextArg = ((i + 1) == argc) ? NULL : argv[i + 1]; outputFile = FileForRedirect(interp, p, atOK, argv[i], nextArg, flags, &skip, &outputClose, &outputRelease); if (outputFile == NULL) { goto error; } if (errorToOutput) { if (errorClose != 0) { errorClose = 0; TclpCloseFile(errorFile); |
︙ | ︙ | |||
673 674 675 676 677 678 679 | if (errorRelease != 0) { errorRelease = 0; TclpReleaseFile(errorFile); } if (atOK && p[0] == '@' && p[1] == '1' && p[2] == '\0') { /* * Special case handling of 2>@1 to redirect stderr to the | | | > | > | | > | | | 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 | if (errorRelease != 0) { errorRelease = 0; TclpReleaseFile(errorFile); } if (atOK && p[0] == '@' && p[1] == '1' && p[2] == '\0') { /* * Special case handling of 2>@1 to redirect stderr to the * exec/open output pipe as well. This is meant for the end of * the command string, otherwise use |& between commands. */ if (i != argc-1) { Tcl_AppendResult(interp, "must specify \"", argv[i], "\" as last word in command", (char *) NULL); goto error; } errorFile = outputFile; errorToOutput = 2; skip = 1; } else { nextArg = ((i + 1) == argc) ? NULL : argv[i + 1]; errorFile = FileForRedirect(interp, p, atOK, argv[i], nextArg, flags, &skip, &errorClose, &errorRelease); if (errorFile == NULL) { goto error; } } break; } if (skip != 0) { for (j = i + skip; j < argc; j++) { argv[j - skip] = argv[j]; } argc -= skip; i -= 1; } } if (inputFile == NULL) { if (inputLiteral != NULL) { /* * The input for the first process is immediate data coming from * Tcl. Create a temporary file for it and put the data into the * file. */ inputFile = TclpCreateTempFile(inputLiteral); if (inputFile == NULL) { Tcl_AppendResult(interp, "couldn't create input file for command: ", Tcl_PosixError(interp), (char *) NULL); goto error; } inputClose = 1; } else if (inPipePtr != NULL) { /* * The input for the first process in the pipeline is to come from * a pipe that can be written from by the caller. */ if (TclpCreatePipe(&inputFile, inPipePtr) == 0) { Tcl_AppendResult(interp, "couldn't create input pipe for command: ", Tcl_PosixError(interp), (char *) NULL); goto error; |
︙ | ︙ | |||
749 750 751 752 753 754 755 | } } } if (outputFile == NULL) { if (outPipePtr != NULL) { /* | | | | 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 | } } } if (outputFile == NULL) { if (outPipePtr != NULL) { /* * Output from the last process in the pipeline is to go to a pipe * that can be read by the caller. */ if (TclpCreatePipe(outPipePtr, &outputFile) == 0) { Tcl_AppendResult(interp, "couldn't create output pipe for command: ", Tcl_PosixError(interp), (char *) NULL); goto error; |
︙ | ︙ | |||
778 779 780 781 782 783 784 | } } } if (errorFile == NULL) { if (errorToOutput == 2) { /* | | > | | | | 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 | } } } if (errorFile == NULL) { if (errorToOutput == 2) { /* * Handle 2>@1 special case at end of cmd line. */ errorFile = outputFile; } else if (errFilePtr != NULL) { /* * Set up the standard error output sink for the pipeline, if * requested. Use a temporary file which is opened, then deleted. * Could potentially just use pipe, but if it filled up it could * cause the pipeline to deadlock: we'd be waiting for processes * to complete before reading stderr, and processes couldn't * complete because stderr was backed up. */ errorFile = TclpCreateTempFile(NULL); if (errorFile == NULL) { Tcl_AppendResult(interp, "couldn't create error file for command: ", |
︙ | ︙ | |||
815 816 817 818 819 820 821 | errorRelease = 1; } } } } /* | | | | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 | errorRelease = 1; } } } } /* * Scan through the argc array, creating a process for each group of * arguments between the "|" characters. */ Tcl_ReapDetachedProcs(); pidPtr = (Tcl_Pid *) ckalloc((unsigned) (cmdCount * sizeof(Tcl_Pid))); curInFile = inputFile; |
︙ | ︙ | |||
853 854 855 856 857 858 859 | } if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == '\0')) { joinThisError = 1; break; } } } | < | | > | 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 | } if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == '\0')) { joinThisError = 1; break; } } } /* * If this is the last segment, use the specified outputFile. * Otherwise create an intermediate pipe. pipeIn will become the * curInFile for the next segment of the pipe. */ if (lastArg == argc) { curOutFile = outputFile; } else { argv[lastArg] = NULL; if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) { Tcl_AppendResult(interp, "couldn't create pipe: ", Tcl_PosixError(interp), (char *) NULL); goto error; } } |
︙ | ︙ | |||
896 897 898 899 900 901 902 | } Tcl_DStringFree(&execBuffer); pidPtr[numPids] = pid; numPids++; /* | | | | | | | | | | 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 | } Tcl_DStringFree(&execBuffer); pidPtr[numPids] = pid; numPids++; /* * Close off our copies of file descriptors that were set up for this * child, then set up the input for the next child. */ if ((curInFile != NULL) && (curInFile != inputFile)) { TclpCloseFile(curInFile); } curInFile = pipeIn; pipeIn = NULL; if ((curOutFile != NULL) && (curOutFile != outputFile)) { TclpCloseFile(curOutFile); } curOutFile = NULL; } *pidArrayPtr = pidPtr; /* * All done. Cleanup open files lying around and then return. */ cleanup: Tcl_DStringFree(&execBuffer); if (inputClose) { TclpCloseFile(inputFile); } else if (inputRelease) { TclpReleaseFile(inputFile); } if (outputClose) { TclpCloseFile(outputFile); } else if (outputRelease) { TclpReleaseFile(outputFile); } if (errorClose) { TclpCloseFile(errorFile); } else if (errorRelease) { TclpReleaseFile(errorFile); } return numPids; /* * An error occurred. There could have been extra files open, such as * pipes between children. Clean them all up. Detach any child processes * that have been created. */ error: if (pipeIn != NULL) { TclpCloseFile(pipeIn); } if ((curOutFile != NULL) && (curOutFile != outputFile)) { TclpCloseFile(curOutFile); } if ((curInFile != NULL) && (curInFile != inputFile)) { |
︙ | ︙ | |||
983 984 985 986 987 988 989 | } /* *---------------------------------------------------------------------- * * Tcl_OpenCommandChannel -- * | | | | | < | | | | | | | < | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_OpenCommandChannel -- * * Opens an I/O channel to one or more subprocesses specified by argc and * argv. The flags argument determines the disposition of the stdio * handles. If the TCL_STDIN flag is set then the standard input for the * first subprocess will be tied to the channel: writing to the channel * will provide input to the subprocess. If TCL_STDIN is not set, then * standard input for the first subprocess will be the same as this * application's standard input. If TCL_STDOUT is set then standard * output from the last subprocess can be read from the channel; * otherwise it goes to this application's standard output. If TCL_STDERR * is set, standard error output for all subprocesses is returned to the * channel and results in an error when the channel is closed; otherwise * it goes to this application's standard error. If TCL_ENFORCE_MODE is * not set, then argc and argv can redirect the stdio handles to override * TCL_STDIN, TCL_STDOUT, and TCL_STDERR; if it is set, then it is an * error for argc and argv to override stdio channels for which * TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set. * * Results: * A new command channel, or NULL on failure with an error message left * in interp. * * Side effects: * Creates processes, opens pipes. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_OpenCommandChannel(interp, argc, argv, flags) Tcl_Interp *interp; /* Interpreter for error reporting. Can NOT be * NULL. */ int argc; /* How many arguments. */ CONST char **argv; /* Array of arguments for command pipe. */ int flags; /* Or'ed combination of TCL_STDIN, TCL_STDOUT, * TCL_STDERR, and TCL_ENFORCE_MODE. */ { TclFile *inPipePtr, *outPipePtr, *errFilePtr; TclFile inPipe, outPipe, errFile; |
︙ | ︙ | |||
1041 1042 1043 1044 1045 1046 1047 | outPipePtr, errFilePtr); if (numPids < 0) { goto error; } /* | | | | 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 | outPipePtr, errFilePtr); if (numPids < 0) { goto error; } /* * Verify that the pipes that were created satisfy the readable/writable * constraints. */ if (flags & TCL_ENFORCE_MODE) { if ((flags & TCL_STDOUT) && (outPipe == NULL)) { Tcl_AppendResult(interp, "can't read output from command:", " standard output was redirected", (char *) NULL); goto error; |
︙ | ︙ | |||
1068 1069 1070 1071 1072 1073 1074 | if (channel == (Tcl_Channel) NULL) { Tcl_AppendResult(interp, "pipe for command could not be created", (char *) NULL); goto error; } return channel; | | > > > > > > > > | 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 | if (channel == (Tcl_Channel) NULL) { Tcl_AppendResult(interp, "pipe for command could not be created", (char *) NULL); goto error; } return channel; error: if (numPids > 0) { Tcl_DetachPids(numPids, pidPtr); ckfree((char *) pidPtr); } if (inPipe != NULL) { TclpCloseFile(inPipe); } if (outPipe != NULL) { TclpCloseFile(outPipe); } if (errFile != NULL) { TclpCloseFile(errFile); } return NULL; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclPkg.c.
|
| | | | | | | | | | | | | | | | | | | | | | | | | < | | | < | | | | | < | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | /* * tclPkg.c -- * * This file implements package and version control for Tcl via the * "package" command and a few C APIs. * * Copyright (c) 1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclPkg.c,v 1.11.2.1 2005/08/02 18:16:06 dgp Exp $ */ #include "tclInt.h" /* * Each invocation of the "package ifneeded" command creates a structure of * the following type, which is used to load the package into the interpreter * if it is requested with a "package require" command. */ typedef struct PkgAvail { char *version; /* Version string; malloc'ed. */ char *script; /* Script to invoke to provide this version of * the package. Malloc'ed and protected by * Tcl_Preserve and Tcl_Release. */ struct PkgAvail *nextPtr; /* Next in list of available versions of the * same package. */ } PkgAvail; /* * For each package that is known in any way to an interpreter, there is one * record of the following type. These records are stored in the * "packageTable" hash table in the interpreter, keyed by package name such as * "Tk" (no version number). */ typedef struct Package { char *version; /* Version that has been supplied in this * interpreter via "package provide" * (malloc'ed). NULL means the package * doesn't exist in this interpreter yet. */ PkgAvail *availPtr; /* First in list of all available versions of * this package. */ ClientData clientData; /* Client data. */ } Package; /* * Prototypes for procedures defined in this file: */ static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp, CONST char *string)); static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1, CONST char *v2, int *satPtr)); static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); /* *---------------------------------------------------------------------- * * Tcl_PkgProvide / Tcl_PkgProvideEx -- * * This procedure is invoked to declare that a particular version of a * particular package is now present in an interpreter. There must not be * any other version of this package already provided in the interpreter. * * Results: * Normally returns TCL_OK; if there is already another version of the * package loaded then TCL_ERROR is returned and an error message is left * in the interp's result. * * Side effects: * The interpreter remembers that this package is available, so that no * other version of the package may be provided for the interpreter. * *---------------------------------------------------------------------- */ int Tcl_PkgProvide(interp, name, version) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of package. */ CONST char *version; /* Version string for package. */ { return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL); } int Tcl_PkgProvideEx(interp, name, version, clientData) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of package. */ CONST char *version; /* Version string for package. */ ClientData clientData; /* clientdata for this package (normally used * for C callback function table) */ { Package *pkgPtr; pkgPtr = FindPackage(interp, name); if (pkgPtr->version == NULL) { pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1)); strcpy(pkgPtr->version, version); |
︙ | ︙ | |||
121 122 123 124 125 126 127 | } /* *---------------------------------------------------------------------- * * Tcl_PkgRequire / Tcl_PkgRequireEx -- * | | | | | | < | | < | | | | | | | | | < | | | | < | | | | | | | | | | | | | | | | | | | < | | | | | | < | | | | | | | | | | | | | < | | | | | | | | | | | | | < | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_PkgRequire / Tcl_PkgRequireEx -- * * This procedure is called by code that depends on a particular version * of a particular package. If the package is not already provided in the * interpreter, this procedure invokes a Tcl script to provide it. If the * package is already provided, this procedure makes sure that the * caller's needs don't conflict with the version that is present. * * Results: * If successful, returns the version string for the currently provided * version of the package, which may be different from the "version" * argument. If the caller's requirements cannot be met (e.g. the version * requested conflicts with a currently provided version, or the required * version cannot be found, or the script to provide the required version * generates an error), NULL is returned and an error message is left in * the interp's result. * * Side effects: * The script from some previous "package ifneeded" command may be * invoked to provide the package. * *---------------------------------------------------------------------- */ CONST char * Tcl_PkgRequire(interp, name, version, exact) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of desired package. */ CONST char *version; /* Version string for desired version; NULL * means use the latest version available. */ int exact; /* Non-zero means that only the particular * version given is acceptable. Zero means use * the latest compatible version. */ { return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL); } CONST char * Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of desired package. */ CONST char *version; /* Version string for desired version; NULL * means use the latest version available. */ int exact; /* Non-zero means that only the particular * version given is acceptable. Zero means use * the latest compatible version. */ ClientData *clientDataPtr; /* Used to return the client data for this * package. If it is NULL then the client data * is not returned. This is unchanged if this * call fails for any reason. */ { Package *pkgPtr; PkgAvail *availPtr, *bestPtr; char *script; int code, satisfies, result, pass; Tcl_DString command; /* * If an attempt is being made to load this into a standalone executable * on a platform where backlinking is not supported then this must be a * shared version of Tcl (Otherwise the load would have failed). Detect * this situation by checking that this library has been correctly * initialised. If it has not been then return immediately as nothing will * work. */ if (tclEmptyStringRep == NULL) { /* * OK, so what's going on here? * * First, what are we doing? We are performing a check on behalf of * one particular caller, Tcl_InitStubs(). When a package is stub- * enabled, it is statically linked to libtclstub.a, which contains a * copy of Tcl_InitStubs(). When a stub-enabled package is loaded, its * *_Init() function is supposed to call Tcl_InitStubs() before * calling any other functions in the Tcl library. The first Tcl * function called by Tcl_InitStubs() through the stub table is * Tcl_PkgRequireEx(), so this code right here is the first code that * is part of the original Tcl library in the executable that gets * executed on behalf of a newly loaded stub-enabled package. * * One easy error for the developer/builder of a stub-enabled package * to make is to forget to define USE_TCL_STUBS when compiling the * package. When that happens, the package will contain symbols that * are references to the Tcl library, rather than function pointers * referencing the stub table. On platforms that lack backlinking, * those unresolved references may cause the loading of the package to * also load a second copy of the Tcl library, leading to all kinds of * trouble. We would like to catch that error and report a useful * message back to the user. That's what we're doing. * * Second, how does this work? If we reach this point, then the global * variable tclEmptyStringRep has the value NULL. Compare that with * the definition of tclEmptyStringRep near the top of the file * generic/tclObj.c. It clearly should not have the value NULL; it * should point to the char tclEmptyString. If we see it having the * value NULL, then somehow we are seeing a Tcl library that isn't * completely initialized, and that's an indicator for the error * condition described above. (Further explanation is welcome.) * * Third, so what do we do about it? This situation indicates the * package we just loaded wasn't properly compiled to be stub-enabled, * yet it thinks it is stub-enabled (it called Tcl_InitStubs()). We * want to report that the package just loaded is broken, so we want * to place an error message in the interpreter result and return NULL * to indicate failure to Tcl_InitStubs() so that it will also fail. * (Further explanation why we don't want to Tcl_Panic() is welcome. * After all, two Tcl libraries can't be a good thing!) * * Trouble is that's going to be tricky. We're now using a Tcl library * that's not fully initialized. In particular, it doesn't have a * proper value for tclEmptyStringRep. The Tcl_Obj system heavily * depends on the value of tclEmptyStringRep and all of Tcl depends * (increasingly) on the Tcl_Obj system, we need to correct that flaw * before making the calls to set the interpreter result to the error * message. That's the only flaw corrected; other problems with * initialization of the Tcl library are not remedied, so be very * careful about adding any other calls here without checking how they * behave when initialization is incomplete. */ tclEmptyStringRep = &tclEmptyString; Tcl_AppendResult(interp, "Cannot load package \"", name, "\" in standalone executable: This package is not ", "compiled with stub support", NULL); return NULL; } /* * It can take up to three passes to find the package: one pass to run the * "package unknown" script, one to run the "package ifneeded" script for * a specific version, and a final pass to lookup the package loaded by * the "package ifneeded" script. */ for (pass = 1; ; pass++) { pkgPtr = FindPackage(interp, name); if (pkgPtr->version != NULL) { break; } /* * The package isn't yet present. Search the list of available * versions and invoke the script for the best available version. */ bestPtr = NULL; for (availPtr = pkgPtr->availPtr; availPtr != NULL; availPtr = availPtr->nextPtr) { if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version, bestPtr->version, (int *) NULL) <= 0)) { continue; } |
︙ | ︙ | |||
298 299 300 301 302 303 304 | } } bestPtr = availPtr; } if (bestPtr != NULL) { /* * We found an ifneeded script for the package. Be careful while | | | | | | 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 | } } bestPtr = availPtr; } if (bestPtr != NULL) { /* * We found an ifneeded script for the package. Be careful while * executing it: this could cause reentrancy, so (a) protect the * script itself from deletion and (b) don't assume that bestPtr * will still exist when the script completes. */ script = bestPtr->script; Tcl_Preserve((ClientData) script); code = Tcl_GlobalEval(interp, script); Tcl_Release((ClientData) script); if (code != TCL_OK) { if (code == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"package ifneeded\" script)"); } return NULL; } Tcl_ResetResult(interp); pkgPtr = FindPackage(interp, name); break; } /* * Package not in the database. If there is a "package unknown" * command, invoke it (but only on the first pass; after that, we * should not get here in the first place). */ if (pass > 1) { break; } script = ((Interp *) interp)->packageUnknown; if (script != NULL) { |
︙ | ︙ | |||
367 368 369 370 371 372 373 | /* * At this point we know that the package is present. Make sure that the * provided version meets the current requirement. */ if (version == NULL) { | | | | | | | < | | | | | < | | | | < | | | | | < | | | | | | | | | | | | | | 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 | /* * At this point we know that the package is present. Make sure that the * provided version meets the current requirement. */ if (version == NULL) { if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } return pkgPtr->version; } result = ComparePkgVersions(pkgPtr->version, version, &satisfies); if ((satisfies && !exact) || (result == 0)) { if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } return pkgPtr->version; } Tcl_AppendResult(interp, "version conflict for package \"", name, "\": have ", pkgPtr->version, ", need ", version, (char *) NULL); return NULL; } /* *---------------------------------------------------------------------- *q * Tcl_PkgPresent / Tcl_PkgPresentEx -- * * Checks to see whether the specified package is present. If it is not * then no additional action is taken. * * Results: * If successful, returns the version string for the currently provided * version of the package, which may be different from the "version" * argument. If the caller's requirements cannot be met (e.g. the version * requested conflicts with a currently provided version), NULL is * returned and an error message is left in interp->result. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_PkgPresent(interp, name, version, exact) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of desired package. */ CONST char *version; /* Version string for desired version; NULL * means use the latest version available. */ int exact; /* Non-zero means that only the particular * version given is acceptable. Zero means use * the latest compatible version. */ { return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL); } CONST char * Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ CONST char *name; /* Name of desired package. */ CONST char *version; /* Version string for desired version; NULL * means use the latest version available. */ int exact; /* Non-zero means that only the particular * version given is acceptable. Zero means use * the latest compatible version. */ ClientData *clientDataPtr; /* Used to return the client data for this * package. If it is NULL then the client data * is not returned. This is unchanged if this * call fails for any reason. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Package *pkgPtr; int satisfies, result; hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); if (hPtr) { pkgPtr = (Package *) Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { /* * At this point we know that the package is present. Make sure * that the provided version meets the current requirement. */ if (version == NULL) { if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } return pkgPtr->version; } result = ComparePkgVersions(pkgPtr->version, version, &satisfies); if ((satisfies && !exact) || (result == 0)) { if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } return pkgPtr->version; } Tcl_AppendResult(interp, "version conflict for package \"", name, "\": have ", pkgPtr->version, ", need ", version, (char *) NULL); return NULL; } } if (version != NULL) { Tcl_AppendResult(interp, "package ", name, " ", version, " is not present", (char *) NULL); } else { Tcl_AppendResult(interp, "package ", name, " is not present", (char *) NULL); } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_PackageObjCmd -- * * This procedure is invoked to process the "package" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_PackageObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *pkgOptions[] = { "forget", "ifneeded", "names", "present", "provide", "require", "unknown", "vcompare", "versions", "vsatisfies", (char *) NULL }; enum pkgOptions { |
︙ | ︙ | |||
530 531 532 533 534 535 536 | Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *tablePtr; CONST char *version; char *argv2, *argv3, *argv4; if (objc < 2) { | | | | > | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | > | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | < | | < | | | | < | 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 | Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *tablePtr; CONST char *version; char *argv2, *argv3, *argv4; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum pkgOptions) optionIndex) { case PKG_FORGET: { char *keyString; for (i = 2; i < objc; i++) { keyString = Tcl_GetString(objv[i]); hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); if (hPtr == NULL) { continue; } pkgPtr = (Package *) Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (pkgPtr->version != NULL) { ckfree(pkgPtr->version); } while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr->nextPtr; ckfree(availPtr->version); Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); ckfree((char *) availPtr); } ckfree((char *) pkgPtr); } break; } case PKG_IFNEEDED: { int length; if ((objc != 4) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); return TCL_ERROR; } argv3 = Tcl_GetString(objv[3]); if (CheckVersion(interp, argv3) != TCL_OK) { return TCL_ERROR; } argv2 = Tcl_GetString(objv[2]); if (objc == 4) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr == NULL) { return TCL_OK; } pkgPtr = (Package *) Tcl_GetHashValue(hPtr); } else { pkgPtr = FindPackage(interp, argv2); } argv3 = Tcl_GetStringFromObj(objv[3], &length); for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; prevPtr = availPtr, availPtr = availPtr->nextPtr) { if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL)==0){ if (objc == 4) { Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); return TCL_OK; } Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); break; } } if (objc == 4) { return TCL_OK; } if (availPtr == NULL) { availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); availPtr->version = ckalloc((unsigned) (length + 1)); strcpy(availPtr->version, argv3); if (prevPtr == NULL) { availPtr->nextPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr; } else { availPtr->nextPtr = prevPtr->nextPtr; prevPtr->nextPtr = availPtr; } } argv4 = Tcl_GetStringFromObj(objv[4], &length); availPtr->script = ckalloc((unsigned) (length + 1)); strcpy(availPtr->script, argv4); break; } case PKG_NAMES: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } tablePtr = &iPtr->packageTable; for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { pkgPtr = (Package *) Tcl_GetHashValue(hPtr); if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); } } break; case PKG_PRESENT: if (objc < 3) { presentSyntax: Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); return TCL_ERROR; } argv2 = Tcl_GetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { exact = 1; } else { exact = 0; } version = NULL; if (objc == (4 + exact)) { version = Tcl_GetString(objv[3 + exact]); if (CheckVersion(interp, version) != TCL_OK) { return TCL_ERROR; } } else if ((objc != 3) || exact) { goto presentSyntax; } if (exact) { argv3 = Tcl_GetString(objv[3]); version = Tcl_PkgPresent(interp, argv3, version, exact); } else { version = Tcl_PkgPresent(interp, argv2, version, exact); } if (version == NULL) { return TCL_ERROR; } Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); break; case PKG_PROVIDE: if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); return TCL_ERROR; } argv2 = Tcl_GetString(objv[2]); if (objc == 3) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { pkgPtr = (Package *) Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); } } return TCL_OK; } argv3 = Tcl_GetString(objv[3]); if (CheckVersion(interp, argv3) != TCL_OK) { return TCL_ERROR; } return Tcl_PkgProvide(interp, argv2, argv3); case PKG_REQUIRE: if (objc < 3) { requireSyntax: Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); return TCL_ERROR; } argv2 = Tcl_GetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { exact = 1; } else { exact = 0; } version = NULL; if (objc == (4 + exact)) { version = Tcl_GetString(objv[3 + exact]); if (CheckVersion(interp, version) != TCL_OK) { return TCL_ERROR; } } else if ((objc != 3) || exact) { goto requireSyntax; } if (exact) { argv3 = Tcl_GetString(objv[3]); version = Tcl_PkgRequire(interp, argv3, version, exact); } else { version = Tcl_PkgRequire(interp, argv2, version, exact); } if (version == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewStringObj(version, -1)); break; case PKG_UNKNOWN: { int length; if (objc == 2) { if (iPtr->packageUnknown != NULL) { Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); } } else if (objc == 3) { if (iPtr->packageUnknown != NULL) { ckfree(iPtr->packageUnknown); } argv2 = Tcl_GetStringFromObj(objv[2], &length); if (argv2[0] == 0) { iPtr->packageUnknown = NULL; } else { iPtr->packageUnknown = (char *) ckalloc((unsigned) (length+1)); strcpy(iPtr->packageUnknown, argv2); } } else { Tcl_WrongNumArgs(interp, 2, objv, "?command?"); return TCL_ERROR; } break; } case PKG_VCOMPARE: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); return TCL_ERROR; } argv3 = Tcl_GetString(objv[3]); argv2 = Tcl_GetString(objv[2]); if ((CheckVersion(interp, argv2) != TCL_OK) || (CheckVersion(interp, argv3) != TCL_OK)) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj( ComparePkgVersions(argv2, argv3, (int *) NULL))); break; case PKG_VERSIONS: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "package"); return TCL_ERROR; } argv2 = Tcl_GetString(objv[2]); hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { pkgPtr = (Package *) Tcl_GetHashValue(hPtr); for (availPtr = pkgPtr->availPtr; availPtr != NULL; availPtr = availPtr->nextPtr) { Tcl_AppendElement(interp, availPtr->version); } } break; case PKG_VSATISFIES: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); return TCL_ERROR; } argv3 = Tcl_GetString(objv[3]); argv2 = Tcl_GetString(objv[2]); if ((CheckVersion(interp, argv2) != TCL_OK) || (CheckVersion(interp, argv3) != TCL_OK)) { return TCL_ERROR; } ComparePkgVersions(argv2, argv3, &satisfies); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); break; default: Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); } return TCL_OK; } /* *---------------------------------------------------------------------- * * FindPackage -- * * This procedure finds the Package record for a particular package in a * particular interpreter, creating a record if one doesn't already * exist. * * Results: * The return value is a pointer to the Package record for the package. * * Side effects: * A new Package record may be created. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
843 844 845 846 847 848 849 | } /* *---------------------------------------------------------------------- * * TclFreePackageInfo -- * | | | < | 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 | } /* *---------------------------------------------------------------------- * * TclFreePackageInfo -- * * This procedure is called during interpreter deletion to free all of * the package-related information for the interpreter. * * Results: * None. * * Side effects: * Memory is freed. * |
︙ | ︙ | |||
891 892 893 894 895 896 897 | } /* *---------------------------------------------------------------------- * * CheckVersion -- * | | | | | | | | | | | | | | | | < | | | | | | | | | | < | | | 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 | } /* *---------------------------------------------------------------------- * * CheckVersion -- * * This procedure checks to see whether a version number has valid * syntax. * * Results: * If string is a properly formed version number the TCL_OK is returned. * Otherwise TCL_ERROR is returned and an error message is left in the * interp's result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int CheckVersion(interp, string) Tcl_Interp *interp; /* Used for error reporting. */ CONST char *string; /* Supposedly a version number, which is * groups of decimal digits separated by * dots. */ { CONST char *p = string; char prevChar; if (!isdigit(UCHAR(*p))) { /* INTL: digit */ goto error; } for (prevChar = *p, p++; *p != 0; p++) { if (!isdigit(UCHAR(*p)) && ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */ goto error; } prevChar = *p; } if (prevChar != '.') { return TCL_OK; } error: Tcl_AppendResult(interp, "expected version number but got \"", string, "\"", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * ComparePkgVersions -- * * This procedure compares two version numbers. * * Results: * The return value is -1 if v1 is less than v2, 0 if the two version * numbers are the same, and 1 if v1 is greater than v2. If *satPtr is * non-NULL, the word it points to is filled in with 1 if v2 >= v1 and * both numbers have the same major number or 0 otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ComparePkgVersions(v1, v2, satPtr) CONST char *v1; CONST char *v2; /* Versions strings, of form 2.1.3 (any number * of version numbers). */ int *satPtr; /* If non-null, the word pointed to is filled * in with a 0/1 value. 1 means v1 "satisfies" * v2: v1 is greater than or equal to v2 and * both version numbers have the same major * number. */ { int thisIsMajor, n1, n2; /* * Each iteration of the following loop processes one number from each * string, terminated by a ".". If those numbers don't match then the * comparison is over; otherwise, we loop back for the next number. */ thisIsMajor = 1; while (1) { /* * Parse one decimal number from the front of each string. */ n1 = n2 = 0; while ((*v1 != 0) && (*v1 != '.')) { n1 = 10*n1 + (*v1 - '0'); v1++; } while ((*v2 != 0) && (*v2 != '.')) { n2 = 10*n2 + (*v2 - '0'); v2++; } /* * Compare and go on to the next version number if the current numbers * match. */ if (n1 != n2) { break; } if (*v1 != 0) { v1++; |
︙ | ︙ | |||
1020 1021 1022 1023 1024 1025 1026 | return 1; } else if (n1 == n2) { return 0; } else { return -1; } } | > > > > > > > > | 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 | return 1; } else if (n1 == n2) { return 0; } else { return -1; } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclPkgConfig.c.
|
| | | | | | | | | | | | | | | | | < | | > | | > | | > | | > | | > | | > | | > | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | /* * tclPkgConfig.c -- * * This file contains the configuration information to embed into the tcl * binary library. * * Copyright (c) 2002 Andreas Kupries <[email protected]> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclPkgConfig.c,v 1.2.4.1 2005/08/02 18:16:06 dgp Exp $ */ /* Note, the definitions in this module are influenced by the following C * preprocessor macros: * * OSCMa = shortcut for "old style configuration macro activates" * NSCMdt = shortcut for "new style configuration macro declares that" * * - TCL_THREADS OSCMa compilation as threaded core. * - TCL_MEM_DEBUG OSCMa memory debugging. * - TCL_COMPILE_DEBUG OSCMa debugging of bytecode compiler. * - TCL_COMPILE_STATS OSCMa bytecode compiler statistics. * * - TCL_CFG_DO64BIT NSCMdt tcl is compiled for a 64bit system. * - TCL_CFG_DEBUG NSCMdt tcl is compiled with symbol info on. * - TCL_CFG_OPTIMIZED NSCMdt tcl is compiled with cc optimizations on * - TCL_CFG_PROFILED NSCMdt tcl is compiled with profiling info. * * - CFG_RUNTIME_* Paths to various stuff at runtime. * - CFG_INSTALL_* Paths to various stuff at installation time. * * - TCL_CFGVAL_ENCODING string containing the encoding used for the * configuration values. */ #include "tclInt.h" /* * Use C preprocessor statements to define the various values for the embedded * configuration information. */ #ifdef TCL_THREADS # define CFG_THREADED "1" #else # define CFG_THREADED "0" #endif #ifdef TCL_MEM_DEBUG # define CFG_MEMDEBUG "1" #else # define CFG_MEMDEBUG "0" #endif #ifdef TCL_COMPILE_DEBUG # define CFG_COMPILE_DEBUG "1" #else # define CFG_COMPILE_DEBUG "0" #endif #ifdef TCL_COMPILE_STATS # define CFG_COMPILE_STATS "1" #else # define CFG_COMPILE_STATS "0" #endif #ifdef TCL_CFG_DO64BIT # define CFG_64 "1" #else # define CFG_64 "0" #endif #ifdef TCL_CFG_DEBUG # define CFG_DEBUG "1" #else # define CFG_DEBUG "0" #endif #ifdef TCL_CFG_OPTIMIZED # define CFG_OPTIMIZED "1" #else # define CFG_OPTIMIZED "0" #endif #ifdef TCL_CFG_PROFILED # define CFG_PROFILED "1" #else # define CFG_PROFILED "0" #endif static Tcl_Config cfg[] = { {"debug", CFG_DEBUG}, {"threaded", CFG_THREADED}, {"profiled", CFG_PROFILED}, {"64bit", CFG_64}, {"optimized", CFG_OPTIMIZED}, {"mem_debug", CFG_MEMDEBUG}, {"compile_debug", CFG_COMPILE_DEBUG}, {"compile_stats", CFG_COMPILE_STATS}, /* Runtime paths to various stuff */ {"libdir,runtime", CFG_RUNTIME_LIBDIR}, {"bindir,runtime", CFG_RUNTIME_BINDIR}, {"scriptdir,runtime", CFG_RUNTIME_SCRDIR}, {"includedir,runtime", CFG_RUNTIME_INCDIR}, {"docdir,runtime", CFG_RUNTIME_DOCDIR}, /* Installation paths to various stuff */ {"libdir,install", CFG_INSTALL_LIBDIR}, {"bindir,install", CFG_INSTALL_BINDIR}, {"scriptdir,install", CFG_INSTALL_SCRDIR}, {"includedir,install", CFG_INSTALL_INCDIR}, {"docdir,install", CFG_INSTALL_DOCDIR}, /* Last entry, closes the array */ {NULL, NULL} }; void TclInitEmbeddedConfigurationInformation(interp) Tcl_Interp* interp; /* Interpreter the configuration command is * registered in. */ { Tcl_RegisterConfig(interp, "tcl", cfg, TCL_CFGVAL_ENCODING); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclPort.h.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclPort.h -- * * This header file handles porting issues that occur because * of differences between systems. It reads in platform specific * portability files. * * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | < > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | /* * tclPort.h -- * * This header file handles porting issues that occur because * of differences between systems. It reads in platform specific * portability files. * * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclPort.h,v 1.13.2.2 2005/01/20 19:13:50 kennykb Exp $ */ #ifndef _TCLPORT #define _TCLPORT #ifdef HAVE_TCL_CONFIG_H #include "tclConfig.h" #endif #include "tcl.h" #if defined(__WIN32__) # include "../win/tclWinPort.h" #else # include "tclUnixPort.h" #endif |
︙ | ︙ |
Changes to generic/tclPosixStr.c.
1 2 3 | /* * tclPosixStr.c -- * | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 | /* * tclPosixStr.c -- * * This file contains procedures that generate strings corresponding to * various POSIX-related codes, such as errno and signals. * * Copyright (c) 1991-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: tclPosixStr.c,v 1.10.2.1 2005/08/02 18:16:06 dgp Exp $ */ #include "tclInt.h" /* *---------------------------------------------------------------------- * * Tcl_ErrnoId -- * * Return a textual identifier for the current errno value. * * Results: * This procedure returns a machine-readable textual identifier that * corresponds to the current errno value (e.g. "EPERM"). The identifier * is the same as the #define name in errno.h. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_ErrnoId() { switch (errno) { #ifdef E2BIG case E2BIG: return "E2BIG"; #endif #ifdef EACCES case EACCES: return "EACCES"; #endif #ifdef EADDRINUSE case EADDRINUSE: return "EADDRINUSE"; #endif #ifdef EADDRNOTAVAIL case EADDRNOTAVAIL: return "EADDRNOTAVAIL"; #endif #ifdef EADV case EADV: return "EADV"; #endif #ifdef EAFNOSUPPORT case EAFNOSUPPORT: return "EAFNOSUPPORT"; #endif #ifdef EAGAIN case EAGAIN: return "EAGAIN"; #endif #ifdef EALIGN case EALIGN: return "EALIGN"; #endif #if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) case EALREADY: return "EALREADY"; #endif #ifdef EBADE case EBADE: return "EBADE"; #endif #ifdef EBADF case EBADF: return "EBADF"; #endif #ifdef EBADFD case EBADFD: return "EBADFD"; #endif #ifdef EBADMSG case EBADMSG: return "EBADMSG"; #endif #ifdef EBADR case EBADR: return "EBADR"; #endif #ifdef EBADRPC case EBADRPC: return "EBADRPC"; #endif #ifdef EBADRQC case EBADRQC: return "EBADRQC"; #endif #ifdef EBADSLT case EBADSLT: return "EBADSLT"; #endif #ifdef EBFONT case EBFONT: return "EBFONT"; #endif #ifdef EBUSY case EBUSY: return "EBUSY"; #endif #ifdef ECHILD case ECHILD: return "ECHILD"; #endif #ifdef ECHRNG case ECHRNG: return "ECHRNG"; #endif #ifdef ECOMM case ECOMM: return "ECOMM"; #endif #ifdef ECONNABORTED case ECONNABORTED: return "ECONNABORTED"; #endif #ifdef ECONNREFUSED case ECONNREFUSED: return "ECONNREFUSED"; #endif #ifdef ECONNRESET case ECONNRESET: return "ECONNRESET"; #endif #if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) case EDEADLK: return "EDEADLK"; #endif #if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK)) case EDEADLOCK: return "EDEADLOCK"; #endif #ifdef EDESTADDRREQ case EDESTADDRREQ: return "EDESTADDRREQ"; #endif #ifdef EDIRTY case EDIRTY: return "EDIRTY"; #endif #ifdef EDOM case EDOM: return "EDOM"; #endif #ifdef EDOTDOT case EDOTDOT: return "EDOTDOT"; #endif #ifdef EDQUOT case EDQUOT: return "EDQUOT"; #endif #ifdef EDUPPKG case EDUPPKG: return "EDUPPKG"; #endif #ifdef EEXIST case EEXIST: return "EEXIST"; #endif #ifdef EFAULT case EFAULT: return "EFAULT"; #endif #ifdef EFBIG case EFBIG: return "EFBIG"; #endif #ifdef EHOSTDOWN case EHOSTDOWN: return "EHOSTDOWN"; #endif #ifdef EHOSTUNREACH case EHOSTUNREACH: return "EHOSTUNREACH"; #endif #if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) case EIDRM: return "EIDRM"; #endif #ifdef EINIT case EINIT: return "EINIT"; #endif #ifdef EINPROGRESS case EINPROGRESS: return "EINPROGRESS"; #endif #ifdef EINTR case EINTR: return "EINTR"; #endif #ifdef EINVAL case EINVAL: return "EINVAL"; #endif #ifdef EIO case EIO: return "EIO"; #endif #ifdef EISCONN case EISCONN: return "EISCONN"; #endif #ifdef EISDIR case EISDIR: return "EISDIR"; #endif #ifdef EISNAME case EISNAM: return "EISNAM"; #endif #ifdef ELBIN case ELBIN: return "ELBIN"; #endif #ifdef EL2HLT case EL2HLT: return "EL2HLT"; #endif #ifdef EL2NSYNC case EL2NSYNC: return "EL2NSYNC"; #endif #ifdef EL3HLT case EL3HLT: return "EL3HLT"; #endif #ifdef EL3RST case EL3RST: return "EL3RST"; #endif #ifdef ELIBACC case ELIBACC: return "ELIBACC"; #endif #ifdef ELIBBAD case ELIBBAD: return "ELIBBAD"; #endif #ifdef ELIBEXEC case ELIBEXEC: return "ELIBEXEC"; #endif #ifdef ELIBMAX case ELIBMAX: return "ELIBMAX"; #endif #ifdef ELIBSCN case ELIBSCN: return "ELIBSCN"; #endif #ifdef ELNRNG case ELNRNG: return "ELNRNG"; #endif #if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) case ELOOP: return "ELOOP"; #endif #ifdef EMFILE case EMFILE: return "EMFILE"; #endif #ifdef EMLINK case EMLINK: return "EMLINK"; #endif #ifdef EMSGSIZE case EMSGSIZE: return "EMSGSIZE"; #endif #ifdef EMULTIHOP case EMULTIHOP: return "EMULTIHOP"; #endif #ifdef ENAMETOOLONG case ENAMETOOLONG: return "ENAMETOOLONG"; #endif #ifdef ENAVAIL case ENAVAIL: return "ENAVAIL"; #endif #ifdef ENET case ENET: return "ENET"; #endif #ifdef ENETDOWN case ENETDOWN: return "ENETDOWN"; #endif #ifdef ENETRESET case ENETRESET: return "ENETRESET"; #endif #ifdef ENETUNREACH case ENETUNREACH: return "ENETUNREACH"; #endif #ifdef ENFILE case ENFILE: return "ENFILE"; #endif #ifdef ENOANO case ENOANO: return "ENOANO"; #endif #if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) case ENOBUFS: return "ENOBUFS"; #endif #ifdef ENOCSI case ENOCSI: return "ENOCSI"; #endif #if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) case ENODATA: return "ENODATA"; #endif #ifdef ENODEV case ENODEV: return "ENODEV"; #endif #ifdef ENOENT case ENOENT: return "ENOENT"; #endif #ifdef ENOEXEC case ENOEXEC: return "ENOEXEC"; #endif #ifdef ENOLCK case ENOLCK: return "ENOLCK"; #endif #ifdef ENOLINK case ENOLINK: return "ENOLINK"; #endif #ifdef ENOMEM case ENOMEM: return "ENOMEM"; #endif #ifdef ENOMSG case ENOMSG: return "ENOMSG"; #endif #ifdef ENONET case ENONET: return "ENONET"; #endif #ifdef ENOPKG case ENOPKG: return "ENOPKG"; #endif #ifdef ENOPROTOOPT case ENOPROTOOPT: return "ENOPROTOOPT"; #endif #ifdef ENOSPC case ENOSPC: return "ENOSPC"; #endif #if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) case ENOSR: return "ENOSR"; #endif #if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) case ENOSTR: return "ENOSTR"; #endif #ifdef ENOSYM case ENOSYM: return "ENOSYM"; #endif #ifdef ENOSYS case ENOSYS: return "ENOSYS"; #endif #ifdef ENOTBLK case ENOTBLK: return "ENOTBLK"; #endif #ifdef ENOTCONN case ENOTCONN: return "ENOTCONN"; #endif #ifdef ENOTDIR case ENOTDIR: return "ENOTDIR"; #endif #if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) case ENOTEMPTY: return "ENOTEMPTY"; #endif #ifdef ENOTNAM case ENOTNAM: return "ENOTNAM"; #endif #ifdef ENOTSOCK case ENOTSOCK: return "ENOTSOCK"; #endif #ifdef ENOTSUP case ENOTSUP: return "ENOTSUP"; #endif #ifdef ENOTTY case ENOTTY: return "ENOTTY"; #endif #ifdef ENOTUNIQ case ENOTUNIQ: return "ENOTUNIQ"; #endif #ifdef ENXIO case ENXIO: return "ENXIO"; #endif #if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) case EOPNOTSUPP: return "EOPNOTSUPP"; #endif #if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) ) case EOVERFLOW: return "EOVERFLOW"; #endif #ifdef EPERM case EPERM: return "EPERM"; #endif #if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) case EPFNOSUPPORT: return "EPFNOSUPPORT"; #endif #ifdef EPIPE case EPIPE: return "EPIPE"; #endif #ifdef EPROCLIM case EPROCLIM: return "EPROCLIM"; #endif #ifdef EPROCUNAVAIL case EPROCUNAVAIL: return "EPROCUNAVAIL"; #endif #ifdef EPROGMISMATCH case EPROGMISMATCH: return "EPROGMISMATCH"; #endif #ifdef EPROGUNAVAIL case EPROGUNAVAIL: return "EPROGUNAVAIL"; #endif #ifdef EPROTO case EPROTO: return "EPROTO"; #endif #ifdef EPROTONOSUPPORT case EPROTONOSUPPORT: return "EPROTONOSUPPORT"; #endif #ifdef EPROTOTYPE case EPROTOTYPE: return "EPROTOTYPE"; #endif #ifdef ERANGE case ERANGE: return "ERANGE"; #endif #if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) case EREFUSED: return "EREFUSED"; #endif #ifdef EREMCHG case EREMCHG: return "EREMCHG"; #endif #ifdef EREMDEV case EREMDEV: return "EREMDEV"; #endif #ifdef EREMOTE case EREMOTE: return "EREMOTE"; #endif #ifdef EREMOTEIO case EREMOTEIO: return "EREMOTEIO"; #endif #ifdef EREMOTERELEASE case EREMOTERELEASE: return "EREMOTERELEASE"; #endif #ifdef EROFS case EROFS: return "EROFS"; #endif #ifdef ERPCMISMATCH case ERPCMISMATCH: return "ERPCMISMATCH"; #endif #ifdef ERREMOTE case ERREMOTE: return "ERREMOTE"; #endif #ifdef ESHUTDOWN case ESHUTDOWN: return "ESHUTDOWN"; #endif #ifdef ESOCKTNOSUPPORT case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT"; #endif #ifdef ESPIPE case ESPIPE: return "ESPIPE"; #endif #ifdef ESRCH case ESRCH: return "ESRCH"; #endif #ifdef ESRMNT case ESRMNT: return "ESRMNT"; #endif #ifdef ESTALE case ESTALE: return "ESTALE"; #endif #ifdef ESUCCESS case ESUCCESS: return "ESUCCESS"; #endif #if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) case ETIME: return "ETIME"; #endif #if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) case ETIMEDOUT: return "ETIMEDOUT"; #endif #ifdef ETOOMANYREFS case ETOOMANYREFS: return "ETOOMANYREFS"; #endif #ifdef ETXTBSY case ETXTBSY: return "ETXTBSY"; #endif #ifdef EUCLEAN case EUCLEAN: return "EUCLEAN"; #endif #ifdef EUNATCH case EUNATCH: return "EUNATCH"; #endif #ifdef EUSERS case EUSERS: return "EUSERS"; #endif #ifdef EVERSION case EVERSION: return "EVERSION"; #endif #if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) case EWOULDBLOCK: return "EWOULDBLOCK"; #endif #ifdef EXDEV case EXDEV: return "EXDEV"; #endif #ifdef EXFULL case EXFULL: return "EXFULL"; #endif } return "unknown error"; } /* *---------------------------------------------------------------------- * * Tcl_ErrnoMsg -- * * Return a human-readable message corresponding to a given errno value. * * Results: * The return value is the standard POSIX error message for errno. This * procedure is used instead of strerror because strerror returns * slightly different values on different machines (e.g. different * capitalizations), which cause problems for things such as regression * tests. This procedure provides messages for most standard errors, then * it calls strerror for things it doesn't understand. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_ErrnoMsg(err) int err; /* Error number (such as in errno variable). */ { switch (err) { #ifdef E2BIG case E2BIG: return "argument list too long"; #endif #ifdef EACCES case EACCES: return "permission denied"; #endif #ifdef EADDRINUSE case EADDRINUSE: return "address already in use"; #endif #ifdef EADDRNOTAVAIL case EADDRNOTAVAIL: return "can't assign requested address"; #endif #ifdef EADV case EADV: return "advertise error"; #endif #ifdef EAFNOSUPPORT case EAFNOSUPPORT: return "address family not supported by protocol family"; #endif #ifdef EAGAIN case EAGAIN: return "resource temporarily unavailable"; #endif #ifdef EALIGN case EALIGN: return "EALIGN"; #endif #if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) case EALREADY: return "operation already in progress"; #endif #ifdef EBADE case EBADE: return "bad exchange descriptor"; #endif #ifdef EBADF case EBADF: return "bad file number"; #endif #ifdef EBADFD case EBADFD: return "file descriptor in bad state"; #endif #ifdef EBADMSG case EBADMSG: return "not a data message"; #endif #ifdef EBADR case EBADR: return "bad request descriptor"; #endif #ifdef EBADRPC case EBADRPC: return "RPC structure is bad"; #endif #ifdef EBADRQC case EBADRQC: return "bad request code"; #endif #ifdef EBADSLT case EBADSLT: return "invalid slot"; #endif #ifdef EBFONT case EBFONT: return "bad font file format"; #endif #ifdef EBUSY case EBUSY: return "file busy"; #endif #ifdef ECHILD case ECHILD: return "no children"; #endif #ifdef ECHRNG case ECHRNG: return "channel number out of range"; #endif #ifdef ECOMM case ECOMM: return "communication error on send"; #endif #ifdef ECONNABORTED case ECONNABORTED: return "software caused connection abort"; #endif #ifdef ECONNREFUSED case ECONNREFUSED: return "connection refused"; #endif #ifdef ECONNRESET case ECONNRESET: return "connection reset by peer"; #endif #if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) case EDEADLK: return "resource deadlock avoided"; #endif #if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK)) case EDEADLOCK: return "resource deadlock avoided"; #endif #ifdef EDESTADDRREQ case EDESTADDRREQ: return "destination address required"; #endif #ifdef EDIRTY case EDIRTY: return "mounting a dirty fs w/o force"; #endif #ifdef EDOM case EDOM: return "math argument out of range"; #endif #ifdef EDOTDOT case EDOTDOT: return "cross mount point"; #endif #ifdef EDQUOT case EDQUOT: return "disk quota exceeded"; #endif #ifdef EDUPPKG case EDUPPKG: return "duplicate package name"; #endif #ifdef EEXIST case EEXIST: return "file already exists"; #endif #ifdef EFAULT case EFAULT: return "bad address in system call argument"; #endif #ifdef EFBIG case EFBIG: return "file too large"; #endif #ifdef EHOSTDOWN case EHOSTDOWN: return "host is down"; #endif #ifdef EHOSTUNREACH case EHOSTUNREACH: return "host is unreachable"; #endif #if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) case EIDRM: return "identifier removed"; #endif #ifdef EINIT case EINIT: return "initialization error"; #endif #ifdef EINPROGRESS case EINPROGRESS: return "operation now in progress"; #endif #ifdef EINTR case EINTR: return "interrupted system call"; #endif #ifdef EINVAL case EINVAL: return "invalid argument"; #endif #ifdef EIO case EIO: return "I/O error"; #endif #ifdef EISCONN case EISCONN: return "socket is already connected"; #endif #ifdef EISDIR case EISDIR: return "illegal operation on a directory"; #endif #ifdef EISNAME case EISNAM: return "is a name file"; #endif #ifdef ELBIN case ELBIN: return "ELBIN"; #endif #ifdef EL2HLT case EL2HLT: return "level 2 halted"; #endif #ifdef EL2NSYNC case EL2NSYNC: return "level 2 not synchronized"; #endif #ifdef EL3HLT case EL3HLT: return "level 3 halted"; #endif #ifdef EL3RST case EL3RST: return "level 3 reset"; #endif #ifdef ELIBACC case ELIBACC: return "can not access a needed shared library"; #endif #ifdef ELIBBAD case ELIBBAD: return "accessing a corrupted shared library"; #endif #ifdef ELIBEXEC case ELIBEXEC: return "can not exec a shared library directly"; #endif #ifdef ELIBMAX case ELIBMAX: return "attempting to link in more shared libraries than system limit"; #endif #ifdef ELIBSCN case ELIBSCN: return ".lib section in a.out corrupted"; #endif #ifdef ELNRNG case ELNRNG: return "link number out of range"; #endif #if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) case ELOOP: return "too many levels of symbolic links"; #endif #ifdef EMFILE case EMFILE: return "too many open files"; #endif #ifdef EMLINK case EMLINK: return "too many links"; #endif #ifdef EMSGSIZE case EMSGSIZE: return "message too long"; #endif #ifdef EMULTIHOP case EMULTIHOP: return "multihop attempted"; #endif #ifdef ENAMETOOLONG case ENAMETOOLONG: return "file name too long"; #endif #ifdef ENAVAIL case ENAVAIL: return "not available"; #endif #ifdef ENET case ENET: return "ENET"; #endif #ifdef ENETDOWN case ENETDOWN: return "network is down"; #endif #ifdef ENETRESET case ENETRESET: return "network dropped connection on reset"; #endif #ifdef ENETUNREACH case ENETUNREACH: return "network is unreachable"; #endif #ifdef ENFILE case ENFILE: return "file table overflow"; #endif #ifdef ENOANO case ENOANO: return "anode table overflow"; #endif #if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) case ENOBUFS: return "no buffer space available"; #endif #ifdef ENOCSI case ENOCSI: return "no CSI structure available"; #endif #if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) case ENODATA: return "no data available"; #endif #ifdef ENODEV case ENODEV: return "no such device"; #endif #ifdef ENOENT case ENOENT: return "no such file or directory"; #endif #ifdef ENOEXEC case ENOEXEC: return "exec format error"; #endif #ifdef ENOLCK case ENOLCK: return "no locks available"; #endif #ifdef ENOLINK case ENOLINK: return "link has be severed"; #endif #ifdef ENOMEM case ENOMEM: return "not enough memory"; #endif #ifdef ENOMSG case ENOMSG: return "no message of desired type"; #endif #ifdef ENONET case ENONET: return "machine is not on the network"; #endif #ifdef ENOPKG case ENOPKG: return "package not installed"; #endif #ifdef ENOPROTOOPT case ENOPROTOOPT: return "bad protocol option"; #endif #ifdef ENOSPC case ENOSPC: return "no space left on device"; #endif #if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) case ENOSR: return "out of stream resources"; #endif #if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) case ENOSTR: return "not a stream device"; #endif #ifdef ENOSYM case ENOSYM: return "unresolved symbol name"; #endif #ifdef ENOSYS case ENOSYS: return "function not implemented"; #endif #ifdef ENOTBLK case ENOTBLK: return "block device required"; #endif #ifdef ENOTCONN case ENOTCONN: return "socket is not connected"; #endif #ifdef ENOTDIR case ENOTDIR: return "not a directory"; #endif #if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) case ENOTEMPTY: return "directory not empty"; #endif #ifdef ENOTNAM case ENOTNAM: return "not a name file"; #endif #ifdef ENOTSOCK case ENOTSOCK: return "socket operation on non-socket"; #endif #ifdef ENOTSUP case ENOTSUP: return "operation not supported"; #endif #ifdef ENOTTY case ENOTTY: return "inappropriate device for ioctl"; #endif #ifdef ENOTUNIQ case ENOTUNIQ: return "name not unique on network"; #endif #ifdef ENXIO case ENXIO: return "no such device or address"; #endif #if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) case EOPNOTSUPP: return "operation not supported on socket"; #endif #if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) ) case EOVERFLOW: return "file too big"; #endif #ifdef EPERM case EPERM: return "not owner"; #endif #if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) case EPFNOSUPPORT: return "protocol family not supported"; #endif #ifdef EPIPE case EPIPE: return "broken pipe"; #endif #ifdef EPROCLIM case EPROCLIM: return "too many processes"; #endif #ifdef EPROCUNAVAIL case EPROCUNAVAIL: return "bad procedure for program"; #endif #ifdef EPROGMISMATCH case EPROGMISMATCH: return "program version wrong"; #endif #ifdef EPROGUNAVAIL case EPROGUNAVAIL: return "RPC program not available"; #endif #ifdef EPROTO case EPROTO: return "protocol error"; #endif #ifdef EPROTONOSUPPORT case EPROTONOSUPPORT: return "protocol not suppored"; #endif #ifdef EPROTOTYPE case EPROTOTYPE: return "protocol wrong type for socket"; #endif #ifdef ERANGE case ERANGE: return "math result unrepresentable"; #endif #if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) case EREFUSED: return "EREFUSED"; #endif #ifdef EREMCHG case EREMCHG: return "remote address changed"; #endif #ifdef EREMDEV case EREMDEV: return "remote device"; #endif #ifdef EREMOTE case EREMOTE: return "pathname hit remote file system"; #endif #ifdef EREMOTEIO case EREMOTEIO: return "remote i/o error"; #endif #ifdef EREMOTERELEASE case EREMOTERELEASE: return "EREMOTERELEASE"; #endif #ifdef EROFS case EROFS: return "read-only file system"; #endif #ifdef ERPCMISMATCH case ERPCMISMATCH: return "RPC version is wrong"; #endif #ifdef ERREMOTE case ERREMOTE: return "object is remote"; #endif #ifdef ESHUTDOWN case ESHUTDOWN: return "can't send afer socket shutdown"; #endif #ifdef ESOCKTNOSUPPORT case ESOCKTNOSUPPORT: return "socket type not supported"; #endif #ifdef ESPIPE case ESPIPE: return "invalid seek"; #endif #ifdef ESRCH case ESRCH: return "no such process"; #endif #ifdef ESRMNT case ESRMNT: return "srmount error"; #endif #ifdef ESTALE case ESTALE: return "stale remote file handle"; #endif #ifdef ESUCCESS case ESUCCESS: return "Error 0"; #endif #if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) case ETIME: return "timer expired"; #endif #if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) case ETIMEDOUT: return "connection timed out"; #endif #ifdef ETOOMANYREFS case ETOOMANYREFS: return "too many references: can't splice"; #endif #ifdef ETXTBSY case ETXTBSY: return "text file or pseudo-device busy"; #endif #ifdef EUCLEAN case EUCLEAN: return "structure needs cleaning"; #endif #ifdef EUNATCH case EUNATCH: return "protocol driver not attached"; #endif #ifdef EUSERS case EUSERS: return "too many users"; #endif #ifdef EVERSION case EVERSION: return "version mismatch"; #endif #if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) case EWOULDBLOCK: return "operation would block"; #endif #ifdef EXDEV case EXDEV: return "cross-domain link"; #endif #ifdef EXFULL case EXFULL: return "message tables full"; #endif default: #ifdef NO_STRERROR return "unknown POSIX error"; #else return strerror(errno); #endif } } /* *---------------------------------------------------------------------- * * Tcl_SignalId -- * * Return a textual identifier for a signal number. * * Results: * This procedure returns a machine-readable textual identifier that * corresponds to sig. The identifier is the same as the #define name in * signal.h. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_SignalId(sig) int sig; /* Number of signal. */ { switch (sig) { #ifdef SIGABRT case SIGABRT: return "SIGABRT"; #endif #ifdef SIGALRM case SIGALRM: return "SIGALRM"; #endif #ifdef SIGBUS case SIGBUS: return "SIGBUS"; #endif #ifdef SIGCHLD case SIGCHLD: return "SIGCHLD"; #endif #if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) case SIGCLD: return "SIGCLD"; #endif #ifdef SIGCONT case SIGCONT: return "SIGCONT"; #endif #if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) case SIGEMT: return "SIGEMT"; #endif #ifdef SIGFPE case SIGFPE: return "SIGFPE"; #endif #ifdef SIGHUP case SIGHUP: return "SIGHUP"; #endif #ifdef SIGILL case SIGILL: return "SIGILL"; #endif #ifdef SIGINT case SIGINT: return "SIGINT"; #endif #ifdef SIGIO case SIGIO: return "SIGIO"; #endif #if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT)) case SIGIOT: return "SIGIOT"; #endif #ifdef SIGKILL case SIGKILL: return "SIGKILL"; #endif #if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO)) case SIGLOST: return "SIGLOST"; #endif #ifdef SIGPIPE case SIGPIPE: return "SIGPIPE"; #endif #if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) case SIGPOLL: return "SIGPOLL"; #endif #ifdef SIGPROF case SIGPROF: return "SIGPROF"; #endif #if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST)) case SIGPWR: return "SIGPWR"; #endif #ifdef SIGQUIT case SIGQUIT: return "SIGQUIT"; #endif #ifdef SIGSEGV case SIGSEGV: return "SIGSEGV"; #endif #ifdef SIGSTOP case SIGSTOP: return "SIGSTOP"; #endif #ifdef SIGSYS case SIGSYS: return "SIGSYS"; #endif #ifdef SIGTERM case SIGTERM: return "SIGTERM"; #endif #ifdef SIGTRAP case SIGTRAP: return "SIGTRAP"; #endif #ifdef SIGTSTP case SIGTSTP: return "SIGTSTP"; #endif #ifdef SIGTTIN case SIGTTIN: return "SIGTTIN"; #endif #ifdef SIGTTOU case SIGTTOU: return "SIGTTOU"; #endif #if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) case SIGURG: return "SIGURG"; #endif #if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) case SIGUSR1: return "SIGUSR1"; #endif #if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) case SIGUSR2: return "SIGUSR2"; #endif #ifdef SIGVTALRM case SIGVTALRM: return "SIGVTALRM"; #endif #ifdef SIGWINCH case SIGWINCH: return "SIGWINCH"; #endif #ifdef SIGXCPU case SIGXCPU: return "SIGXCPU"; #endif #ifdef SIGXFSZ case SIGXFSZ: return "SIGXFSZ"; #endif } return "unknown signal"; } /* *---------------------------------------------------------------------- * * Tcl_SignalMsg -- * * Return a human-readable message describing a signal. * * Results: * This procedure returns a string describing sig that should make sense * to a human. It may not be easy for a machine to parse. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_SignalMsg(sig) int sig; /* Number of signal. */ { switch (sig) { #ifdef SIGABRT case SIGABRT: return "SIGABRT"; #endif #ifdef SIGALRM case SIGALRM: return "alarm clock"; #endif #ifdef SIGBUS case SIGBUS: return "bus error"; #endif #ifdef SIGCHLD case SIGCHLD: return "child status changed"; #endif #if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) case SIGCLD: return "child status changed"; #endif #ifdef SIGCONT case SIGCONT: return "continue after stop"; #endif #if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) case SIGEMT: return "EMT instruction"; #endif #ifdef SIGFPE case SIGFPE: return "floating-point exception"; #endif #ifdef SIGHUP case SIGHUP: return "hangup"; #endif #ifdef SIGILL case SIGILL: return "illegal instruction"; #endif #ifdef SIGINT case SIGINT: return "interrupt"; #endif #ifdef SIGIO case SIGIO: return "input/output possible on file"; #endif #if defined(SIGIOT) && (!defined(SIGABRT) || (SIGABRT != SIGIOT)) case SIGIOT: return "IOT instruction"; #endif #ifdef SIGKILL case SIGKILL: return "kill signal"; #endif #if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO)) case SIGLOST: return "resource lost"; #endif #ifdef SIGPIPE case SIGPIPE: return "write on pipe with no readers"; #endif #if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) case SIGPOLL: return "input/output possible on file"; #endif #ifdef SIGPROF case SIGPROF: return "profiling alarm"; #endif #if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST)) case SIGPWR: return "power-fail restart"; #endif #ifdef SIGQUIT case SIGQUIT: return "quit signal"; #endif #ifdef SIGSEGV case SIGSEGV: return "segmentation violation"; #endif #ifdef SIGSTOP case SIGSTOP: return "stop"; #endif #ifdef SIGSYS case SIGSYS: return "bad argument to system call"; #endif #ifdef SIGTERM case SIGTERM: return "software termination signal"; #endif #ifdef SIGTRAP case SIGTRAP: return "trace trap"; #endif #ifdef SIGTSTP case SIGTSTP: return "stop signal from tty"; #endif #ifdef SIGTTIN case SIGTTIN: return "background tty read"; #endif #ifdef SIGTTOU case SIGTTOU: return "background tty write"; #endif #if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) case SIGURG: return "urgent I/O condition"; #endif #if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) case SIGUSR1: return "user-defined signal 1"; #endif #if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) case SIGUSR2: return "user-defined signal 2"; #endif #ifdef SIGVTALRM case SIGVTALRM: return "virtual time alarm"; #endif #ifdef SIGWINCH case SIGWINCH: return "window changed"; #endif #ifdef SIGXCPU case SIGXCPU: return "exceeded CPU time limit"; #endif #ifdef SIGXFSZ case SIGXFSZ: return "exceeded file size limit"; #endif } return "unknown signal"; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclPreserve.c.
|
| | | | < | | | | | | | | | | | | > > > > > | | | | < > > | | | | < | | | | | | < < < < < < < < | | | < | | | | | | | | | | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 | /* * tclPreserve.c -- * * This file contains a collection of functions that are used to make * sure that widget records and other data structures aren't reallocated * when there are nested functions that depend on their existence. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclPreserve.c,v 1.5.2.2 2005/08/02 18:16:07 dgp Exp $ */ #include "tclInt.h" /* * The following data structure is used to keep track of all the Tcl_Preserve * calls that are still in effect. It grows as needed to accommodate any * number of calls in effect. */ typedef struct { ClientData clientData; /* Address of preserved block. */ int refCount; /* Number of Tcl_Preserve calls in effect for * block. */ int mustFree; /* Non-zero means Tcl_EventuallyFree was * called while a Tcl_Preserve call was in * effect, so the structure must be freed when * refCount becomes zero. */ Tcl_FreeProc *freeProc; /* Function to call to free. */ } Reference; /* * Global data structures used to hold the list of preserved data references. * These variables are protected by "preserveMutex". */ static Reference *refArray; /* First in array of references. */ static int spaceAvl = 0; /* Total number of structures available at * *firstRefPtr. */ static int inUse = 0; /* Count of structures currently in use in * refArray. */ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ #define INITIAL_SIZE 2 /* Initial number of reference slots to make */ /* * The following data structure is used to keep track of whether an arbitrary * block of memory has been deleted. This is used by the TclHandle code to * avoid the more time-expensive algorithm of Tcl_Preserve(). This mechanism * is mainly used when we have lots of references to a few big, expensive * objects that we don't want to live any longer than necessary. */ typedef struct HandleStruct { VOID *ptr; /* Pointer to the memory block being tracked. * This field will become NULL when the memory * block is deleted. This field must be the * first in the structure. */ #ifdef TCL_MEM_DEBUG VOID *ptr2; /* Backup copy of the above pointer used to * ensure that the contents of the handle are * not changed by anyone else. */ #endif int refCount; /* Number of TclHandlePreserve() calls in * effect on this handle. */ } HandleStruct; /* *---------------------------------------------------------------------- * * TclFinalizePreserve -- * * Called during exit processing to clean up the reference array. * * Results: * None. * * Side effects: * Frees the storage of the reference array. * *---------------------------------------------------------------------- */ /* ARGSUSED */ void TclFinalizePreserve() { Tcl_MutexLock(&preserveMutex); if (spaceAvl != 0) { ckfree((char *) refArray); refArray = (Reference *) NULL; inUse = 0; spaceAvl = 0; } Tcl_MutexUnlock(&preserveMutex); } /* *---------------------------------------------------------------------- * * Tcl_Preserve -- * * This function is used by a function to declare its interest in a * particular block of memory, so that the block will not be reallocated * until a matching call to Tcl_Release has been made. * * Results: * None. * * Side effects: * Information is retained so that the block of memory will not be freed * until at least the matching call to Tcl_Release. * *---------------------------------------------------------------------- */ void Tcl_Preserve(clientData) ClientData clientData; /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; int i; /* * See if there is already a reference for this pointer. If so, just * increment its reference count. */ Tcl_MutexLock(&preserveMutex); for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) { if (refPtr->clientData == clientData) { refPtr->refCount++; Tcl_MutexUnlock(&preserveMutex); return; } } /* * Make a reference array if it doesn't already exist, or make it bigger * if it is full. */ if (inUse == spaceAvl) { if (spaceAvl == 0) { refArray = (Reference *) ckalloc((unsigned) (INITIAL_SIZE*sizeof(Reference))); spaceAvl = INITIAL_SIZE; } else { Reference *new; new = (Reference *) ckalloc((unsigned) |
︙ | ︙ | |||
183 184 185 186 187 188 189 | } /* *---------------------------------------------------------------------- * * Tcl_Release -- * | | | | | | < < < > > > | | | > > | > | | | | | | | | | | | | > > > > > > > > > | | | | < | < | | < < | | | | < | | | | > | 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 | } /* *---------------------------------------------------------------------- * * Tcl_Release -- * * This function is called to cancel a previous call to Tcl_Preserve, * thereby allowing a block of memory to be freed (if no one else cares * about it). * * Results: * None. * * Side effects: * If Tcl_EventuallyFree has been called for clientData, and if no other * call to Tcl_Preserve is still in effect, the block of memory is freed. * *---------------------------------------------------------------------- */ void Tcl_Release(clientData) ClientData clientData; /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; int i; Tcl_MutexLock(&preserveMutex); for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) { int mustFree; Tcl_FreeProc *freeProc; if (refPtr->clientData != clientData) { continue; } if (--refPtr->refCount != 0) { Tcl_MutexUnlock(&preserveMutex); return; } /* * Must remove information from the slot before calling freeProc to * avoid reentrancy problems if the freeProc calls Tcl_Preserve on the * same clientData. Copy down the last reference in the array to * overwrite the current slot. */ freeProc = refPtr->freeProc; mustFree = refPtr->mustFree; inUse--; if (i < inUse) { refArray[i] = refArray[inUse]; } /* * Now committed to disposing the data. But first, we've patched up * all the global data structures so we should release the mutex now. * Only then should we dabble around with potentially-slow memory * managers... */ Tcl_MutexUnlock(&preserveMutex); if (mustFree) { if (freeProc == TCL_DYNAMIC) { ckfree((char *) clientData); } else { (*freeProc)((char *) clientData); } } return; } Tcl_MutexUnlock(&preserveMutex); /* * Reference not found. This is a bug in the caller. */ Tcl_Panic("Tcl_Release couldn't find reference for 0x%x", clientData); } /* *---------------------------------------------------------------------- * * Tcl_EventuallyFree -- * * Free up a block of memory, unless a call to Tcl_Preserve is in effect * for that block. In this case, defer the free until all calls to * Tcl_Preserve have been undone by matching calls to Tcl_Release. * * Results: * None. * * Side effects: * Ptr may be released by calling free(). * *---------------------------------------------------------------------- */ void Tcl_EventuallyFree(clientData, freeProc) ClientData clientData; /* Pointer to malloc'ed block of memory. */ Tcl_FreeProc *freeProc; /* Function to actually do free. */ { Reference *refPtr; int i; /* * See if there is a reference for this pointer. If so, set its "mustFree" * flag (the flag had better not be set already!). */ Tcl_MutexLock(&preserveMutex); for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { if (refPtr->clientData != clientData) { continue; } if (refPtr->mustFree) { Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x\n", clientData); } refPtr->mustFree = 1; refPtr->freeProc = freeProc; Tcl_MutexUnlock(&preserveMutex); return; } Tcl_MutexUnlock(&preserveMutex); |
︙ | ︙ | |||
313 314 315 316 317 318 319 | } /* *--------------------------------------------------------------------------- * * TclHandleCreate -- * | | | | | | < | | | | | < | | | | | | < | | | | | 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 | } /* *--------------------------------------------------------------------------- * * TclHandleCreate -- * * Allocate a handle that contains enough information to determine if an * arbitrary malloc'd block has been deleted. This is used to avoid the * more time-expensive algorithm of Tcl_Preserve(). * * Results: * The return value is a TclHandle that refers to the given malloc'd * block. Doubly dereferencing the returned handle will give back the * pointer to the block, or will give NULL if the block has been deleted. * * Side effects: * The caller must keep track of this handle (generally by storing it in * a field in the malloc'd block) and call TclHandleFree() on this handle * when the block is deleted. Everything else that wishes to keep track * of whether the malloc'd block has been deleted should use calls to * TclHandlePreserve() and TclHandleRelease() on the associated handle. * *--------------------------------------------------------------------------- */ TclHandle TclHandleCreate(ptr) VOID *ptr; /* Pointer to an arbitrary block of memory to * be tracked for deletion. Must not be * NULL. */ { HandleStruct *handlePtr; handlePtr = (HandleStruct *) ckalloc(sizeof(HandleStruct)); handlePtr->ptr = ptr; #ifdef TCL_MEM_DEBUG handlePtr->ptr2 = ptr; #endif handlePtr->refCount = 0; return (TclHandle) handlePtr; } /* *--------------------------------------------------------------------------- * * TclHandleFree -- * * Called when the arbitrary malloc'd block associated with the handle is * being deleted. Modifies the handle so that doubly dereferencing it * will give NULL. This informs any user of the handle that the block of * memory formerly referenced by the handle has been freed. * * Results: * None. * * Side effects: * If nothing is referring to the handle, the handle will be reclaimed. * *--------------------------------------------------------------------------- */ void TclHandleFree(handle) TclHandle handle; /* Previously created handle associated with a * malloc'd block that is being deleted. The * handle is modified so that doubly * dereferencing it will give NULL. */ { HandleStruct *handlePtr; handlePtr = (HandleStruct *) handle; #ifdef TCL_MEM_DEBUG if (handlePtr->refCount == 0x61616161) { Tcl_Panic("using previously disposed TclHandle %x", handlePtr); |
︙ | ︙ | |||
401 402 403 404 405 406 407 | } /* *--------------------------------------------------------------------------- * * TclHandlePreserve -- * | | | | | | | | | < | | | | | | | | | < | > > > > > > > | 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 | } /* *--------------------------------------------------------------------------- * * TclHandlePreserve -- * * Declare an interest in the arbitrary malloc'd block associated with * the handle. * * Results: * The return value is the handle argument, with its ref count * incremented. * * Side effects: * For each call to TclHandlePreserve(), there should be a matching call * to TclHandleRelease() when the caller is no longer interested in the * malloc'd block associated with the handle. * *--------------------------------------------------------------------------- */ TclHandle TclHandlePreserve(handle) TclHandle handle; /* Declare an interest in the block of memory * referenced by this handle. */ { HandleStruct *handlePtr; handlePtr = (HandleStruct *) handle; #ifdef TCL_MEM_DEBUG if (handlePtr->refCount == 0x61616161) { Tcl_Panic("using previously disposed TclHandle %x", handlePtr); } if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) { Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif handlePtr->refCount++; return handle; } /* *--------------------------------------------------------------------------- * * TclHandleRelease -- * * This function is called to release an interest in the malloc'd block * associated with the handle. * * Results: * None. * * Side effects: * The ref count of the handle is decremented. If the malloc'd block has * been freed and if no one is using the handle any more, the handle will * be reclaimed. * *--------------------------------------------------------------------------- */ void TclHandleRelease(handle) TclHandle handle; /* Unregister interest in the block of memory * referenced by this handle. */ { HandleStruct *handlePtr; handlePtr = (HandleStruct *) handle; #ifdef TCL_MEM_DEBUG if (handlePtr->refCount == 0x61616161) { Tcl_Panic("using previously disposed TclHandle %x", handlePtr); } if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) { Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif handlePtr->refCount--; if ((handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) { ckfree((char *) handlePtr); } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclProc.c.
|
| | | | | | | > > > > | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | /* * 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.66.2.8 2005/09/27 18:42:54 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * Prototypes for static functions in this file */ static void ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr)); static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr)); static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp, char *procName, int nameLen, int returnCode)); static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); static void InitCompiledLocals _ANSI_ARGS_((Tcl_Interp *interp, ByteCode *codePtr, CompiledLocal *localPtr, Var *varPtr, Namespace *nsPtr)); /* * The ProcBodyObjType type */ Tcl_ObjType tclProcBodyType = { "procbody", /* name for this type */ ProcBodyFree, /* FreeInternalRep function */ ProcBodyDup, /* DupInternalRep function */ NULL, /* UpdateString function; Tcl_GetString and * Tcl_GetStringFromObj should panic * instead. */ NULL /* SetFromAny function; Tcl_ConvertToType * should panic instead. */ }; /* * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field, * encoding the type of level reference in ptr1 and the actual parsed out * offset in ptr2. * * Uses the default behaviour throughout, and never disposes of the string * rep; it's just a cache type. */ static Tcl_ObjType levelReferenceType = { "levelReference", NULL, NULL, NULL, NULL }; /* *---------------------------------------------------------------------- * * Tcl_ProcObjCmd -- * * This object-based function is invoked to process the "proc" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * * Side effects: * A new procedure gets created. |
︙ | ︙ | |||
91 92 93 94 95 96 97 | if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); return TCL_ERROR; } /* | | | | | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); return TCL_ERROR; } /* * Determine the namespace where the procedure should reside. Unless the * command name includes namespace qualifiers, this will be the current * namespace. */ fullName = TclGetString(objv[1]); TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL, 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { Tcl_AppendResult(interp, "can't create procedure \"", fullName, "\": unknown namespace", (char *) NULL); return TCL_ERROR; } if (procName == NULL) { |
︙ | ︙ | |||
121 122 123 124 125 126 127 128 129 130 131 132 133 | (char *) NULL); return TCL_ERROR; } /* * Create the data structure to represent the procedure. */ if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], &procPtr) != TCL_OK) { return TCL_ERROR; } /* | > | | > | | | | | | | | | > | | | | | | | | | | | | | < | | | > | 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 | (char *) NULL); return TCL_ERROR; } /* * Create the data structure to represent the procedure. */ if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], &procPtr) != TCL_OK) { return TCL_ERROR; } /* * Now create a command for the procedure. This will initially be in the * current namespace unless the procedure's name included namespace * qualifiers. To create the new command in the right namespace, we * generate a fully qualified name for it. */ Tcl_DStringInit(&ds); if (nsPtr != iPtr->globalNsPtr) { Tcl_DStringAppend(&ds, nsPtr->fullName, -1); Tcl_DStringAppend(&ds, "::", 2); } Tcl_DStringAppend(&ds, procName, -1); cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); Tcl_DStringFree(&ds); /* * Now initialize the new procedure's cmdPtr field. This will be used * later when the procedure is called to determine what namespace the * procedure will run in. This will be different than the current * namespace if the proc was renamed into a different namespace. */ procPtr->cmdPtr = (Command *) cmd; /* * Optimize for no-op procs: if the body is not precompiled (like a TclPro * procbody), and the argument list is just "args" and the body is empty, * define a compileProc to compile a no-op. * * Notes: * - cannot be done for any argument list without having different * compiled/not-compiled behaviour in the "wrong argument #" case, or * making this code much more complicated. In any case, it doesn't * seem to make a lot of sense to verify the number of arguments we * are about to ignore ... * - could be enhanced to handle also non-empty bodies that contain only * comments; however, parsing the body will slow down the compilation * of all procs whose argument list is just _args_ */ if (objv[3]->typePtr == &tclProcBodyType) { goto done; } procArgs = TclGetString(objv[2]); while (*procArgs == ' ') { procArgs++; } if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { procArgs +=4; while(*procArgs != '\0') { if (*procArgs != ' ') { goto done; } procArgs++; } /* * The argument list is just "args"; check the body */ procBody = TclGetString(objv[3]); while (*procBody != '\0') { if (!isspace(UCHAR(*procBody))) { goto done; } procBody++; } /* * The body is just spaces: link the compileProc */ ((Command *) cmd)->compileProc = TclCompileNoOp; } done: return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCreateProc -- * * Creates the data associated with a Tcl procedure definition. This * function knows how to handle two types of body objects: strings and * procbody. Strings are the traditional (and common) value for bodies, * procbody are values created by extensions that have loaded a * previously compiled script. * * Results: * Returns TCL_OK on success, along with a pointer to a Tcl procedure * definition in procPtrPtr where the cmdPtr field is not initialised. * This definition should be freed by calling TclProcCleanupProc() when * it is no longer needed. Returns TCL_ERROR if anything goes wrong. * * Side effects: * If anything goes wrong, this function returns an error message in the * interpreter. * *---------------------------------------------------------------------- */ int TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) Tcl_Interp *interp; /* interpreter containing proc */ Namespace *nsPtr; /* namespace containing this proc */ CONST char *procName; /* unqualified name of this proc */ Tcl_Obj *argsPtr; /* description of arguments */ Tcl_Obj *bodyPtr; /* command body */ |
︙ | ︙ | |||
272 273 274 275 276 277 278 | procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; } else { /* | | | | | | > | | | | | | | 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 | procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; } else { /* * If the procedure's body object is shared because its string value * is identical to, e.g., the body of another procedure, we must * create a private copy for this procedure to use. Such sharing of * procedure bodies is rare but can cause problems. A procedure body * is compiled in a context that includes the number of * compiler-allocated "slots" for local variables. Each formal * parameter is given a local variable slot (the * "procPtr->numCompiledLocals = numArgs" assignment below). This * means that the same code can not be shared by two procedures that * have a different number of arguments, even if their bodies are * identical. Note that we don't use Tcl_DuplicateObj since we would * not want any bytecode internal representation. */ if (Tcl_IsShared(bodyPtr)) { bytes = Tcl_GetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); } |
︙ | ︙ | |||
309 310 311 312 313 314 315 | procPtr->numArgs = 0; /* actual argument count is set below. */ procPtr->numCompiledLocals = 0; procPtr->firstLocalPtr = NULL; procPtr->lastLocalPtr = NULL; } /* | | < | | | > | > > | | | < > | 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 | procPtr->numArgs = 0; /* actual argument count is set below. */ procPtr->numCompiledLocals = 0; procPtr->firstLocalPtr = NULL; procPtr->lastLocalPtr = NULL; } /* * Break up the argument list into argument specifiers, then process each * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. * * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS. */ args = Tcl_GetStringFromObj(argsPtr, &length); result = Tcl_SplitList(interp, args, &numArgs, &argArray); if (result != TCL_OK) { goto procError; } if (precompiled) { if (numArgs > procPtr->numArgs) { Tcl_Obj *objPtr = Tcl_NewObj(); TclObjPrintf(NULL, objPtr, "procedure \"%s\": arg list contains %d entries, " "precompiled header expects %d", procName, numArgs, procPtr->numArgs); Tcl_SetObjResult(interp, objPtr); goto procError; } localPtr = procPtr->firstLocalPtr; } else { procPtr->numArgs = numArgs; procPtr->numCompiledLocals = numArgs; } for (i = 0; i < numArgs; i++) { int fieldCount, nameLength, valueLength; CONST char **fieldValues; /* * Now divide the specifier up into name and default. */ |
︙ | ︙ | |||
402 403 404 405 406 407 408 | goto procError; } p++; } if (precompiled) { /* | | | | | | | | | | | > | > | | < > > > > > > > > | | | 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 | goto procError; } p++; } if (precompiled) { /* * Compare the parsed argument with the stored one. For the flags, * we and out VAR_UNDEFINED to support bridging precompiled <= 8.3 * code in 8.4 where this is now used as an optimization * indicator. Yes, this is a hack. -- hobbs */ if ((localPtr->nameLength != nameLength) || (strcmp(localPtr->name, fieldValues[0])) || (localPtr->frameIndex != i) || ((localPtr->flags & ~VAR_UNDEFINED) != (VAR_SCALAR | VAR_ARGUMENT)) || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { Tcl_Obj *objPtr = Tcl_NewObj(); TclObjPrintf(NULL, objPtr, "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i); Tcl_SetObjResult(interp, objPtr); ckfree((char *) fieldValues); goto procError; } /* * compare the default value if any */ if (localPtr->defValuePtr != NULL) { int tmpLength; char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, &tmpLength); if ((valueLength != tmpLength) || strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { Tcl_Obj *objPtr = Tcl_NewObj(); TclObjPrintf(NULL, objPtr, "procedure \"%s\": formal parameter \"%s\" has " "default value inconsistent with precompiled body", procName, fieldValues[0]); Tcl_SetObjResult(interp, objPtr); ckfree((char *) fieldValues); goto procError; } if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') && (strcmp(localPtr->name, "args") == 0)) { localPtr->flags |= VAR_IS_ARGS; } } localPtr = localPtr->nextPtr; } else { /* * Allocate an entry in the runtime procedure frame's array of * local variables for the argument. */ localPtr = (CompiledLocal *) ckalloc((unsigned) (sizeof(CompiledLocal) - sizeof(localPtr->name) + nameLength + 1)); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { procPtr->lastLocalPtr->nextPtr = localPtr; procPtr->lastLocalPtr = localPtr; |
︙ | ︙ | |||
473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 | localPtr->defValuePtr = Tcl_NewStringObj(fieldValues[1], valueLength); Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } strcpy(localPtr->name, fieldValues[0]); } ckfree((char *) fieldValues); } *procPtrPtr = procPtr; ckfree((char *) argArray); return TCL_OK; | > > > > > > | | 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 | localPtr->defValuePtr = Tcl_NewStringObj(fieldValues[1], valueLength); Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } strcpy(localPtr->name, fieldValues[0]); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') && (strcmp(localPtr->name, "args") == 0)) { localPtr->flags |= VAR_IS_ARGS; } } ckfree((char *) fieldValues); } *procPtrPtr = procPtr; ckfree((char *) argArray); return TCL_OK; procError: if (precompiled) { procPtr->refCount--; } else { Tcl_DecrRefCount(bodyPtr); while (procPtr->firstLocalPtr != NULL) { localPtr = procPtr->firstLocalPtr; procPtr->firstLocalPtr = localPtr->nextPtr; |
︙ | ︙ | |||
511 512 513 514 515 516 517 | } /* *---------------------------------------------------------------------- * * TclGetFrame -- * | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TclGetFrame -- * * Given a description of a procedure frame, such as the first argument * to an "uplevel" or "upvar" command, locate the call frame for the * appropriate level of procedure. * * Results: * The return value is -1 if an error occurred in finding the frame (in * this case an error message is left in the interp's result). 1 is * returned if string was either a number or a number preceded by "#" and * it specified a valid frame. 0 is returned if string isn't one of the * two things above (in this case, the lookup acts as if string were * "1"). The variable pointed to by framePtrPtr is filled in with the * address of the desired frame (unless an error occurs, in which case it * isn't modified). * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclGetFrame(interp, name, framePtrPtr) Tcl_Interp *interp; /* Interpreter in which to find frame. */ CONST char *name; /* String describing frame. */ CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL if * global frame indicated). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; CallFrame *framePtr; /* * Parse string to figure out which level number to go to. |
︙ | ︙ | |||
562 563 564 565 566 567 568 | } level = curLevel - level; } else { level = curLevel - 1; result = 0; } | > | > | | | | | | | | | | | | | | | > | > | > > > > > > | > > > > | > > | > | | | | 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 | } level = curLevel - level; } else { level = curLevel - 1; result = 0; } /* * Figure out which frame to use, and return it to the caller. */ if (level == 0) { framePtr = NULL; } else { for (framePtr = iPtr->varFramePtr; framePtr != NULL; framePtr = framePtr->callerVarPtr) { if (framePtr->level == level) { break; } } if (framePtr == NULL) { goto levelError; } } *framePtrPtr = framePtr; return result; levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", (char *) NULL); return -1; } /* *---------------------------------------------------------------------- * * TclObjGetFrame -- * * Given a description of a procedure frame, such as the first argument * to an "uplevel" or "upvar" command, locate the call frame for the * appropriate level of procedure. * * Results: * The return value is -1 if an error occurred in finding the frame (in * this case an error message is left in the interp's result). 1 is * returned if objPtr was either a number or a number preceded by "#" and * it specified a valid frame. 0 is returned if objPtr isn't one of the * two things above (in this case, the lookup acts as if objPtr were * "1"). The variable pointed to by framePtrPtr is filled in with the * address of the desired frame (unless an error occurs, in which case it * isn't modified). * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclObjGetFrame(interp, objPtr, framePtrPtr) Tcl_Interp *interp; /* Interpreter in which to find frame. */ Tcl_Obj *objPtr; /* Object describing frame. */ CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL if * global frame indicated). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; CallFrame *framePtr; CONST char *name = TclGetString(objPtr); /* * Parse object to figure out which level number to go to. */ result = 1; curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; if (objPtr->typePtr == &levelReferenceType) { if ((int) objPtr->internalRep.twoPtrValue.ptr1) { level = curLevel - (int) objPtr->internalRep.twoPtrValue.ptr2; } else { level = (int) objPtr->internalRep.twoPtrValue.ptr2; } if (level < 0) { goto levelError; } /* TODO: Consider skipping the typePtr checks */ } else if (objPtr->typePtr == &tclIntType #ifndef NO_WIDE_TYPE || objPtr->typePtr == &tclWideIntType #endif ) { if (Tcl_GetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) { goto levelError; } level = curLevel - level; } else { if (*name == '#') { if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { goto levelError; } /* * Cache for future reference. * * TODO: Use the new ptrAndLongRep intrep */ TclFreeIntRep(objPtr); objPtr->typePtr = &levelReferenceType; objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 0; objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level; } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ if (Tcl_GetInt(interp, name, &level) != TCL_OK) { return -1; } /* * Cache for future reference. * * TODO: Use the new ptrAndLongRep intrep */ TclFreeIntRep(objPtr); objPtr->typePtr = &levelReferenceType; objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 1; objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level; level = curLevel - level; } else { /* * Don't cache as the object *isn't* a level reference. */ level = curLevel - 1; result = 0; } } /* * Figure out which frame to use, and return it to the caller. */ if (level == 0) { framePtr = NULL; } else { for (framePtr = iPtr->varFramePtr; framePtr != NULL; framePtr = framePtr->callerVarPtr) { if (framePtr->level == level) { break; } } if (framePtr == NULL) { goto levelError; } } *framePtrPtr = framePtr; return result; levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", (char *) NULL); return -1; } /* *---------------------------------------------------------------------- * * Tcl_UplevelObjCmd -- * * This object function is invoked to process the "uplevel" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
731 732 733 734 735 736 737 | Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr, *framePtr; if (objc < 2) { | | | 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 | Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr, *framePtr; if (objc < 2) { uplevelSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; } /* * Find the level to use for executing the command. */ |
︙ | ︙ | |||
766 767 768 769 770 771 772 | */ if (objc == 1) { result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT); } else { /* * More than one argument: concatenate them together with spaces | | | > < | | | | | | | | < | | | | 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 | */ if (objc == 1) { result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT); } else { /* * More than one argument: concatenate them together with spaces * between, then evaluate the result. Tcl_EvalObjEx will delete the * object when it decrements its refcount after eval'ing it. */ Tcl_Obj *objPtr; objPtr = Tcl_ConcatObj(objc, objv); result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { TclFormatToErrorInfo(interp, "\n (\"uplevel\" body line %d)", interp->errorLine); } /* * Restore the variable frame, and return. */ iPtr->varFramePtr = savedVarFramePtr; return result; } /* *---------------------------------------------------------------------- * * TclFindProc -- * * Given the name of a procedure, return a pointer to the record * describing the procedure. The procedure will be looked up using the * usual rules: first in the current namespace and then in the global * namespace. * * Results: * NULL is returned if the name doesn't correspond to any procedure. * Otherwise, the return value is a pointer to the procedure's record. If * the name is found but refers to an imported command that points to a * "real" procedure defined in another namespace, a pointer to that * "real" procedure's structure is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
846 847 848 849 850 851 852 | *---------------------------------------------------------------------- * * TclIsProc -- * * Tells whether a command is a Tcl procedure or not. * * Results: | | | | | 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 | *---------------------------------------------------------------------- * * TclIsProc -- * * Tells whether a command is a Tcl procedure or not. * * Results: * If the given command is actually a Tcl procedure, the return value is * the address of the record describing the procedure. Otherwise the * return value is 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
875 876 877 878 879 880 881 882 883 | } return (Proc *) 0; } /* *---------------------------------------------------------------------- * * TclObjInterpProc -- * | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 | } return (Proc *) 0; } /* *---------------------------------------------------------------------- * * InitCompiledLocals -- * * This routine is invoked in order to initialize the compiled locals * table for a new call frame. * * Results: * None. * * Side effects: * May invoke various name resolvers in order to determine which * variables are being referenced at runtime. * *---------------------------------------------------------------------- */ static void InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr) Tcl_Interp *interp; /* Current interpreter. */ ByteCode *codePtr; CompiledLocal *localPtr; Var *varPtr; Namespace *nsPtr; /* Pointer to current namespace. */ { Interp *iPtr = (Interp*) interp; int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr); CompiledLocal *firstLocalPtr; if (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS) { /* * This is the first run after a recompile, or else the resolver epoch * has changed: update the resolver cache. */ firstLocalPtr = localPtr; for (; localPtr != NULL; localPtr = localPtr->nextPtr) { if (localPtr->resolveInfo) { if (localPtr->resolveInfo->deleteProc) { localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); } else { ckfree((char*)localPtr->resolveInfo); } localPtr->resolveInfo = NULL; } localPtr->flags &= ~VAR_RESOLVED; if (haveResolvers && !(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) { ResolverScheme *resPtr = iPtr->resolverPtr; Tcl_ResolvedVarInfo *vinfo; int result; if (nsPtr->compiledVarResProc) { result = (*nsPtr->compiledVarResProc)(nsPtr->interp, localPtr->name, localPtr->nameLength, (Tcl_Namespace *) nsPtr, &vinfo); } else { result = TCL_CONTINUE; } while ((result == TCL_CONTINUE) && resPtr) { if (resPtr->compiledVarResProc) { result = (*resPtr->compiledVarResProc)(nsPtr->interp, localPtr->name, localPtr->nameLength, (Tcl_Namespace *) nsPtr, &vinfo); } resPtr = resPtr->nextPtr; } if (result == TCL_OK) { localPtr->resolveInfo = vinfo; localPtr->flags |= VAR_RESOLVED; } } } localPtr = firstLocalPtr; codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS; } /* * Initialize the array of local variables stored in the call frame. Some * variables may have special resolution rules. In that case, we call * their "resolver" procs to get our hands on the variable, and we make * the compiled local a link to the real variable. */ if (haveResolvers) { Tcl_ResolvedVarInfo *resVarInfo; for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { 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; /* * Now invoke the resolvers to determine the exact variables that * should be used. */ resVarInfo = localPtr->resolveInfo; if (resVarInfo && resVarInfo->fetchProc) { Var *resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, resVarInfo); if (resolvedVarPtr) { resolvedVarPtr->refCount++; varPtr->value.linkPtr = resolvedVarPtr; varPtr->flags = VAR_LINK; } } } } else { for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { 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; } } } /* *---------------------------------------------------------------------- * * TclInitCompiledLocals -- * * This routine is invoked in order to initialize the compiled locals * table for a new call frame. * * DEPRECATED: functionality has been inlined elsewhere; this function * remains to insure binary compatibility with Itcl. * * Results: * None. * * Side effects: * May invoke various name resolvers in order to determine which * variables are being referenced at runtime. * *---------------------------------------------------------------------- */ void TclInitCompiledLocals(interp, framePtr, nsPtr) Tcl_Interp *interp; /* Current interpreter. */ CallFrame *framePtr; /* Call frame to initialize. */ Namespace *nsPtr; /* Pointer to current namespace. */ { Var *varPtr = framePtr->compiledLocals; Tcl_Obj *bodyPtr; ByteCode *codePtr; CompiledLocal *localPtr = framePtr->procPtr->firstLocalPtr; bodyPtr = framePtr->procPtr->bodyPtr; if (bodyPtr->typePtr != &tclByteCodeType) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); } /* *---------------------------------------------------------------------- * * TclObjInterpProc -- * * When a Tcl procedure gets invoked during bytecode evaluation, this * object-based routine gets invoked to interpret the procedure. * * Results: * A standard Tcl object result value. * * Side effects: * Depends on the commands in the procedure. |
︙ | ︙ | |||
901 902 903 904 905 906 907 | * invoked. */ int objc; /* Count of number of arguments to this * procedure. */ Tcl_Obj *CONST objv[]; /* Argument value objects. */ { register Proc *procPtr = (Proc *) clientData; Namespace *nsPtr = procPtr->cmdPtr->nsPtr; | | < | < < < < < < < < < | | | | < | < < < < < < < < < < | | | | > | | > > | > > | > < < | | | | > > | | < < | | > > > > > | > | < > | > > > > > > > > > > > | > > | < < | | | | | | | < < | | | < < | | | < | < > | > > | > | > > > > | > > > > > > > > > > > > > > > > > > > | 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 | * invoked. */ int objc; /* Count of number of arguments to this * procedure. */ Tcl_Obj *CONST objv[]; /* Argument value objects. */ { register Proc *procPtr = (Proc *) clientData; Namespace *nsPtr = procPtr->cmdPtr->nsPtr; CallFrame *framePtr, **framePtrPtr; register Var *varPtr; register CompiledLocal *localPtr; char *procName; int nameLen, localCt, numArgs, argCt, i, imax, result; Var *compiledLocals; /* * Get the procedure's name. */ procName = Tcl_GetStringFromObj(objv[0], &nameLen); /* * If necessary, compile the procedure's body. The compiler will allocate * frame slots for the procedure's non-argument local variables. Note that * compiling the body might increase procPtr->numCompiledLocals if new * local variables are found while compiling. */ result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, "body of proc", procName); if (result != TCL_OK) { return result; } /* * Set up and push a new call frame for the new procedure invocation. * This call frame will execute in the proc's namespace, which might be * different than the current namespace. The proc's namespace is that of * its command, which can change if the command is renamed from one * namespace to another. */ framePtrPtr = &framePtr; result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, FRAME_IS_PROC); if (result != TCL_OK) { return result; } framePtr->objc = objc; framePtr->objv = objv; /* ref counts for args are incremented below */ framePtr->procPtr = procPtr; /* * Create the "compiledLocals" array. Make sure it is large enough to hold * all the procedure's compiled local variables, including its formal * parameters. */ localCt = procPtr->numCompiledLocals; compiledLocals = (Var *) TclStackAlloc(interp, localCt*sizeof(Var)); framePtr->numCompiledLocals = localCt; framePtr->compiledLocals = compiledLocals; /* * Match and assign the call's actual parameters to the procedure's formal * arguments. The formal arguments are described by the first numArgs * entries in both the Proc structure's local variable list and the call * frame's local variable array. */ numArgs = procPtr->numArgs; argCt = objc-1; /* set it to the number of args to the proc */ varPtr = framePtr->compiledLocals; localPtr = procPtr->firstLocalPtr; if (numArgs == 0) { if (argCt) { goto incorrectArgs; } else { goto runProc; } } imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1)); for (i = 1; i <= imax; i++) { /* * "Normal" arguments; last formal is special, depends on it being * 'args'. */ Tcl_Obj *objPtr = objv[i]; varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* local var is a reference */ varPtr->name = localPtr->name; varPtr->nsPtr = NULL; varPtr->hPtr = NULL; varPtr->refCount = 0; varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; varPtr->flags = localPtr->flags; varPtr++; localPtr = localPtr->nextPtr; } for (; i < numArgs; i++) { /* * This loop is entered if argCt < (numArgs-1). Set default values; * last formal is special. */ if (localPtr->defValuePtr != NULL) { Tcl_Obj *objPtr = localPtr->defValuePtr; varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* local var is a reference */ varPtr->name = localPtr->name; varPtr->nsPtr = NULL; varPtr->hPtr = NULL; varPtr->refCount = 0; varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; varPtr->flags = localPtr->flags; varPtr++; localPtr = localPtr->nextPtr; } else { goto incorrectArgs; } } /* * When we get here, the last formal argument remains to be defined: * localPtr and varPtr point to the last argument to be initialized. */ if (localPtr->flags & VAR_IS_ARGS) { Tcl_Obj *listPtr = Tcl_NewListObj(objc-numArgs, &(objv[numArgs])); varPtr->value.objPtr = listPtr; Tcl_IncrRefCount(listPtr); /* local var is a reference */ } else if (argCt == numArgs) { Tcl_Obj *objPtr = objv[numArgs]; varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* local var is a reference */ } else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) { Tcl_Obj *objPtr = localPtr->defValuePtr; varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* local var is a reference */ } else { Tcl_Obj **desiredObjs, *argObj; ByteCode *codePtr; /* * Do initialise all compiled locals, to avoid problems at * DeleteLocalVars. */ incorrectArgs: codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); /* * Build up desired argument list for Tcl_WrongNumArgs */ desiredObjs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1)); #ifdef AVOID_HACKS_FOR_ITCL desiredObjs[0] = objv[0]; #else desiredObjs[0] = Tcl_NewListObj(1, objv); #endif /* AVOID_HACKS_FOR_ITCL */ localPtr = procPtr->firstLocalPtr; for (i=1 ; i<=numArgs ; i++) { TclNewObj(argObj); if (localPtr->defValuePtr != NULL) { Tcl_AppendStringsToObj(argObj, "?", localPtr->name, "?", (char *) NULL); } else if ((i==numArgs) && !strcmp(localPtr->name, "args")) { |
︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 | for (i=0 ; i<=numArgs ; i++) { TclDecrRefCount(desiredObjs[i]); } #endif /* AVOID_HACKS_FOR_ITCL */ ckfree((char *) desiredObjs); goto procDone; } /* * Invoke the commands in the procedure's body. */ #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 1) { | > > > > > > > > > > > > > > > > > > > > > > > | 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 | for (i=0 ; i<=numArgs ; i++) { TclDecrRefCount(desiredObjs[i]); } #endif /* AVOID_HACKS_FOR_ITCL */ ckfree((char *) desiredObjs); goto procDone; } varPtr->name = localPtr->name; varPtr->nsPtr = NULL; varPtr->hPtr = NULL; varPtr->refCount = 0; varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; varPtr->flags = localPtr->flags; localPtr = localPtr->nextPtr; varPtr++; /* * Initialise and resolve the remaining compiledLocals. */ runProc: if (localPtr) { ByteCode *codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); } /* * Invoke the commands in the procedure's body. */ #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 1) { |
︙ | ︙ | |||
1107 1108 1109 1110 1111 1112 1113 | } if (result != TCL_OK) { result = ProcessProcResultCode(interp, procName, nameLen, result); } /* | | | | > | | > | > > | > > > | | < | | | | | | | | | | | | | | | | | | 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 | } if (result != TCL_OK) { result = ProcessProcResultCode(interp, procName, nameLen, result); } /* * Pop and free the call frame for this procedure invocation, then free * the compiledLocals array if malloc'ed storage was used. */ procDone: /* * Free the stack-allocated compiled locals and CallFrame. It is important * to pop the call frame without freeing it first: the compiledLocals * cannot be freed before the frame is popped, as the local variables must * be deleted. But the compiledLocals must be freed first, as they were * allocated later on the stack. */ Tcl_PopCallFrame(interp); /* pop but do not free */ TclStackFree(interp); /* free compiledLocals */ TclStackFree(interp); /* free CallFrame */ return result; #undef NUM_LOCALS } /* *---------------------------------------------------------------------- * * TclProcCompileProc -- * * Called just before a procedure is executed to compile the body to byte * codes. If the type of the body is not "byte code" or if the compile * conditions have changed (namespace context, epoch counters, etc.) then * the body is recompiled. Otherwise, this function does nothing. * * Results: * None. * * Side effects: * May change the internal representation of the body object to compiled * code. * *---------------------------------------------------------------------- */ int TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) Tcl_Interp *interp; /* Interpreter containing procedure. */ Proc *procPtr; /* Data associated with procedure. */ Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr, * but could be any code fragment compiled in * the context of this procedure.) */ Namespace *nsPtr; /* Namespace containing procedure. */ CONST char *description; /* string describing this body of code. */ CONST char *procName; /* Name of this procedure. */ { Interp *iPtr = (Interp*)interp; int result; Tcl_CallFrame *framePtr; Proc *saveProcPtr; ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; /* * If necessary, compile the procedure's body. The compiler will allocate * frame slots for the procedure's non-argument local variables. If the * ByteCode already exists, make sure it hasn't been invalidated by * someone redefining a core command (this might make the compiled code * wrong). Also, if the code was compiled in/for a different interpreter, * we recompile it. Note that compiling the body might increase * procPtr->numCompiledLocals if new local variables are found while * compiling. * * Precompiled procedure bodies, however, are immutable and therefore they * are not recompiled, even if things have changed. */ if (bodyPtr->typePtr == &tclByteCodeType) { if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr)) { if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { |
︙ | ︙ | |||
1194 1195 1196 1197 1198 1199 1200 | } } } if (bodyPtr->typePtr != &tclByteCodeType) { #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 1) { /* | | | > > | | | < | | | | | | > > > | | | < | < < < | < < < < < | | < < | < < < < < < < < < | | | | | | | | | | | | | < | < < | < < < | | | | | | | 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 | } } } if (bodyPtr->typePtr != &tclByteCodeType) { #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 1) { /* * Display a line summarizing the top level command we are about * to compile. */ Tcl_Obj *message = Tcl_NewStringObj("Compiling ", -1); Tcl_IncrRefCount(message); Tcl_AppendStringsToObj(message, description, " \"", NULL); TclAppendLimitedToObj(message, procName, -1, 50, NULL); fprintf(stdout, "%s\"\n", TclGetString(message)); Tcl_DecrRefCount(message); } #endif /* * Plug the current procPtr into the interpreter and coerce the code * body to byte codes. The interpreter needs to know which proc it's * compiling so that it can access its list of compiled locals. * * TRICKY NOTE: Be careful to push a call frame with the proper * namespace context, so that the byte codes are compiled in the * appropriate class context. */ saveProcPtr = iPtr->compiledProcPtr; iPtr->compiledProcPtr = procPtr; result = TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0); if (result == TCL_OK) { result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); TclPopStackFrame(interp); } iPtr->compiledProcPtr = saveProcPtr; if (result != TCL_OK) { if (result == TCL_ERROR) { int length = strlen(procName); int limit = 50; int overflow = (length > limit); TclFormatToErrorInfo(interp, "\n (compiling %s \"%.*s%s\", line %d)", description, (overflow ? limit : length), procName, (overflow ? "..." : ""), interp->errorLine); } return result; } } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { /* * The resolver epoch has changed, but we only need to invalidate the * resolver cache. */ codePtr->flags |= TCL_BYTECODE_RESOLVE_VARS; } return TCL_OK; } /* *---------------------------------------------------------------------- * * ProcessProcResultCode -- * * Function called by TclObjInterpProc to process a return code other * than TCL_OK returned by a Tcl procedure. * * Results: * Depending on the argument return code, the result returned is another * return code and the interpreter's result is set to a value to * supplement that return code. * * Side effects: * If the result returned is TCL_ERROR, traceback information about the * procedure just executed is appended to the interpreter's errorInfo * field. * *---------------------------------------------------------------------- */ static int ProcessProcResultCode(interp, procName, nameLen, returnCode) Tcl_Interp *interp; /* The interpreter in which the procedure was * called and returned returnCode. */ char *procName; /* Name of the procedure. Used for error * messages and trace information. */ int nameLen; /* Number of bytes in procedure's name. */ int returnCode; /* The unexpected result code. */ { Interp *iPtr = (Interp *) interp; int overflow, limit = 60; if (returnCode == TCL_OK) { return TCL_OK; } if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) { return returnCode; } if (returnCode == TCL_RETURN) { return TclUpdateReturnInfo(iPtr); } if (returnCode != TCL_ERROR) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "invoked \"", ((returnCode == TCL_BREAK) ? "break" : "continue"), "\" outside of a loop", NULL); } overflow = (nameLen > limit); TclFormatToErrorInfo(interp, "\n (procedure \"%.*s%s\" line %d)", (overflow ? limit : nameLen), procName, (overflow ? "..." : ""), interp->errorLine); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclProcDeleteProc -- * * This function is invoked just before a command procedure is removed * from an interpreter. Its job is to release all the resources allocated * to the procedure. * * Results: * None. * * Side effects: * Memory gets freed, unless the procedure is actively being executed. * In this case the cleanup is delayed until the last call to the current * procedure completes. * *---------------------------------------------------------------------- */ void TclProcDeleteProc(clientData) ClientData clientData; /* Procedure to be deleted. */ |
︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 | } /* *---------------------------------------------------------------------- * * TclProcCleanupProc -- * | | | < | 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 | } /* *---------------------------------------------------------------------- * * TclProcCleanupProc -- * * This function does all the real work of freeing up a Proc structure. * It's called only when the structure's reference count becomes zero. * * Results: * None. * * Side effects: * Memory gets freed. * |
︙ | ︙ | |||
1421 1422 1423 1424 1425 1426 1427 | } /* *---------------------------------------------------------------------- * * TclUpdateReturnInfo -- * | | | | | | | | > | > > | | | | | | | | | | < | 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 | } /* *---------------------------------------------------------------------- * * TclUpdateReturnInfo -- * * This function is called when procedures return, and at other points * where the TCL_RETURN code is used. It examines the returnLevel and * returnCode to determine the real return status. * * Results: * The return value is the true completion code to use for the procedure * or script, instead of TCL_RETURN. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclUpdateReturnInfo(iPtr) Interp *iPtr; /* Interpreter for which TCL_RETURN exception * is being processed. */ { int code = TCL_RETURN; iPtr->returnLevel--; if (iPtr->returnLevel < 0) { Tcl_Panic("TclUpdateReturnInfo: negative return level"); } if (iPtr->returnLevel == 0) { /* * Now we've reached the level to return the requested -code. */ code = iPtr->returnCode; } return code; } /* *---------------------------------------------------------------------- * * TclGetObjInterpProc -- * * Returns a pointer to the TclObjInterpProc function; this is different * from the value obtained from the TclObjInterpProc reference on systems * like Windows where import and export versions of a function exported * by a DLL exist. * * Results: * Returns the internal address of the TclObjInterpProc function. * * Side effects: * None. * *---------------------------------------------------------------------- */ TclObjCmdProcType TclGetObjInterpProc() { return (TclObjCmdProcType) TclObjInterpProc; } /* *---------------------------------------------------------------------- * * TclNewProcBodyObj -- * * Creates a new object, of type "procbody", whose internal * representation is the given Proc struct. The newly created object's * reference count is 0. * * Results: * Returns a pointer to a newly allocated Tcl_Obj, 0 on error. * * Side effects: * The reference count in the ByteCode attached to the Proc is bumped up * by one, since the internal rep stores a pointer to it. * *---------------------------------------------------------------------- */ Tcl_Obj * TclNewProcBodyObj(procPtr) Proc *procPtr; /* the Proc struct to store as the internal |
︙ | ︙ | |||
1526 1527 1528 1529 1530 1531 1532 | } /* *---------------------------------------------------------------------- * * ProcBodyDup -- * | | | < | 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 | } /* *---------------------------------------------------------------------- * * ProcBodyDup -- * * Tcl_ObjType's Dup function for the proc body object. Bumps the * reference count on the Proc stored in the internal representation. * * Results: * None. * * Side effects: * Sets up the object in dupPtr to be a duplicate of the one in srcPtr. * |
︙ | ︙ | |||
1556 1557 1558 1559 1560 1561 1562 | } /* *---------------------------------------------------------------------- * * ProcBodyFree -- * | | | | | | | | | | | | > > > > > > > > | 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 | } /* *---------------------------------------------------------------------- * * ProcBodyFree -- * * Tcl_ObjType's Free function for the proc body object. The reference * count on its Proc struct is decreased by 1; if the count reaches 0, * the proc is freed. * * Results: * None. * * Side effects: * If the reference count on the Proc struct reaches 0, the struct is * freed. * *---------------------------------------------------------------------- */ static void ProcBodyFree(objPtr) Tcl_Obj *objPtr; /* the object to clean up */ { Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr; procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } } /* *---------------------------------------------------------------------- * * TclCompileNoOp -- * * Function called to compile no-op's * * Results: * The return value is TCL_OK, indicating successful compilation. * * Side effects: * Instructions are added to envPtr to execute a no-op at runtime. * *---------------------------------------------------------------------- */ static int TclCompileNoOp(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 *tokenPtr; int i; int savedStackDepth = envPtr->currStackDepth; tokenPtr = parsePtr->tokenPtr; for(i = 1; i < parsePtr->numWords; i++) { tokenPtr = tokenPtr + tokenPtr->numComponents + 1; envPtr->currStackDepth = savedStackDepth; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); TclEmitOpcode(INST_POP, envPtr); } } envPtr->currStackDepth = savedStackDepth; TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclRegexp.c.
|
| | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 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 | /* * tclRegexp.c -- * * This file contains the public interfaces to the Tcl regular expression * mechanism. * * Copyright (c) 1998 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclRegexp.c,v 1.17.2.2 2005/08/02 18:16:07 dgp Exp $ */ #include "tclInt.h" #include "tclRegexp.h" /* *---------------------------------------------------------------------- * The routines in this file use Henry Spencer's regular expression package * contained in the following additional source files: * * regc_color.c regc_cvec.c regc_lex.c * regc_nfa.c regcomp.c regcustom.h * rege_dfa.c regerror.c regerrs.h * regex.h regexec.c regfree.c * regfronts.c regguts.h * * Copyright (c) 1998 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * * Redistribution and use in source and binary forms -- with or without * modification -- are permitted for any purpose, provided that * redistributions in source form retain this entire copyright notice and * indicate the origin and nature of any modifications. * * I'd appreciate being given credit for this package in the documentation of * software which uses it, but that is not a requirement. * * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY * AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL * HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
︙ | ︙ | |||
64 65 66 67 68 69 70 | * regular expressions. */ #define NUM_REGEXPS 30 typedef struct ThreadSpecificData { int initialized; /* Set to 1 when the module is initialized. */ | | | < | | | | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | * regular expressions. */ #define NUM_REGEXPS 30 typedef struct ThreadSpecificData { int initialized; /* Set to 1 when the module is initialized. */ char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular * expression patterns. NULL means that this * slot isn't used. Malloc-ed. */ int patLengths[NUM_REGEXPS];/* Number of non-null characters in * corresponding entry in patterns. -1 means * entry isn't used. */ struct TclRegexp *regexps[NUM_REGEXPS]; /* Compiled forms of above strings. Also * malloc-ed, or NULL if not in use yet. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * Declarations for functions used only in this file. |
︙ | ︙ | |||
96 97 98 99 100 101 102 | static int RegExpExecUniChar _ANSI_ARGS_((Tcl_Interp *interp, Tcl_RegExp re, CONST Tcl_UniChar *uniString, int numChars, int nmatches, int flags)); static int SetRegexpFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* | | | < | | | | | | < | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | static int RegExpExecUniChar _ANSI_ARGS_((Tcl_Interp *interp, Tcl_RegExp re, CONST Tcl_UniChar *uniString, int numChars, int nmatches, int flags)); static int SetRegexpFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* * The regular expression Tcl object type. This serves as a cache of the * compiled form of the regular expression. */ Tcl_ObjType tclRegexpType = { "regexp", /* name */ FreeRegexpInternalRep, /* freeIntRepProc */ DupRegexpInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetRegexpFromAny /* setFromAnyProc */ }; /* *---------------------------------------------------------------------- * * Tcl_RegExpCompile -- * * Compile a regular expression into a form suitable for fast matching. * This function is DEPRECATED in favor of the object version of the * command. * * Results: * The return value is a pointer to the compiled form of string, suitable * for passing to Tcl_RegExpExec. This compiled form is only valid up * until the next call to this function, so don't keep these around for a * long time! If an error occurred while compiling the pattern, then NULL * is returned and an error message is left in the interp's result. * * Side effects: * Updates the cache of compiled regexps. * *---------------------------------------------------------------------- */ Tcl_RegExp Tcl_RegExpCompile(interp, pattern) Tcl_Interp *interp; /* For use in error reporting and to access * the interp regexp cache. */ CONST char *pattern; /* String for which to produce compiled * regular expression. */ { return (Tcl_RegExp) CompileRegexp(interp, pattern, (int) strlen(pattern), REG_ADVANCED); } /* *---------------------------------------------------------------------- * * Tcl_RegExpExec -- * * Execute the regular expression matcher using a compiled form of a * regular expression and save information about any match that is found. * * Results: * If an error occurs during the matching operation then -1 is returned * and the interp's result contains an error message. Otherwise the * return value is 1 if a matching range is found and 0 if there is no * matching range. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_RegExpExec(interp, re, text, start) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ Tcl_RegExp re; /* Compiled regular expression; must have been * returned by previous call to * Tcl_GetRegExpFromObj. */ CONST char *text; /* Text against which to match re. */ CONST char *start; /* If text is part of a larger string, this * identifies beginning of larger string, so * that "^" won't match. */ { int flags, result, numChars; TclRegexp *regexp = (TclRegexp *)re; Tcl_DString ds; CONST Tcl_UniChar *ustr; /* * If the starting point is offset from the beginning of the buffer, then * we need to tell the regexp engine not to match "^". */ if (text > start) { flags = REG_NOTBOL; } else { flags = 0; } /* * Remember the string for use by Tcl_RegExpRange(). */ regexp->string = text; regexp->objPtr = NULL; /* * Convert the string to Unicode and perform the match. */ Tcl_DStringInit(&ds); ustr = Tcl_UtfToUniCharDString(text, -1, &ds); numChars = Tcl_DStringLength(&ds) / sizeof(Tcl_UniChar); result = RegExpExecUniChar(interp, re, ustr, numChars, -1 /* nmatches */, flags); Tcl_DStringFree(&ds); return result; } /* *--------------------------------------------------------------------------- * * Tcl_RegExpRange -- * * Returns pointers describing the range of a regular expression match, * or one of the subranges within the match. * * Results: * The variables at *startPtr and *endPtr are modified to hold the * addresses of the endpoints of the range given by index. If the * specified range doesn't exist then NULLs are returned. * * Side effects: * None. * *--------------------------------------------------------------------------- */ void Tcl_RegExpRange(re, index, startPtr, endPtr) Tcl_RegExp re; /* Compiled regular expression that has been * passed to Tcl_RegExpExec. */ int index; /* 0 means give the range of the entire match, * > 0 means give the range of a matching * subrange. */ CONST char **startPtr; /* Store address of first character in * (sub-)range here. */ CONST char **endPtr; /* Store address of character just after last * in (sub-)range here. */ { TclRegexp *regexpPtr = (TclRegexp *) re; CONST char *string; if ((size_t) index > regexpPtr->re.re_nsub) { *startPtr = *endPtr = NULL; } else if (regexpPtr->matches[index].rm_so < 0) { |
︙ | ︙ | |||
267 268 269 270 271 272 273 | /* *--------------------------------------------------------------------------- * * RegExpExecUniChar -- * * Execute the regular expression matcher using a compiled form of a | | < | | | | | | | | | | | 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 | /* *--------------------------------------------------------------------------- * * RegExpExecUniChar -- * * Execute the regular expression matcher using a compiled form of a * regular expression and save information about any match that is found. * * Results: * If an error occurs during the matching operation then -1 is returned * and an error message is left in interp's result. Otherwise the return * value is 1 if a matching range was found or 0 if there was no matching * range. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int RegExpExecUniChar(interp, re, wString, numChars, nmatches, flags) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ Tcl_RegExp re; /* Compiled regular expression; returned by a * previous call to Tcl_GetRegExpFromObj */ CONST Tcl_UniChar *wString; /* String against which to match re. */ int numChars; /* Length of Tcl_UniChar string (must be * >=0). */ int nmatches; /* How many subexpression matches (counting * the whole match as subexpression 0) are of * interest. -1 means "don't know". */ int flags; /* Regular expression flags. */ { int status; TclRegexp *regexpPtr = (TclRegexp *) re; size_t last = regexpPtr->re.re_nsub + 1; size_t nm = last; |
︙ | ︙ | |||
335 336 337 338 339 340 341 | * * Returns pointers describing the range of a regular expression match, * or one of the subranges within the match, or the hypothetical range * represented by the rm_extend field of the rm_detail_t. * * Results: * The variables at *startPtr and *endPtr are modified to hold the | | | | | | | | | | | | 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 | * * Returns pointers describing the range of a regular expression match, * or one of the subranges within the match, or the hypothetical range * represented by the rm_extend field of the rm_detail_t. * * Results: * The variables at *startPtr and *endPtr are modified to hold the * offsets of the endpoints of the range given by index. If the specified * range doesn't exist then -1s are supplied. * * Side effects: * None. * *--------------------------------------------------------------------------- */ void TclRegExpRangeUniChar(re, index, startPtr, endPtr) Tcl_RegExp re; /* Compiled regular expression that has been * passed to Tcl_RegExpExec. */ int index; /* 0 means give the range of the entire match, * > 0 means give the range of a matching * subrange, -1 means the range of the * rm_extend field. */ int *startPtr; /* Store address of first character in * (sub-)range here. */ int *endPtr; /* Store address of character just after last * in (sub-)range here. */ { TclRegexp *regexpPtr = (TclRegexp *) re; if ((regexpPtr->flags®_EXPECT) && index == -1) { *startPtr = regexpPtr->details.rm_extend.rm_so; *endPtr = regexpPtr->details.rm_extend.rm_eo; } else if ((size_t) index > regexpPtr->re.re_nsub) { |
︙ | ︙ | |||
379 380 381 382 383 384 385 | *---------------------------------------------------------------------- * * Tcl_RegExpMatch -- * * See if a string matches a regular expression. * * Results: | | | | < | | | < | | | | < | | | | | | | | | | | | < | | | | 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 | *---------------------------------------------------------------------- * * Tcl_RegExpMatch -- * * See if a string matches a regular expression. * * Results: * If an error occurs during the matching operation then -1 is returned * and the interp's result contains an error message. Otherwise the * return value is 1 if "text" matches "pattern" and 0 otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_RegExpMatch(interp, text, pattern) Tcl_Interp *interp; /* Used for error reporting. May be NULL. */ CONST char *text; /* Text to search for pattern matches. */ CONST char *pattern; /* Regular expression to match against text. */ { Tcl_RegExp re; re = Tcl_RegExpCompile(interp, pattern); if (re == NULL) { return -1; } return Tcl_RegExpExec(interp, re, text, text); } /* *---------------------------------------------------------------------- * * Tcl_RegExpExecObj -- * * Execute a precompiled regexp against the given object. * * Results: * If an error occurs during the matching operation then -1 is returned * and the interp's result contains an error message. Otherwise the * return value is 1 if "string" matches "pattern" and 0 otherwise. * * Side effects: * Converts the object to a Unicode object. * *---------------------------------------------------------------------- */ int Tcl_RegExpExecObj(interp, re, textObj, offset, nmatches, flags) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ Tcl_RegExp re; /* Compiled regular expression; must have been * returned by previous call to * Tcl_GetRegExpFromObj. */ Tcl_Obj *textObj; /* Text against which to match re. */ int offset; /* Character index that marks where matching * should begin. */ int nmatches; /* How many subexpression matches (counting * the whole match as subexpression 0) are of * interest. -1 means all of them. */ int flags; /* Regular expression execution flags. */ { TclRegexp *regexpPtr = (TclRegexp *) re; Tcl_UniChar *udata; int length; /* * Save the target object so we can extract strings from it later. */ regexpPtr->string = NULL; regexpPtr->objPtr = textObj; udata = Tcl_GetUnicodeFromObj(textObj, &length); if (offset > length) { offset = length; } udata += offset; length -= offset; return RegExpExecUniChar(interp, re, udata, length, nmatches, flags); } /* *---------------------------------------------------------------------- * * Tcl_RegExpMatchObj -- * * See if an object matches a regular expression. * * Results: * If an error occurs during the matching operation then -1 is returned * and the interp's result contains an error message. Otherwise the * return value is 1 if "text" matches "pattern" and 0 otherwise. * * Side effects: * Changes the internal rep of the pattern and string objects. * *---------------------------------------------------------------------- */ int Tcl_RegExpMatchObj(interp, textObj, patternObj) Tcl_Interp *interp; /* Used for error reporting. May be NULL. */ Tcl_Obj *textObj; /* Object containing the String to search. */ Tcl_Obj *patternObj; /* Regular expression to match against * string. */ { Tcl_RegExp re; re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED | TCL_REG_NOSUB); if (re == NULL) { return -1; } return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */, 0 /* nmatches */, 0 /* flags */); } /* *---------------------------------------------------------------------- * * Tcl_RegExpGetInfo -- |
︙ | ︙ | |||
517 518 519 520 521 522 523 | * *---------------------------------------------------------------------- */ void Tcl_RegExpGetInfo(regexp, infoPtr) Tcl_RegExp regexp; /* Pattern from which to get subexpressions. */ | | | | | | | | | | | > | | 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 | * *---------------------------------------------------------------------- */ void Tcl_RegExpGetInfo(regexp, infoPtr) Tcl_RegExp regexp; /* Pattern from which to get subexpressions. */ Tcl_RegExpInfo *infoPtr; /* Match information is stored here. */ { TclRegexp *regexpPtr = (TclRegexp *) regexp; infoPtr->nsubs = regexpPtr->re.re_nsub; infoPtr->matches = (Tcl_RegExpIndices *) regexpPtr->matches; infoPtr->extendStart = regexpPtr->details.rm_extend.rm_so; } /* *---------------------------------------------------------------------- * * Tcl_GetRegExpFromObj -- * * Compile a regular expression into a form suitable for fast matching. * This function caches the result in a Tcl_Obj. * * Results: * The return value is a pointer to the compiled form of string, suitable * for passing to Tcl_RegExpExec. If an error occurred while compiling * the pattern, then NULL is returned and an error message is left in the * interp's result. * * Side effects: * Updates the native rep of the Tcl_Obj. * *---------------------------------------------------------------------- */ Tcl_RegExp Tcl_GetRegExpFromObj(interp, objPtr, flags) Tcl_Interp *interp; /* For use in error reporting, and to access * the interp regexp cache. */ Tcl_Obj *objPtr; /* Object whose string rep contains regular * expression pattern. Internal rep will be * changed to compiled form of this regular * expression. */ int flags; /* Regular expression compilation flags. */ { int length; TclRegexp *regexpPtr; char *pattern; /* * This is OK because we only actually interpret this value properly as a * TclRegexp* when the type is tclRegexpType. */ regexpPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr; if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) { pattern = Tcl_GetStringFromObj(objPtr, &length); regexpPtr = CompileRegexp(interp, pattern, length, flags); if (regexpPtr == NULL) { return NULL; } /* * Add a reference to the regexp so it will persist even if it is * pushed out of the current thread's regexp cache. This reference * will be removed when the object's internal rep is freed. */ regexpPtr->refCount++; /* * Free the old representation and set our type. |
︙ | ︙ | |||
601 602 603 604 605 606 607 | *---------------------------------------------------------------------- * * TclRegAbout -- * * Return information about a compiled regular expression. * * Results: | | | | | | 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 | *---------------------------------------------------------------------- * * TclRegAbout -- * * Return information about a compiled regular expression. * * Results: * The return value is -1 for failure, 0 for success, although at the * moment there's nothing that could fail. On success, a list is left in * the interp's result: first element is the subexpression count, second * is a list of re_info bit names. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
648 649 650 651 652 653 654 | Tcl_ResetResult(interp); sprintf(buf, "%u", (unsigned)(regexpPtr->re.re_nsub)); Tcl_AppendElement(interp, buf); /* | | | > | 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 | Tcl_ResetResult(interp); sprintf(buf, "%u", (unsigned)(regexpPtr->re.re_nsub)); Tcl_AppendElement(interp, buf); /* * Must count bits before generating list, because we must know whether {} * are needed before we start appending names. */ n = 0; for (inf = infonames; inf->bit != 0; inf++) { if (regexpPtr->re.re_info&inf->bit) { n++; } } if (n != 1) { |
︙ | ︙ | |||
708 709 710 711 712 713 714 | p = (n > sizeof(buf)) ? "..." : ""; Tcl_AppendResult(interp, msg, buf, p, NULL); sprintf(cbuf, "%d", status); (VOID) TclReError(REG_ITOA, (regex_t *)NULL, cbuf, sizeof(cbuf)); Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL); } | < | 701 702 703 704 705 706 707 708 709 710 711 712 713 714 | p = (n > sizeof(buf)) ? "..." : ""; Tcl_AppendResult(interp, msg, buf, p, NULL); sprintf(cbuf, "%d", status); (VOID) TclReError(REG_ITOA, (regex_t *)NULL, cbuf, sizeof(cbuf)); Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL); } /* *---------------------------------------------------------------------- * * FreeRegexpInternalRep -- * * Deallocate the storage associated with a regexp object's internal |
︙ | ︙ | |||
747 748 749 750 751 752 753 | } /* *---------------------------------------------------------------------- * * DupRegexpInternalRep -- * | | | > | 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 | } /* *---------------------------------------------------------------------- * * DupRegexpInternalRep -- * * We copy the reference to the compiled regexp and bump its reference * count. * * Results: * None. * * Side effects: * Increments the reference count of the regexp. * *---------------------------------------------------------------------- */ static void DupRegexpInternalRep(srcPtr, copyPtr) Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { TclRegexp *regexpPtr = (TclRegexp *) srcPtr->internalRep.otherValuePtr; regexpPtr->refCount++; copyPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr; copyPtr->typePtr = &tclRegexpType; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
806 807 808 809 810 811 812 | } /* *--------------------------------------------------------------------------- * * CompileRegexp -- * | | | | | | | | | | | | | | | | | 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 | } /* *--------------------------------------------------------------------------- * * CompileRegexp -- * * Attempt to compile the given regexp pattern. If the compiled regular * expression can be found in the per-thread cache, it will be used * instead of compiling a new copy. * * Results: * The return value is a pointer to a newly allocated TclRegexp that * represents the compiled pattern, or NULL if the pattern could not be * compiled. If NULL is returned, an error message is left in the * interp's result. * * Side effects: * The thread-local regexp cache is updated and a new TclRegexp may be * allocated. * *---------------------------------------------------------------------- */ static TclRegexp * CompileRegexp(interp, string, length, flags) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ CONST char *string; /* The regexp to compile (UTF-8). */ int length; /* The length of the string in bytes. */ int flags; /* Compilation flags. */ { TclRegexp *regexpPtr; CONST Tcl_UniChar *uniString; int numChars; Tcl_DString stringBuf; int status, i; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->initialized) { tsdPtr->initialized = 1; Tcl_CreateThreadExitHandler(FinalizeRegexp, NULL); } /* * This routine maintains a second-level regular expression cache in * addition to the per-object regexp cache. The per-thread cache is needed * to handle the case where for various reasons the object is lost between * invocations of the regexp command, but the literal pattern is the same. */ /* * Check the per-thread compiled regexp cache. We can only reuse a regexp * if it has the same pattern and the same flags. */ for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) { if ((length == tsdPtr->patLengths[i]) && (tsdPtr->regexps[i]->flags == flags) && (strcmp(string, tsdPtr->patterns[i]) == 0)) { /* * Move the matched pattern to the first slot in the cache and * shift the other patterns down one position. */ if (i != 0) { int j; char *cachedString; cachedString = tsdPtr->patterns[i]; |
︙ | ︙ | |||
885 886 887 888 889 890 891 | return tsdPtr->regexps[0]; } } /* * This is a new expression, so compile it and add it to the cache. */ | | | 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 | return tsdPtr->regexps[0]; } } /* * This is a new expression, so compile it and add it to the cache. */ regexpPtr = (TclRegexp *) ckalloc(sizeof(TclRegexp)); regexpPtr->objPtr = NULL; regexpPtr->string = NULL; regexpPtr->details.rm_extend.rm_so = -1; regexpPtr->details.rm_extend.rm_eo = -1; /* |
︙ | ︙ | |||
923 924 925 926 927 928 929 | "couldn't compile regular expression pattern: ", status); } return NULL; } /* | | | | 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 | "couldn't compile regular expression pattern: ", status); } return NULL; } /* * Allocate enough space for all of the subexpressions, plus one extra for * the entire pattern. */ regexpPtr->matches = (regmatch_t *) ckalloc( sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1)); /* * Initialize the refcount to one initially, since it is in the cache. |
︙ | ︙ | |||
1021 1022 1023 1024 1025 1026 1027 | regexpPtr = tsdPtr->regexps[i]; if (--(regexpPtr->refCount) <= 0) { FreeRegexp(regexpPtr); } ckfree(tsdPtr->patterns[i]); } } | > > > > > > > > | 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 | regexpPtr = tsdPtr->regexps[i]; if (--(regexpPtr->refCount) <= 0) { FreeRegexp(regexpPtr); } ckfree(tsdPtr->patterns[i]); } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclResolve.c.
1 2 3 | /* * tclResolve.c -- * | | | | | < | | | | < | | | < | | > | | | < | | | | < | | | < | < | | | | | | | | | | | | > | | | | | > | | | | | | | | > | | | | | | | < < | | | | | | > | | | | | < | | | | | | | | < | | | > | | | | | | > | | | | | | > | | | | | | | | | | | | | | | | < < | < | | > < | | | | < | < | | | | | | | | < | | | > | | < | | | | | | < | | | | | | | | | | | | | < | | | | | | | | | | | | | > > | | < | | | | | < < | | | | | < | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 | /* * tclResolve.c -- * * Contains hooks for customized command/variable name resolution * schemes. These hooks allow extensions like [incr Tcl] to add their own * name resolution rules to the Tcl language. Rules can be applied to a * particular namespace, to the interpreter as a whole, or both. * * Copyright (c) 1998 Lucent Technologies, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclResolve.c,v 1.4.6.2 2005/08/02 18:16:07 dgp Exp $ */ #include "tclInt.h" /* * Declarations for functions local to this file: */ static void BumpCmdRefEpochs _ANSI_ARGS_((Namespace *nsPtr)); /* *---------------------------------------------------------------------- * * Tcl_AddInterpResolvers -- * * Adds a set of command/variable resolution functions to an interpreter. * These functions are consulted when commands are resolved in * Tcl_FindCommand, and when variables are resolved in TclLookupVar and * LookupCompiledLocal. Each namespace may also have its own set of * resolution functions which take precedence over those for the * interpreter. * * When a name is resolved, it is handled as follows. First, the name is * passed to the resolution functions for the namespace. If not resolved, * the name is passed to each of the resolution functions added to the * interpreter. Finally, if still not resolved, the name is handled using * the default Tcl rules for name resolution. * * Results: * Returns pointers to the current name resolution functions in the * cmdProcPtr, varProcPtr and compiledVarProcPtr arguments. * * Side effects: * If a compiledVarProc is specified, this function bumps the * compileEpoch for the interpreter, forcing all code to be recompiled. * If a cmdProc is specified, this function bumps the cmdRefEpoch in all * namespaces, forcing commands to be resolved again using the new rules. * *---------------------------------------------------------------------- */ void Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc) Tcl_Interp *interp; /* Interpreter whose name resolution * rules are being modified. */ CONST char *name; /* Name of this resolution scheme. */ Tcl_ResolveCmdProc *cmdProc; /* New function for command * resolution. */ Tcl_ResolveVarProc *varProc; /* Function for variable resolution at * runtime. */ Tcl_ResolveCompiledVarProc *compiledVarProc; /* Function for variable resolution at * compile time. */ { Interp *iPtr = (Interp *) interp; ResolverScheme *resPtr; /* * Since we're adding a new name resolution scheme, we must force all code * to be recompiled to use the new scheme. If there are new compiled * variable resolution rules, bump the compiler epoch to invalidate * compiled code. If there are new command resolution rules, bump the * cmdRefEpoch in all namespaces. */ if (compiledVarProc) { iPtr->compileEpoch++; } if (cmdProc) { BumpCmdRefEpochs(iPtr->globalNsPtr); } /* * Look for an existing scheme with the given name. If found, then replace * its rules. */ for (resPtr=iPtr->resolverPtr ; resPtr!=NULL ; resPtr=resPtr->nextPtr) { if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { resPtr->cmdResProc = cmdProc; resPtr->varResProc = varProc; resPtr->compiledVarResProc = compiledVarProc; return; } } /* * Otherwise, this is a new scheme. Add it to the FRONT of the linked * list, so that it overrides existing schemes. */ resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme)); resPtr->name = (char *) ckalloc((unsigned)(strlen(name) + 1)); strcpy(resPtr->name, name); resPtr->cmdResProc = cmdProc; resPtr->varResProc = varProc; resPtr->compiledVarResProc = compiledVarProc; resPtr->nextPtr = iPtr->resolverPtr; iPtr->resolverPtr = resPtr; } /* *---------------------------------------------------------------------- * * Tcl_GetInterpResolvers -- * * Looks for a set of command/variable resolution functions with the * given name in an interpreter. These functions are registered by * calling Tcl_AddInterpResolvers. * * Results: * If the name is recognized, this function returns non-zero, along with * pointers to the name resolution functions in the Tcl_ResolverInfo * structure. If the name is not recognized, this function returns zero. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetInterpResolvers(interp, name, resInfoPtr) Tcl_Interp *interp; /* Interpreter whose name resolution * rules are being queried. */ CONST char *name; /* Look for a scheme with this name. */ Tcl_ResolverInfo *resInfoPtr; /* Returns pointers to the functions, * if found */ { Interp *iPtr = (Interp *) interp; ResolverScheme *resPtr; /* * Look for an existing scheme with the given name. If found, then return * pointers to its functions. */ for (resPtr=iPtr->resolverPtr ; resPtr!=NULL ; resPtr=resPtr->nextPtr) { if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { resInfoPtr->cmdResProc = resPtr->cmdResProc; resInfoPtr->varResProc = resPtr->varResProc; resInfoPtr->compiledVarResProc = resPtr->compiledVarResProc; return 1; } } return 0; } /* *---------------------------------------------------------------------- * * Tcl_RemoveInterpResolvers -- * * Removes a set of command/variable resolution functions previously * added by Tcl_AddInterpResolvers. The next time a command/variable name * is resolved, these functions won't be consulted. * * Results: * Returns non-zero if the name was recognized and the resolution scheme * was deleted. Returns zero otherwise. * * Side effects: * If a scheme with a compiledVarProc was deleted, this function bumps * the compileEpoch for the interpreter, forcing all code to be * recompiled. If a scheme with a cmdProc was deleted, this function * bumps the cmdRefEpoch in all namespaces, forcing commands to be * resolved again using the new rules. * *---------------------------------------------------------------------- */ int Tcl_RemoveInterpResolvers(interp, name) Tcl_Interp *interp; /* Interpreter whose name resolution * rules are being modified. */ CONST char *name; /* Name of the scheme to be removed. */ { Interp *iPtr = (Interp *) interp; ResolverScheme **prevPtrPtr, *resPtr; /* * Look for an existing scheme with the given name. */ prevPtrPtr = &iPtr->resolverPtr; for (resPtr=iPtr->resolverPtr ; resPtr!=NULL ; resPtr=resPtr->nextPtr) { if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { break; } prevPtrPtr = &resPtr->nextPtr; } /* * If we found the scheme, delete it. */ if (resPtr) { /* * If we're deleting a scheme with compiled variable resolution rules, * bump the compiler epoch to invalidate compiled code. If we're * deleting a scheme with command resolution rules, bump the * cmdRefEpoch in all namespaces. */ if (resPtr->compiledVarResProc) { iPtr->compileEpoch++; } if (resPtr->cmdResProc) { BumpCmdRefEpochs(iPtr->globalNsPtr); } *prevPtrPtr = resPtr->nextPtr; ckfree(resPtr->name); ckfree((char *) resPtr); return 1; } return 0; } /* *---------------------------------------------------------------------- * * BumpCmdRefEpochs -- * * This function is used to bump the cmdRefEpoch counters in the * specified namespace and all of its child namespaces. It is used * whenever name resolution schemes are added/removed from an * interpreter, to invalidate all command references. * * Results: * None. * * Side effects: * Bumps the cmdRefEpoch in the specified namespace and its children, * recursively. * *---------------------------------------------------------------------- */ static void BumpCmdRefEpochs(nsPtr) Namespace *nsPtr; /* Namespace being modified. */ { Tcl_HashEntry *entry; Tcl_HashSearch search; nsPtr->cmdRefEpoch++; for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { Namespace *childNsPtr = (Namespace *) Tcl_GetHashValue(entry); BumpCmdRefEpochs(childNsPtr); } TclInvalidateNsPath(nsPtr); } /* *---------------------------------------------------------------------- * * Tcl_SetNamespaceResolvers -- * * Sets the command/variable resolution functions for a namespace, * thereby changing the way that command/variable names are interpreted. * This allows extension writers to support different name resolution * schemes, such as those for object-oriented packages. * * Command resolution is handled by a function of the following type: * * typedef int (*Tcl_ResolveCmdProc)(Tcl_Interp *interp, * CONST char *name, Tcl_Namespace *context, * int flags, Tcl_Command *rPtr); * * Whenever a command is executed or Tcl_FindCommand is invoked within * the namespace, this function is called to resolve the command name. * If this function is able to resolve the name, it should return the * status code TCL_OK, along with the corresponding Tcl_Command in the * rPtr argument. Otherwise, the function can return TCL_CONTINUE, and * the command will be treated under the usual name resolution rules. * Or, it can return TCL_ERROR, and the command will be considered * invalid. * * Variable resolution is handled by two functions. The first is called * whenever a variable needs to be resolved at compile time: * * typedef int (*Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, * CONST char *name, Tcl_Namespace *context, * Tcl_ResolvedVarInfo *rPtr); * * If this function is able to resolve the name, it should return the * status code TCL_OK, along with variable resolution info in the rPtr * argument; this info will be used to set up compiled locals in the call * frame at runtime. The function may also return TCL_CONTINUE, and the * variable will be treated under the usual name resolution rules. Or, it * can return TCL_ERROR, and the variable will be considered invalid. * * Another function is used whenever a variable needs to be resolved at * runtime but it is not recognized as a compiled local. (For example, * the variable may be requested via Tcl_FindNamespaceVar.) This function * has the following type: * * typedef int (*Tcl_ResolveVarProc)(Tcl_Interp *interp, * CONST char *name, Tcl_Namespace *context, * int flags, Tcl_Var *rPtr); * * This function is quite similar to the compile-time version. It returns * the same status codes, but if variable resolution succeeds, this * function returns a Tcl_Var directly via the rPtr argument. * * Results: * Nothing. * * Side effects: * Bumps the command epoch counter for the namespace, invalidating all * command references in that namespace. Also bumps the resolver epoch * counter for the namespace, forcing all code in the namespace to be * recompiled. * *---------------------------------------------------------------------- */ void Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc) Tcl_Namespace *namespacePtr; /* Namespace whose resolution rules * are being modified. */ Tcl_ResolveCmdProc *cmdProc; /* Function for command resolution */ Tcl_ResolveVarProc *varProc; /* Function for variable resolution at * run-time */ Tcl_ResolveCompiledVarProc *compiledVarProc; /* Function for variable resolution at * compile time. */ { Namespace *nsPtr = (Namespace *) namespacePtr; /* * Plug in the new command resolver, and bump the epoch counters so that * all code will have to be recompiled and all commands will have to be * resolved again using the new policy. */ nsPtr->cmdResProc = cmdProc; nsPtr->varResProc = varProc; nsPtr->compiledVarResProc = compiledVarProc; nsPtr->cmdRefEpoch++; nsPtr->resolverEpoch++; TclInvalidateNsPath(nsPtr); } /* *---------------------------------------------------------------------- * * Tcl_GetNamespaceResolvers -- * * Returns the current command/variable resolution functions for a * namespace. By default, these functions are NULL. New functions can be * installed by calling Tcl_SetNamespaceResolvers, to provide new name * resolution rules. * * Results: * Returns non-zero if any name resolution functions have been assigned * to this namespace; also returns pointers to the functions in the * Tcl_ResolverInfo structure. Returns zero otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetNamespaceResolvers(namespacePtr, resInfoPtr) Tcl_Namespace *namespacePtr; /* Namespace whose resolution rules * are being modified. */ Tcl_ResolverInfo *resInfoPtr; /* Returns: pointers for all name * resolution functions assigned to * this namespace. */ { Namespace *nsPtr = (Namespace *) namespacePtr; resInfoPtr->cmdResProc = nsPtr->cmdResProc; resInfoPtr->varResProc = nsPtr->varResProc; resInfoPtr->compiledVarResProc = nsPtr->compiledVarResProc; if (nsPtr->cmdResProc != NULL || nsPtr->varResProc != NULL || nsPtr->compiledVarResProc != NULL) { return 1; } return 0; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclResult.c.
|
| | | | | > | > > | | | | | | < > | | | | | < | | < | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | /* * tclResult.c -- * * This file contains code to manage the interpreter result. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclResult.c,v 1.23.2.5 2005/09/15 20:58:40 dgp Exp $ */ #include "tclInt.h" /* * Indices of the standard return options dictionary keys. */ enum returnKeys { KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE, KEY_LEVEL, KEY_OPTIONS, KEY_LAST }; /* * Function prototypes for local functions in this file: */ static Tcl_Obj ** GetKeys _ANSI_ARGS_((void)); static void ReleaseKeys _ANSI_ARGS_((ClientData clientData)); static void ResetObjResult _ANSI_ARGS_((Interp *iPtr)); static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, int newSpace)); /* * This structure is used to take a snapshot of the interpreter state in * Tcl_SaveInterpState. You can snapshot the state, execute a command, and * then back up to the result or the error that was previously in progress. */ typedef struct InterpState { int status; /* return code status */ int flags; /* Each remaining field saves the */ int returnLevel; /* corresponding field of the Interp */ int returnCode; /* struct. These fields taken together are */ Tcl_Obj *errorInfo; /* the "state" of the interp. */ Tcl_Obj *errorCode; Tcl_Obj *returnOpts; Tcl_Obj *objResult; } InterpState; /* *---------------------------------------------------------------------- * * Tcl_SaveInterpState -- * * Fills a token with a snapshot of the current state of the interpreter. * The snapshot can be restored at any point by TclRestoreInterpState. * * The token returned must be eventally passed to one of the routines * TclRestoreInterpState or TclDiscardInterpState, or there will be a * memory leak. * * Results: * Returns a token representing the interp state. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_InterpState Tcl_SaveInterpState(interp, status) Tcl_Interp* interp; /* Interpreter's state to be saved */ int status; /* status code for current operation */ { Interp *iPtr = (Interp *)interp; InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState)); statePtr->status = status; statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED; statePtr->returnLevel = iPtr->returnLevel; |
︙ | ︙ | |||
99 100 101 102 103 104 105 | } /* *---------------------------------------------------------------------- * * Tcl_RestoreInterpState -- * | | | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | } /* *---------------------------------------------------------------------- * * Tcl_RestoreInterpState -- * * Accepts an interp and a token previously returned by * Tcl_SaveInterpState. Restore the state of the interp to what it was at * the time of the Tcl_SaveInterpState call. * * Results: * Returns the status value originally passed in to Tcl_SaveInterpState. * * Side effects: * Restores the interp state and frees memory held by token. * |
︙ | ︙ | |||
157 158 159 160 161 162 163 | } /* *---------------------------------------------------------------------- * * Tcl_DiscardInterpState -- * | | | | | | | | < | | | | < | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_DiscardInterpState -- * * Accepts a token previously returned by Tcl_SaveInterpState. Frees the * memory it uses. * * Results: * None. * * Side effects: * Frees memory. * *---------------------------------------------------------------------- */ void Tcl_DiscardInterpState(state) Tcl_InterpState state; /* saved interpreter state */ { InterpState *statePtr = (InterpState *)state; if (statePtr->errorInfo) { Tcl_DecrRefCount(statePtr->errorInfo); } if (statePtr->errorCode) { Tcl_DecrRefCount(statePtr->errorCode); } if (statePtr->returnOpts) { Tcl_DecrRefCount(statePtr->returnOpts); } Tcl_DecrRefCount(statePtr->objResult); ckfree((char*) statePtr); } /* *---------------------------------------------------------------------- * * Tcl_SaveResult -- * * Takes a snapshot of the current result state of the interpreter. The * snapshot can be restored at any point by Tcl_RestoreResult. Note that * this routine does not preserve the errorCode, errorInfo, or flags * fields so it should not be used if an error is in progress. * * Once a snapshot is saved, it must be restored by calling * Tcl_RestoreResult, or discarded by calling Tcl_DiscardResult. * * Results: * None. * * Side effects: * Resets the interpreter result. * *---------------------------------------------------------------------- */ void Tcl_SaveResult(interp, statePtr) Tcl_Interp *interp; /* Interpreter to save. */ Tcl_SavedResult *statePtr; /* Pointer to state structure. */ { Interp *iPtr = (Interp *) interp; /* * Move the result object into the save state. Note that we don't need to * change its refcount because we're moving it, not adding a new * reference. Put an empty object into the interpreter. */ statePtr->objResultPtr = iPtr->objResultPtr; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); /* * Save the string result. */ statePtr->freeProc = iPtr->freeProc; if (iPtr->result == iPtr->resultSpace) { /* * Copy the static string data out of the interp buffer. */ |
︙ | ︙ | |||
273 274 275 276 277 278 279 | } /* *---------------------------------------------------------------------- * * Tcl_RestoreResult -- * | | | | | | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 | } /* *---------------------------------------------------------------------- * * Tcl_RestoreResult -- * * Restores the state of the interpreter to a snapshot taken by * Tcl_SaveResult. After this call, the token for the interpreter state * is no longer valid. * * Results: * None. * * Side effects: * Restores the interpreter result. * *---------------------------------------------------------------------- */ void Tcl_RestoreResult(interp, statePtr) Tcl_Interp* interp; /* Interpreter being restored. */ |
︙ | ︙ | |||
341 342 343 344 345 346 347 | } /* *---------------------------------------------------------------------- * * Tcl_DiscardResult -- * | | | < | | | | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 | } /* *---------------------------------------------------------------------- * * Tcl_DiscardResult -- * * Frees the memory associated with an interpreter snapshot taken by * Tcl_SaveResult. If the snapshot is not restored, this function must be * called to discard it, or the memory will be lost. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_DiscardResult(statePtr) Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */ |
︙ | ︙ | |||
377 378 379 380 381 382 383 | } /* *---------------------------------------------------------------------- * * Tcl_SetResult -- * | | | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_SetResult -- * * Arrange for "result" to be the Tcl return value. * * Results: * None. * * Side effects: * interp->result is left pointing either to "result" or to a copy of it. * Also, the object result is reset. * *---------------------------------------------------------------------- */ void Tcl_SetResult(interp, result, freeProc) Tcl_Interp *interp; /* Interpreter with which to associate the * return value. */ register char *result; /* Value to be returned. If NULL, the result * is set to an empty string. */ Tcl_FreeProc *freeProc; /* Gives information about the string: * TCL_STATIC, TCL_VOLATILE, or the address of * a Tcl_FreeProc such as free. */ { Interp *iPtr = (Interp *) interp; int length; register Tcl_FreeProc *oldFreeProc = iPtr->freeProc; char *oldResult = iPtr->result; if (result == NULL) { iPtr->resultSpace[0] = 0; iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; } else if (freeProc == TCL_VOLATILE) { length = strlen(result); if (length > TCL_RESULT_SIZE) { iPtr->result = (char *) ckalloc((unsigned) length+1); iPtr->freeProc = TCL_DYNAMIC; } else { iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; } strcpy(iPtr->result, result); } else { iPtr->result = result; iPtr->freeProc = freeProc; } /* * If the old result was dynamically-allocated, free it up. Do it here, * rather than at the beginning, in case the new result value was part of * the old result value. */ if (oldFreeProc != 0) { if (oldFreeProc == TCL_DYNAMIC) { ckfree(oldResult); } else { (*oldFreeProc)(oldResult); |
︙ | ︙ | |||
463 464 465 466 467 468 469 | * string result, then the object result is reset. * *---------------------------------------------------------------------- */ CONST char * Tcl_GetStringResult(interp) | | | | | | | | | | < | | < | | | | 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 | * string result, then the object result is reset. * *---------------------------------------------------------------------- */ CONST char * Tcl_GetStringResult(interp) register Tcl_Interp *interp;/* Interpreter whose result to return. */ { /* * If the string result is empty, move the object result to the string * result, then reset the object result. */ if (*(interp->result) == 0) { Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } return interp->result; } /* *---------------------------------------------------------------------- * * Tcl_SetObjResult -- * * Arrange for objPtr to be an interpreter's result value. * * Results: * None. * * Side effects: * interp->objResultPtr is left pointing to the object referenced by * objPtr. The object's reference count is incremented since there is now * a new reference to it. The reference count for any old objResultPtr * value is decremented. Also, the string result is reset. * *---------------------------------------------------------------------- */ void Tcl_SetObjResult(interp, objPtr) Tcl_Interp *interp; /* Interpreter with which to associate the * return object value. */ register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the obj * result is made an empty string object. */ { register Interp *iPtr = (Interp *) interp; register Tcl_Obj *oldObjResult = iPtr->objResultPtr; iPtr->objResultPtr = objPtr; Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ /* * We wait until the end to release the old object result, in case we are * setting the result to itself. */ TclDecrRefCount(oldObjResult); /* * Reset the string result since we just set the result object. */ if (iPtr->freeProc != NULL) { |
︙ | ︙ | |||
540 541 542 543 544 545 546 | /* *---------------------------------------------------------------------- * * Tcl_GetObjResult -- * * Returns an interpreter's result value as a Tcl object. The object's | | | | | | | | | | | | | < | | < | | < > | | | < | | | | | < | | | | | < | < | | | | | | | | | | | | | | | | > | | | > | | | | | | | | | | | | | | | | | | | | | | < | | | 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 | /* *---------------------------------------------------------------------- * * Tcl_GetObjResult -- * * Returns an interpreter's result value as a Tcl object. The object's * reference count is not modified; the caller must do that if it needs * to hold on to a long-term reference to it. * * Results: * The interpreter's result as an object. * * Side effects: * If the interpreter has a non-empty string result, the result object is * either empty or stale because some function set interp->result * directly. If so, the string result is moved to the result object then * the string result is reset. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_GetObjResult(interp) Tcl_Interp *interp; /* Interpreter whose result to return. */ { register Interp *iPtr = (Interp *) interp; Tcl_Obj *objResultPtr; int length; /* * If the string result is non-empty, move the string result to the object * result, then reset the string result. */ if (*(iPtr->result) != 0) { ResetObjResult(iPtr); objResultPtr = iPtr->objResultPtr; length = strlen(iPtr->result); TclInitStringRep(objResultPtr, iPtr->result, length); if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); } else { (*iPtr->freeProc)(iPtr->result); } iPtr->freeProc = 0; } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; } return iPtr->objResultPtr; } /* *---------------------------------------------------------------------- * * Tcl_AppendResultVA -- * * Append a variable number of strings onto the interpreter's result. * * Results: * None. * * Side effects: * The result of the interpreter given by the first argument is extended * by the strings in the va_list (up to a terminating NULL argument). * * If the string result is non-empty, the object result forced to be a * duplicate of it first. There will be a string result afterwards. * *---------------------------------------------------------------------- */ void Tcl_AppendResultVA(interp, argList) Tcl_Interp *interp; /* Interpreter with which to associate the * return value. */ va_list argList; /* Variable argument list. */ { Tcl_Obj *objPtr = Tcl_GetObjResult(interp); if (Tcl_IsShared(objPtr)) { objPtr = Tcl_DuplicateObj(objPtr); } Tcl_AppendStringsToObjVA(objPtr, argList); Tcl_SetObjResult(interp, objPtr); /* * Strictly we should call Tcl_GetStringResult(interp) here to make sure * that interp->result is correct according to the old contract, but that * makes the performance of much code (e.g. in Tk) absolutely awful. So we * leave it out; code that really wants interp->result can just insert the * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion] */ #ifdef USE_DIRECT_INTERP_RESULT_ACCESS /* * Ensure that the interp->result is legal so old Tcl 7.* code still * works. There's still embarrasingly much of it about... */ (void) Tcl_GetStringResult(interp); #endif /* USE_DIRECT_INTERP_RESULT_ACCESS */ } /* *---------------------------------------------------------------------- * * Tcl_AppendResult -- * * Append a variable number of strings onto the interpreter's result. * * Results: * None. * * Side effects: * The result of the interpreter given by the first argument is extended * by the strings given by the second and following arguments (up to a * terminating NULL argument). * * If the string result is non-empty, the object result forced to be a * duplicate of it first. There will be a string result afterwards. * *---------------------------------------------------------------------- */ void Tcl_AppendResult(Tcl_Interp *interp, ...) { va_list argList; va_start(argList, interp); Tcl_AppendResultVA(interp, argList); va_end(argList); } /* *---------------------------------------------------------------------- * * Tcl_AppendElement -- * * Convert a string to a valid Tcl list element and append it to the * result (which is ostensibly a list). * * Results: * None. * * Side effects: * The result in the interpreter given by the first argument is extended * with a list element converted from string. A separator space is added * before the converted list element unless the current result is empty, * contains the single character "{", or ends in " {". * * If the string result is empty, the object result is moved to the * string result, then the object result is reset. * *---------------------------------------------------------------------- */ void Tcl_AppendElement(interp, element) Tcl_Interp *interp; /* Interpreter whose result is to be * extended. */ CONST char *element; /* String to convert to list element and add * to result. */ { Interp *iPtr = (Interp *) interp; char *dst; int size; int flags; /* * If the string result is empty, move the object result to the string * result, then reset the object result. */ (void) Tcl_GetStringResult(interp); /* * See how much space is needed, and grow the append buffer if needed to * accommodate the list element. */ size = Tcl_ScanElement(element, &flags) + 1; if ((iPtr->result != iPtr->appendResult) || (iPtr->appendResult[iPtr->appendUsed] != 0) || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { SetupAppendBuffer(iPtr, size+iPtr->appendUsed); } /* * Convert the string into a list element and copy it to the buffer that's * forming, with a space separator if needed. */ dst = iPtr->appendResult + iPtr->appendUsed; if (TclNeedSpace(iPtr->appendResult, dst)) { iPtr->appendUsed++; *dst = ' '; dst++; /* * If we need a space to separate this element from preceding stuff, * then this element will not lead a list, and need not have it's * leading '#' quoted. */ flags |= TCL_DONT_QUOTE_HASH; } iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); } /* *---------------------------------------------------------------------- * * SetupAppendBuffer -- * * This function makes sure that there is an append buffer properly * initialized, if necessary, from the interpreter's result, and that it * has at least enough room to accommodate newSpace new bytes of * information. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void SetupAppendBuffer(iPtr, newSpace) Interp *iPtr; /* Interpreter whose result is being set up. */ int newSpace; /* Make sure that at least this many bytes of * new information may be added. */ { int totalSpace; /* * Make the append buffer larger, if that's necessary, then copy the * result into the append buffer and make the append buffer the official * Tcl result. */ if (iPtr->result != iPtr->appendResult) { /* * If an oversized buffer was used recently, then free it up so we go * back to a smaller buffer. This avoids tying up memory forever after * a large operation. */ if (iPtr->appendAvl > 500) { ckfree(iPtr->appendResult); iPtr->appendResult = NULL; iPtr->appendAvl = 0; } iPtr->appendUsed = strlen(iPtr->result); } else if (iPtr->result[iPtr->appendUsed] != 0) { /* * Most likely someone has modified a result created by * Tcl_AppendResult et al. so that it has a different size. Just * recompute the size. */ iPtr->appendUsed = strlen(iPtr->result); } totalSpace = newSpace + iPtr->appendUsed; if (totalSpace >= iPtr->appendAvl) { char *new; if (totalSpace < 100) { totalSpace = 200; } else { totalSpace *= 2; } new = (char *) ckalloc((unsigned) totalSpace); strcpy(new, iPtr->result); if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); } iPtr->appendResult = new; iPtr->appendAvl = totalSpace; } else if (iPtr->result != iPtr->appendResult) { strcpy(iPtr->appendResult, iPtr->result); } Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->appendResult; } /* *---------------------------------------------------------------------- * * Tcl_FreeResult -- * * This function frees up the memory associated with an interpreter's * string result. It also resets the interpreter's result object. * Tcl_FreeResult is most commonly used when a function is about to * replace one result value with another. * * Results: * None. * * Side effects: * Frees the memory associated with interp's string result and sets * interp->freeProc to zero, but does not change interp->result or clear * error state. Resets interp's result object to an unshared empty * object. * *---------------------------------------------------------------------- */ void Tcl_FreeResult(interp) register Tcl_Interp *interp; /* Interpreter for which to free result. */ { register Interp *iPtr = (Interp *) interp; if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); } else { (*iPtr->freeProc)(iPtr->result); } iPtr->freeProc = 0; } ResetObjResult(iPtr); } /* *---------------------------------------------------------------------- * * Tcl_ResetResult -- * * This function resets both the interpreter's string and object results. * * Results: * None. * * Side effects: * It resets the result object to an unshared empty object. It then * restores the interpreter's string result area to its default * initialized state, freeing up any memory that may have been * allocated. It also clears any error information for the interpreter. * *---------------------------------------------------------------------- */ void |
︙ | ︙ | |||
923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 | if (iPtr->errorInfo) { /* Legacy support */ Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY); Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); iPtr->returnOpts = NULL; } iPtr->flags &= ~ERR_ALREADY_LOGGED; } /* *---------------------------------------------------------------------- * * ResetObjResult -- * | > > | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | > > | > > > | | | | | | > > > | > > | | | > | | | | | | 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 | if (iPtr->errorInfo) { /* Legacy support */ Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY); Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } iPtr->returnLevel = 1; iPtr->returnCode = TCL_OK; if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); iPtr->returnOpts = NULL; } iPtr->flags &= ~ERR_ALREADY_LOGGED; } /* *---------------------------------------------------------------------- * * ResetObjResult -- * * Function used to reset an interpreter's Tcl result object. * * Results: * None. * * Side effects: * Resets the interpreter's result object to an unshared empty string * object with ref count one. It does not clear any error information in * the interpreter. * *---------------------------------------------------------------------- */ static void ResetObjResult(iPtr) register Interp *iPtr; /* Points to the interpreter whose result * object should be reset. */ { register Tcl_Obj *objResultPtr = iPtr->objResultPtr; if (Tcl_IsShared(objResultPtr)) { TclDecrRefCount(objResultPtr); TclNewObj(objResultPtr); Tcl_IncrRefCount(objResultPtr); iPtr->objResultPtr = objResultPtr; } else { if ((objResultPtr->bytes != NULL) && (objResultPtr->bytes != tclEmptyStringRep)) { ckfree((char *) objResultPtr->bytes); } objResultPtr->bytes = tclEmptyStringRep; objResultPtr->length = 0; TclFreeIntRep(objResultPtr); objResultPtr->typePtr = (Tcl_ObjType *) NULL; } } /* *---------------------------------------------------------------------- * * Tcl_SetErrorCodeVA -- * * This function is called to record machine-readable information about * an error that is about to be returned. * * Results: * None. * * Side effects: * The errorCode field of the interp is modified to hold all of the * arguments to this function, in a list form with each argument becoming * one element of the list. * *---------------------------------------------------------------------- */ void Tcl_SetErrorCodeVA(interp, argList) Tcl_Interp *interp; /* Interpreter in which to set errorCode */ va_list argList; /* Variable argument list. */ { Tcl_Obj *errorObj = Tcl_NewObj(); /* * Scan through the arguments one at a time, appending them to the * errorCode field as list elements. */ while (1) { char *elem = va_arg(argList, char *); if (elem == NULL) { break; } Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1)); } Tcl_SetObjErrorCode(interp, errorObj); } /* *---------------------------------------------------------------------- * * Tcl_SetErrorCode -- * * This function is called to record machine-readable information about * an error that is about to be returned. * * Results: * None. * * Side effects: * The errorCode field of the interp is modified to hold all of the * arguments to this function, in a list form with each argument becoming * one element of the list. * *---------------------------------------------------------------------- */ void Tcl_SetErrorCode(Tcl_Interp *interp, ...) { va_list argList; /* * Scan through the arguments one at a time, appending them to the * errorCode field as list elements. */ va_start(argList, interp); Tcl_SetErrorCodeVA(interp, argList); va_end(argList); } /* *---------------------------------------------------------------------- * * Tcl_SetObjErrorCode -- * * This function is called to record machine-readable information about * an error that is about to be returned. The caller should build a list * object up and pass it to this routine. * * Results: * None. * * Side effects: * The errorCode field of the interp is set to the new value. * *---------------------------------------------------------------------- */ void Tcl_SetObjErrorCode(interp, errorObjPtr) Tcl_Interp *interp; Tcl_Obj *errorObjPtr; { Interp *iPtr = (Interp *) interp; if (iPtr->errorCode) { Tcl_DecrRefCount(iPtr->errorCode); } iPtr->errorCode = errorObjPtr; Tcl_IncrRefCount(iPtr->errorCode); } /* *---------------------------------------------------------------------- * * GetKeys -- * * Returns a Tcl_Obj * array of the standard keys used in the return * options dictionary. * * Broadly sharing one copy of these key values helps with both memory * efficiency and dictionary lookup times. * * Results: * A Tcl_Obj * array. * * Side effects: * First time called in a thread, creates the keys (allocating memory) * and arranges for their cleanup at thread exit. * *---------------------------------------------------------------------- */ static Tcl_Obj ** GetKeys() { static Tcl_ThreadDataKey returnKeysKey; Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey, (int) (KEY_LAST * sizeof(Tcl_Obj *))); if (keys[0] == NULL) { /* * First call in this thread, create the keys... */ int i; keys[KEY_CODE] = Tcl_NewStringObj("-code", -1); keys[KEY_ERRORCODE] = Tcl_NewStringObj("-errorcode", -1); keys[KEY_ERRORINFO] = Tcl_NewStringObj("-errorinfo", -1); keys[KEY_ERRORLINE] = Tcl_NewStringObj("-errorline", -1); keys[KEY_LEVEL] = Tcl_NewStringObj("-level", -1); keys[KEY_OPTIONS] = Tcl_NewStringObj("-options", -1); for (i = KEY_CODE; i < KEY_LAST; i++) { Tcl_IncrRefCount(keys[i]); } /* * ... and arrange for their clenaup. */ Tcl_CreateThreadExitHandler(ReleaseKeys, (ClientData) keys); } return keys; } /* *---------------------------------------------------------------------- * * ReleaseKeys -- * * Called as a thread exit handler to cleanup return options dictionary * keys. * * Results: * None. * * Side effects: * Frees memory. * *---------------------------------------------------------------------- */ static void ReleaseKeys(clientData) ClientData clientData; { Tcl_Obj **keys = (Tcl_Obj **)clientData; int i; for (i = KEY_CODE; i < KEY_LAST; i++) { Tcl_DecrRefCount(keys[i]); } } /* *---------------------------------------------------------------------- * * TclProcessReturn -- * * Does the work of the [return] command based on the code, level, and * returnOpts arguments. Note that the code argument must agree with the * -code entry in returnOpts and the level argument must agree with the * -level entry in returnOpts, as is the case for values returned from * TclMergeReturnOptions. * * Results: * Returns the return code the [return] command should return. * * Side effects: * None. * |
︙ | ︙ | |||
1184 1185 1186 1187 1188 1189 1190 | int level; Tcl_Obj *returnOpts; { Interp *iPtr = (Interp *) interp; Tcl_Obj *valuePtr; Tcl_Obj **keys = GetKeys(); | > | > > > | 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 | int level; Tcl_Obj *returnOpts; { Interp *iPtr = (Interp *) interp; Tcl_Obj *valuePtr; Tcl_Obj **keys = GetKeys(); /* * Store the merged return options. */ if (iPtr->returnOpts != returnOpts) { if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } iPtr->returnOpts = returnOpts; Tcl_IncrRefCount(iPtr->returnOpts); } if (code == TCL_ERROR) { if (iPtr->errorInfo) { Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { int infoLen; (void) Tcl_GetStringFromObj(valuePtr, &infoLen); if (infoLen) { iPtr->errorInfo = valuePtr; Tcl_IncrRefCount(iPtr->errorInfo); iPtr->flags |= ERR_ALREADY_LOGGED; } } |
︙ | ︙ | |||
1236 1237 1238 1239 1240 1241 1242 | *---------------------------------------------------------------------- * * TclMergeReturnOptions -- * * Parses, checks, and stores the options to the [return] command. * * Results: | | | | | | | < | 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 | *---------------------------------------------------------------------- * * TclMergeReturnOptions -- * * Parses, checks, and stores the options to the [return] command. * * Results: * Returns TCL_ERROR is any of the option values are invalid. Otherwise, * returns TCL_OK, and writes the returnOpts, code, and level values to * the pointers provided. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ Tcl_Obj **optionsPtrPtr; /* If not NULL, points to space for a (Tcl_Obj * *) where the pointer to the merged return * options dictionary should be written */ int *codePtr; /* If not NULL, points to space where the * -code value should be written */ int *levelPtr; /* If not NULL, points to space where the * -level value should be written */ { int code=TCL_OK; int level = 1; |
︙ | ︙ | |||
1279 1280 1281 1282 1283 1284 1285 | if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) { Tcl_DictSearch search; int done = 0; Tcl_Obj *keyPtr; Tcl_Obj *dict = objv[1]; | | | | > | > > | | | 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 | if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) { Tcl_DictSearch search; int done = 0; Tcl_Obj *keyPtr; Tcl_Obj *dict = objv[1]; nestedOptions: if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, &search, &keyPtr, &valuePtr, &done)) { /* * Value is not a legal dictionary. */ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad ", compare, " value: expected dictionary but got \"", TclGetString(objv[1]), "\"", (char *) NULL); goto error; } while (!done) { Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr); Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); |
︙ | ︙ | |||
1307 1308 1309 1310 1311 1312 1313 | } } else { Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]); } } | > | > > | > | > > | > | > > | | | | < > > > | > > | | 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 | } } else { Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]); } } /* * Check for bogus -code value. */ Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr); if ((valuePtr != NULL) && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) { static CONST char *returnCodes[] = { "ok", "error", "return", "break", "continue", NULL }; if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes, NULL, TCL_EXACT, &code)) { /* Value is not a legal return code */ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad completion code \"", TclGetString(valuePtr), "\": must be ok, error, return, break, ", "continue, or an integer", (char *) NULL); goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]); } /* * Check for bogus -level value. */ Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr); if (valuePtr != NULL) { if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level)) || (level < 0)) { /* * Value is not a legal level. */ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad -level value: ", "expected non-negative integer but got \"", TclGetString(valuePtr), "\"", (char *) NULL); goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]); } /* * Convert [return -code return -level X] to [return -code ok -level X+1] */ if (code == TCL_RETURN) { level++; code = TCL_OK; } if (codePtr != NULL) { *codePtr = code; } if (levelPtr != NULL) { *levelPtr = level; } if (optionsPtrPtr == NULL) { /* * Not passing back the options (?!), so clean them up. */ Tcl_DecrRefCount(returnOpts); } else { *optionsPtrPtr = returnOpts; } return TCL_OK; error: Tcl_DecrRefCount(returnOpts); return TCL_ERROR; } /* *------------------------------------------------------------------------- * |
︙ | ︙ | |||
1416 1417 1418 1419 1420 1421 1422 | Tcl_NewIntObj(result)); Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL], Tcl_NewIntObj(0)); } if (result == TCL_ERROR) { /* | | | > | | | | | | | | 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 | Tcl_NewIntObj(result)); Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL], Tcl_NewIntObj(0)); } if (result == TCL_ERROR) { /* * When result was an error, fill in any missing values for * -errorinfo, -errorcode, and -errorline */ Tcl_AddObjErrorInfo(interp, "", -1); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE], Tcl_NewIntObj(iPtr->errorLine)); } return options; } /* *------------------------------------------------------------------------- * * Tcl_SetReturnOptions -- * * Accepts an interp and a dictionary of return options, and sets the * return options of the interp to match the dictionary. * * Results: * A standard status code. Usually TCL_OK, but TCL_ERROR if an invalid * option value was found in the dictionary. If a -level value of 0 is in * the dictionary, then the -code value in the dictionary will be * returned (TCL_OK default). * * Side effects: * Sets the state of the interp. * *------------------------------------------------------------------------- */ |
︙ | ︙ | |||
1478 1479 1480 1481 1482 1483 1484 | } /* *------------------------------------------------------------------------- * * TclTransferResult -- * | | | | < | | | | | | | | | | | | | | | > > > > > > > > | 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 | } /* *------------------------------------------------------------------------- * * TclTransferResult -- * * Copy the result (and error information) from one interp to another. * Used when one interp has caused another interp to evaluate a script * and then wants to transfer the results back to itself. * * This routine copies the string reps of the result and error * information. It does not simply increment the refcounts of the result * and error information objects themselves. It is not legal to exchange * objects between interps, because an object may be kept alive by one * interp, but have an internal rep that is only valid while some other * interp is alive. * * Results: * The target interp's result is set to a copy of the source interp's * result. The source's errorInfo field may be transferred to the * target's errorInfo field, and the source's errorCode field may be * transferred to the target's errorCode field. * * Side effects: * None. * *------------------------------------------------------------------------- */ void TclTransferResult(sourceInterp, result, targetInterp) Tcl_Interp *sourceInterp; /* Interp whose result and error information * should be moved to the target interp. * After moving result, this interp's result * is reset. */ int result; /* TCL_OK if just the result should be copied, * TCL_ERROR if both the result and error * information should be copied. */ Tcl_Interp *targetInterp; /* Interp where result and error information * should be stored. If source and target are * the same, nothing is done. */ { Interp *iPtr = (Interp *) targetInterp; if (sourceInterp == targetInterp) { return; } Tcl_SetReturnOptions(targetInterp, Tcl_GetReturnOptions(sourceInterp, result)); iPtr->flags &= ~(ERR_ALREADY_LOGGED); Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp)); Tcl_ResetResult(sourceInterp); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclScan.c.
|
| | | | | | | | | > | | | | | | > | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | /* * tclScan.c -- * * This file contains the implementation of the "scan" command. * * Copyright (c) 1998 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclScan.c,v 1.16.2.6 2005/09/28 00:23:46 dgp Exp $ */ #include "tclInt.h" /* * Flag values used by Tcl_ScanObjCmd. */ #define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ #define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ #define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ #define SCAN_WIDTH 0x8 /* A width value was supplied. */ #if 0 #define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */ #define SCAN_NODIGITS 0x20 /* No digits have been scanned. */ #define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */ #define SCAN_XOK 0x80 /* An 'x' is allowed. */ #define SCAN_PTOK 0x100 /* Decimal point is allowed. */ #define SCAN_EXPOK 0x200 /* An exponent is allowed. */ #endif #define SCAN_LONGER 0x400 /* Asked for a wide value. */ #define SCAN_BIG 0x800 /* Asked for a bignum value. */ /* * The following structure contains the information associated with a * character set. */ typedef struct CharSet { int exclude; /* 1 if this is an exclusion set. */ int nchars; Tcl_UniChar *chars; int nranges; |
︙ | ︙ | |||
58 59 60 61 62 63 64 | int numVars, int *totalVars)); /* *---------------------------------------------------------------------- * * BuildCharSet -- * | | | | | | 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 | int numVars, int *totalVars)); /* *---------------------------------------------------------------------- * * BuildCharSet -- * * This function examines a character set format specification and builds * a CharSet containing the individual characters and character ranges * specified. * * Results: * Returns the next format position. * * Side effects: * Initializes the charset. * *---------------------------------------------------------------------- */ static char * BuildCharSet(cset, format) CharSet *cset; char *format; /* Points to first char of set. */ { Tcl_UniChar ch, start; int offset, nranges; char *end; memset(cset, 0, sizeof(CharSet)); offset = Tcl_UtfToUniChar(format, &ch); if (ch == '^') { cset->exclude = 1; format += offset; offset = Tcl_UtfToUniChar(format, &ch); } end = format + offset; |
︙ | ︙ | |||
127 128 129 130 131 132 133 | if (ch == ']' || ch == '-') { cset->chars[cset->nchars++] = ch; format += Tcl_UtfToUniChar(format, &ch); } while (ch != ']') { if (*format == '-') { /* | | | | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | if (ch == ']' || ch == '-') { cset->chars[cset->nchars++] = ch; format += Tcl_UtfToUniChar(format, &ch); } while (ch != ']') { if (*format == '-') { /* * This may be the first character of a range, so don't add it * yet. */ start = ch; } else if (ch == '-') { /* * Check to see if this is the last character in the set, in which * case it is not a range and we should add the previous character |
︙ | ︙ | |||
155 156 157 158 159 160 161 | if (start < ch) { cset->ranges[cset->nranges].start = start; cset->ranges[cset->nranges].end = ch; } else { cset->ranges[cset->nranges].start = ch; cset->ranges[cset->nranges].end = start; | | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 | if (start < ch) { cset->ranges[cset->nranges].start = start; cset->ranges[cset->nranges].end = ch; } else { cset->ranges[cset->nranges].start = ch; cset->ranges[cset->nranges].end = start; } cset->nranges++; } } else { cset->chars[cset->nchars++] = ch; } format += Tcl_UtfToUniChar(format, &ch); } |
︙ | ︙ | |||
185 186 187 188 189 190 191 | * *---------------------------------------------------------------------- */ static int CharInSet(cset, c) CharSet *cset; | | | | | 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 | * *---------------------------------------------------------------------- */ static int CharInSet(cset, c) CharSet *cset; int c; /* Character to test, passed as int because of * non-ANSI prototypes. */ { Tcl_UniChar ch = (Tcl_UniChar) c; int i, match = 0; for (i = 0; i < cset->nchars; i++) { if (cset->chars[i] == ch) { match = 1; break; } } if (!match) { for (i = 0; i < cset->nranges; i++) { if ((cset->ranges[i].start <= ch) && (ch <= cset->ranges[i].end)) { match = 1; break; } } } return (cset->exclude ? !match : match); } /* *---------------------------------------------------------------------- * * ReleaseCharSet -- * |
︙ | ︙ | |||
239 240 241 242 243 244 245 | } /* *---------------------------------------------------------------------- * * ValidateFormat -- * | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * ValidateFormat -- * * Parse the format string and verify that it is properly formed and that * there are exactly enough variables on the command line. * * Results: * A standard Tcl result. * * Side effects: * May place an error in the interpreter result. * *---------------------------------------------------------------------- */ static int ValidateFormat(interp, format, numVars, totalSubs) Tcl_Interp *interp; /* Current interpreter. */ char *format; /* The format string. */ int numVars; /* The number of variables passed to the scan * command. */ int *totalSubs; /* The number of variables that will be * required. */ { #define STATIC_LIST_SIZE 16 int gotXpg, gotSequential, value, i, flags; char *end; Tcl_UniChar ch; int staticAssign[STATIC_LIST_SIZE]; int *nassign = staticAssign; int objIndex, xpgSize, nspace = STATIC_LIST_SIZE; char buf[TCL_UTF_MAX+1]; /* * Initialize an array that records the number of times a variable is * assigned to by the format string. We use this to detect if a variable * is multiply assigned or left unassigned. */ if (numVars > nspace) { nassign = (int*)ckalloc(sizeof(int) * numVars); nspace = numVars; } for (i = 0; i < nspace; i++) { |
︙ | ︙ | |||
305 306 307 308 309 310 311 | flags |= SCAN_SUPPRESS; format += Tcl_UtfToUniChar(format, &ch); goto xpgCheckDone; } if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ /* | | | | | | | | | > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | 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 | flags |= SCAN_SUPPRESS; format += Tcl_UtfToUniChar(format, &ch); goto xpgCheckDone; } if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ /* * Check for an XPG3-style %n$ specification. Note: there must * not be a mixture of XPG3 specs and non-XPG3 specs in the same * format string. */ value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ if (*end != '$') { goto notXpg; } format = end+1; format += Tcl_UtfToUniChar(format, &ch); gotXpg = 1; if (gotSequential) { goto mixedXPG; } objIndex = value - 1; if ((objIndex < 0) || (numVars && (objIndex >= numVars))) { goto badIndex; } else if (numVars == 0) { /* * In the case where no vars are specified, the user can * specify %9999$ legally, so we have to consider special * rules for growing the assign array. 'value' is guaranteed * to be > 0. */ xpgSize = (xpgSize > value) ? xpgSize : value; } goto xpgCheckDone; } notXpg: gotSequential = 1; if (gotXpg) { mixedXPG: Tcl_SetResult(interp, "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC); goto error; } xpgCheckDone: /* * Parse any width specifier. */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ value = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ flags |= SCAN_WIDTH; format += Tcl_UtfToUniChar(format, &ch); } /* * Handle any size specifier. */ switch (ch) { case 'l': if (*format == 'l') { flags |= SCAN_BIG; format += 1; format += Tcl_UtfToUniChar(format, &ch); break; } case 'L': flags |= SCAN_LONGER; case 'h': format += Tcl_UtfToUniChar(format, &ch); } if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) { goto badIndex; } /* * Handle the various field types. */ switch (ch) { case 'c': if (flags & SCAN_WIDTH) { Tcl_SetResult(interp, "field width may not be specified in %c conversion", TCL_STATIC); goto error; } /* * Fall through! */ case 'n': case 's': if (flags & (SCAN_LONGER|SCAN_BIG)) { invalidFieldSize: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; Tcl_AppendResult(interp, "field size modifier may not be specified in %", buf, " conversion", NULL); goto error; } /* * Fall through! */ case 'd': case 'e': case 'f': case 'g': case 'i': case 'o': case 'x': break; case 'u': if (flags & SCAN_BIG) { Tcl_SetResult(interp, "unsigned bignum scans are invalid", TCL_STATIC); goto error; } break; /* * Bracket terms need special checking */ case '[': if (flags & (SCAN_LONGER|SCAN_BIG)) { goto invalidFieldSize; } if (*format == '\0') { goto badSet; } format += Tcl_UtfToUniChar(format, &ch); if (ch == '^') { if (*format == '\0') { goto badSet; } format += Tcl_UtfToUniChar(format, &ch); } if (ch == ']') { if (*format == '\0') { goto badSet; } format += Tcl_UtfToUniChar(format, &ch); } while (ch != ']') { if (*format == '\0') { goto badSet; } format += Tcl_UtfToUniChar(format, &ch); } break; badSet: Tcl_SetResult(interp, "unmatched [ in format string", TCL_STATIC); goto error; default: { char buf[TCL_UTF_MAX+1]; buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; Tcl_AppendResult(interp, "bad scan conversion character \"", buf, "\"", NULL); goto error; } } if (!(flags & SCAN_SUPPRESS)) { if (objIndex >= nspace) { /* * Expand the nassign buffer. If we are using XPG specifiers, * make sure that we grow to a large enough size. xpgSize is * guaranteed to be at least one larger than objIndex. */ value = nspace; if (xpgSize) { nspace = xpgSize; } else { nspace += STATIC_LIST_SIZE; } if (nassign == staticAssign) { |
︙ | ︙ | |||
500 501 502 503 504 505 506 | } } if (totalSubs) { *totalSubs = numVars; } for (i = 0; i < numVars; i++) { if (nassign[i] > 1) { | > | > | | > > | > | | | | | | 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 | } } if (totalSubs) { *totalSubs = numVars; } for (i = 0; i < numVars; i++) { if (nassign[i] > 1) { Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", TCL_STATIC); goto error; } else if (!xpgSize && (nassign[i] == 0)) { /* * If the space is empty, and xpgSize is 0 (means XPG wasn't used, * and/or numVars != 0), then too many vars were given */ Tcl_SetResult(interp, "variable is not assigned by any conversion specifiers", TCL_STATIC); goto error; } } if (nassign != staticAssign) { ckfree((char *)nassign); } return TCL_OK; badIndex: if (gotXpg) { Tcl_SetResult(interp, "\"%n$\" argument index out of range", TCL_STATIC); } else { Tcl_SetResult(interp, "different numbers of variable names and field specifiers", TCL_STATIC); } error: if (nassign != staticAssign) { ckfree((char *)nassign); } return TCL_ERROR; #undef STATIC_LIST_SIZE } /* *---------------------------------------------------------------------- * * Tcl_ScanObjCmd -- * * This function is invoked to process the "scan" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
564 565 566 567 568 569 570 | int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *format; int numVars, nconversions, totalVars = -1; int objIndex, offset, i, result, code; long value; | | < < < < < | | | > > > > > > > | | | | | > | | | | | > | | | | | > > > > > > | | | | | | | | | | > > | | | > | | | > > | | | > | | | > > | | | > | | | > > | | | > | | | < | > > | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | < | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > > | | | < < | | | | < < | < | > | < | < | | < < < < < < < < < | < < < < < < < < | < < < | | | < < < < | < < < < < | < < < < < < < < < < < < < < | | < < < | < < < < < < < < < < < < < < < < < < | > | < | | > | > > | | < | | | | | < > | | > | 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 | int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *format; int numVars, nconversions, totalVars = -1; int objIndex, offset, i, result, code; long value; CONST char *string, *end, *baseString; char op = 0; int underflow = 0; size_t width; Tcl_WideInt wideValue; Tcl_UniChar ch, sch; Tcl_Obj **objs = NULL, *objPtr = NULL; int flags; char buf[513]; /* Temporary buffer to hold scanned number * strings before they are passed to * strtoul. */ #if 0 int base = 0; long (*fn) _ANSI_ARGS_((char*,void*,int)) = NULL; #ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt (*lfn) _ANSI_ARGS_((char*,void*,int)) = NULL; #endif #endif if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "string format ?varName varName ...?"); return TCL_ERROR; } format = Tcl_GetStringFromObj(objv[2], NULL); numVars = objc-3; /* * Check for errors in the format string. */ if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) { return TCL_ERROR; } /* * Allocate space for the result objects. */ if (totalVars > 0) { objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * totalVars); for (i = 0; i < totalVars; i++) { objs[i] = NULL; } } string = Tcl_GetStringFromObj(objv[1], NULL); baseString = string; /* * Iterate over the format string filling in the result objects until we * reach the end of input, the end of the format string, or there is a * mismatch. */ objIndex = 0; nconversions = 0; while (*format != '\0') { int parseFlag = 0; format += Tcl_UtfToUniChar(format, &ch); flags = 0; /* * If we see whitespace in the format, skip whitespace in the string. */ if (Tcl_UniCharIsSpace(ch)) { offset = Tcl_UtfToUniChar(string, &sch); while (Tcl_UniCharIsSpace(sch)) { if (*string == '\0') { goto done; } string += offset; offset = Tcl_UtfToUniChar(string, &sch); } continue; } if (ch != '%') { literal: if (*string == '\0') { underflow = 1; goto done; } string += Tcl_UtfToUniChar(string, &sch); if (ch != sch) { goto done; } continue; } format += Tcl_UtfToUniChar(format, &ch); if (ch == '%') { goto literal; } /* * Check for assignment suppression ('*') or an XPG3-style assignment * ('%n$'). */ if (ch == '*') { flags |= SCAN_SUPPRESS; format += Tcl_UtfToUniChar(format, &ch); } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ char *formatEnd; value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */ if (*formatEnd == '$') { format = formatEnd+1; format += Tcl_UtfToUniChar(format, &ch); objIndex = (int) value - 1; } } /* * Parse any width specifier. */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ width = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ format += Tcl_UtfToUniChar(format, &ch); } else { width = 0; } /* * Handle any size specifier. */ switch (ch) { case 'l': if (*format == 'l') { flags |= SCAN_BIG; format += 1; format += Tcl_UtfToUniChar(format, &ch); break; } case 'L': flags |= SCAN_LONGER; /* * Fall through so we skip to the next character. */ case 'h': format += Tcl_UtfToUniChar(format, &ch); } /* * Handle the various field types. */ switch (ch) { case 'n': if (!(flags & SCAN_SUPPRESS)) { objPtr = Tcl_NewIntObj(string - baseString); Tcl_IncrRefCount(objPtr); objs[objIndex++] = objPtr; } nconversions++; continue; case 'd': op = 'i'; parseFlag = TCL_PARSE_DECIMAL_ONLY; #if 0 base = 10; fn = (long (*) _ANSI_ARGS_((char*,void*,int)))strtol; #ifndef TCL_WIDE_INT_IS_LONG lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll; #endif #endif break; case 'i': op = 'i'; parseFlag = TCL_PARSE_SCAN_PREFIXES; #if 0 base = 0; fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtol; #ifndef TCL_WIDE_INT_IS_LONG lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll; #endif #endif break; case 'o': op = 'i'; parseFlag = TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES; #if 0 base = 8; fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul; #ifndef TCL_WIDE_INT_IS_LONG lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull; #endif #endif break; case 'x': op = 'i'; parseFlag = TCL_PARSE_HEXADECIMAL_ONLY; #if 0 base = 16; fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul; #ifndef TCL_WIDE_INT_IS_LONG lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull; #endif #endif break; case 'u': op = 'i'; flags |= SCAN_UNSIGNED; #if 0 base = 10; fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul; #ifndef TCL_WIDE_INT_IS_LONG lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull; #endif #endif break; case 'f': case 'e': case 'g': op = 'f'; break; case 's': op = 's'; break; case 'c': op = 'c'; flags |= SCAN_NOSKIP; break; case '[': op = '['; flags |= SCAN_NOSKIP; break; } /* * At this point, we will need additional characters from the string * to proceed. */ if (*string == '\0') { underflow = 1; goto done; } /* * Skip any leading whitespace at the beginning of a field unless the * format suppresses this behavior. */ if (!(flags & SCAN_NOSKIP)) { while (*string != '\0') { offset = Tcl_UtfToUniChar(string, &sch); if (!Tcl_UniCharIsSpace(sch)) { break; } string += offset; } if (*string == '\0') { underflow = 1; goto done; } } /* * Perform the requested scanning operation. */ switch (op) { case 's': /* * Scan a string up to width characters or whitespace. */ if (width == 0) { width = (size_t) ~0; } end = string; while (*end != '\0') { offset = Tcl_UtfToUniChar(end, &sch); if (Tcl_UniCharIsSpace(sch)) { break; } end += offset; if (--width == 0) { break; } } if (!(flags & SCAN_SUPPRESS)) { objPtr = Tcl_NewStringObj(string, end-string); Tcl_IncrRefCount(objPtr); objs[objIndex++] = objPtr; } string = end; break; case '[': { CharSet cset; if (width == 0) { width = (size_t) ~0; } end = string; format = BuildCharSet(&cset, format); while (*end != '\0') { offset = Tcl_UtfToUniChar(end, &sch); if (!CharInSet(&cset, (int)sch)) { break; } end += offset; if (--width == 0) { break; } } ReleaseCharSet(&cset); if (string == end) { /* * Nothing matched the range, stop processing. */ goto done; } if (!(flags & SCAN_SUPPRESS)) { objPtr = Tcl_NewStringObj(string, end-string); Tcl_IncrRefCount(objPtr); objs[objIndex++] = objPtr; } string = end; break; } case 'c': /* * Scan a single Unicode character. */ string += Tcl_UtfToUniChar(string, &sch); if (!(flags & SCAN_SUPPRESS)) { objPtr = Tcl_NewIntObj((int)sch); Tcl_IncrRefCount(objPtr); objs[objIndex++] = objPtr; } break; case 'i': /* * Scan an unsigned or signed integer. */ #if 0 if ((width == 0) || (width > sizeof(buf) - 1)) { width = sizeof(buf) - 1; } flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO; for (end = buf; width > 0; width--) { switch (*string) { /* * The 0 digit has special meaning at the beginning of a * number. If we are unsure of the base, it indicates that * we are in base 8 or base 16 (if it is followed by an * 'x'). * * 8.1 - 8.3.4 incorrectly handled 0x... base-16 cases for * %x by not reading the 0x as the auto-prelude for * base-16. [Bug #495213] */ case '0': if (base == 0) { base = 8; flags |= SCAN_XOK; } if (base == 16) { flags |= SCAN_XOK; } if (flags & SCAN_NOZERO) { flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO); } else { flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); } goto addToInt; case '1': case '2': case '3': case '4': case '5': case '6': case '7': if (base == 0) { base = 10; } flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); goto addToInt; case '8': case '9': if (base == 0) { base = 10; } if (base <= 8) { break; } flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); goto addToInt; case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': if (base <= 10) { break; } flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); goto addToInt; case '+': case '-': if (flags & SCAN_SIGNOK) { flags &= ~SCAN_SIGNOK; goto addToInt; } break; case 'x': case 'X': if ((flags & SCAN_XOK) && (end == buf+1)) { base = 16; flags &= ~SCAN_XOK; goto addToInt; } break; } /* * We got an illegal character so we are done accumulating. */ break; addToInt: /* * Add the character to the temporary buffer. */ *end++ = *string++; if (*string == '\0') { break; } } /* * Check to see if we need to back up because we only got a sign * or a trailing x after a 0. */ if (flags & SCAN_NODIGITS) { if (*string == '\0') { underflow = 1; } goto done; } else if (end[-1] == 'x' || end[-1] == 'X') { end--; string--; } /* * Scan the value from the temporary buffer. If we are returning a * large unsigned value, we have to convert it back to a string * since Tcl only supports signed values. */ if (!(flags & SCAN_SUPPRESS)) { *end = '\0'; #ifndef TCL_WIDE_INT_IS_LONG if (flags & SCAN_LONGER) { wideValue = (Tcl_WideInt) (*lfn)(buf, NULL, base); if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { /* INTL: ISO digit */ sprintf(buf, "%" TCL_LL_MODIFIER "u", (Tcl_WideUInt)wideValue); objPtr = Tcl_NewStringObj(buf, -1); } else { objPtr = Tcl_NewWideIntObj(wideValue); } } else { #endif /* !TCL_WIDE_INT_IS_LONG */ value = (long) (*fn)(buf, NULL, base); if ((flags & SCAN_UNSIGNED) && (value < 0)) { sprintf(buf, "%lu", value); /* INTL: ISO digit */ objPtr = Tcl_NewStringObj(buf, -1); } else if ((flags & SCAN_LONGER) || (unsigned long) value > UINT_MAX) { objPtr = Tcl_NewLongObj(value); } else { objPtr = Tcl_NewIntObj(value); } #ifndef TCL_WIDE_INT_IS_LONG } #endif Tcl_IncrRefCount(objPtr); objs[objIndex++] = objPtr; } break; #else objPtr = Tcl_NewLongObj(0); Tcl_IncrRefCount(objPtr); if (width == 0) { width = -1; } if (TclParseNumber(NULL, objPtr, NULL, string, width, &end, TCL_PARSE_INTEGER_ONLY | parseFlag) != TCL_OK) { Tcl_DecrRefCount(objPtr); /* TODO: set underflow? test scan-4.44 */ goto done; } string = end; if (flags & SCAN_SUPPRESS) { Tcl_DecrRefCount(objPtr); break; } if (flags & SCAN_LONGER) { if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */ if (Tcl_GetString(objPtr)[0] == '-') { wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */ } } if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { sprintf(buf, "%" TCL_LL_MODIFIER "u", (Tcl_WideUInt)wideValue); Tcl_SetStringObj(objPtr, buf, -1); } else { Tcl_SetWideIntObj(objPtr, wideValue); } } else if (!(flags & SCAN_BIG)) { if (Tcl_GetLongFromObj(NULL, objPtr, &value) != TCL_OK) { if (Tcl_GetString(objPtr)[0] == '-') { value = LONG_MIN; } else { value = LONG_MAX; } } if ((flags & SCAN_UNSIGNED) && (value < 0)) { sprintf(buf, "%lu", value); /* INTL: ISO digit */ Tcl_SetStringObj(objPtr, buf, -1); } else { Tcl_SetLongObj(objPtr, value); } } objs[objIndex++] = objPtr; break; #endif case 'f': /* * Scan a floating point number */ objPtr = Tcl_NewDoubleObj(0.0); Tcl_IncrRefCount(objPtr); if (width == 0) { width = -1; } if (TclParseNumber(NULL, objPtr, NULL, string, width, &end, TCL_PARSE_DECIMAL_ONLY) != TCL_OK) { /* TODO: set underflow? test scan-4.55 */ Tcl_DecrRefCount(objPtr); goto done; } else if (flags & SCAN_SUPPRESS) { Tcl_DecrRefCount(objPtr); string = end; } else { double dvalue; if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) { #ifdef ACCEPT_NAN if (objPtr->typePtr == &tclDoubleType) { dValue = objPtr->internalRep.doubleValue; } else #endif { Tcl_DecrRefCount(objPtr); goto done; } } Tcl_SetDoubleObj(objPtr, dvalue); objs[objIndex++] = objPtr; string = end; } } nconversions++; } done: result = 0; code = TCL_OK; if (numVars) { /* * In this case, variables were specified (classic scan). */ for (i = 0; i < totalVars; i++) { if (objs[i] == NULL) { continue; } result++; if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", TclGetString(objv[i+3]), "\"", (char *) NULL); code = TCL_ERROR; } Tcl_DecrRefCount(objs[i]); } } else { /* * Here no vars were specified, we want a list returned (inline scan) */ objPtr = Tcl_NewObj(); for (i = 0; i < totalVars; i++) { if (objs[i] != NULL) { Tcl_ListObjAppendElement(NULL, objPtr, objs[i]); Tcl_DecrRefCount(objs[i]); } else { /* * More %-specifiers than matching chars, so we just spit out * empty strings for these. */ Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj()); } } } if (objs != NULL) { ckfree((char*) objs); } |
︙ | ︙ | |||
1209 1210 1211 1212 1213 1214 1215 | } else if (numVars) { objPtr = Tcl_NewIntObj(result); } Tcl_SetObjResult(interp, objPtr); } return code; } | > > > > > > > > | 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 | } else if (numVars) { objPtr = Tcl_NewIntObj(result); } Tcl_SetObjResult(interp, objPtr); } return code; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Added generic/tclStrToD.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 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 | /* *---------------------------------------------------------------------- * * tclDouble.c -- * * This file contains a collection of procedures for managing * conversions to/from floating-point in Tcl. They include * TclParseNumber, which parses numbers from strings; TclDoubleDigits, * which formats numbers into strings of digits, and procedures for * interconversion among 'double' and 'mp_int' types. * * Copyright (c) 2005 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: tclStrToD.c,v 1.1.2.39 2005/09/26 20:16:53 kennykb Exp $ * *---------------------------------------------------------------------- */ #include <tclInt.h> #include <stdio.h> #include <stdlib.h> #include <float.h> #include <limits.h> #include <math.h> #include <ctype.h> #include <tommath.h> /* * Define TIP_114_FORMATS to accept 0b and 0o for binary and octal strings. * Define KILL_OCTAL as well as TIP_114_FORMATS to suppress interpretation * of numbers with leading zero as octal. (Ceterum censeo: numeros octonarios * delendos esse.) */ #define TIP_114_FORMATS #undef KILL_OCTAL #ifndef TIP_114_FORMATS #undef KILL_OCTAL #endif /* * This code supports (at least hypothetically), IBM, Cray, VAX and * IEEE-754 floating point; of these, only IEEE-754 can represent NaN. * IEEE-754 can be uniquely determined by radix and by the widths of * significand and exponent. */ #if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) # define IEEE_FLOATING_POINT #endif /* * gcc on x86 needs access to rounding controls, because of a questionable * feature where it retains intermediate results as IEEE 'long double' values * somewhat unpredictably. It is tempting to include fpu_control.h, but * that file exists only on Linux; it is missing on Cygwin and MinGW. Most * gcc-isms and ix86-isms are factored out here. */ #if defined(__GNUC__) && defined(__i386) typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); #define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw)) #define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)) # define FPU_IEEE_ROUNDING 0x027f # define ADJUST_FPU_CONTROL_WORD #endif /* * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. * Everyone else uses 7ff8000000000000. (Why, HP, why?) */ #ifdef __hppa # define NAN_START 0x7ff4 # define NAN_MASK (((Tcl_WideUInt) 1) << 50) #else # define NAN_START 0x7ff8 # define NAN_MASK (((Tcl_WideUInt) 1) << 51) #endif /* The powers of ten that can be represented exactly as wide integers */ static int maxpow10_wide; static Tcl_WideUInt *pow10_wide; /* The number of decimal digits that fit in an mp_digit */ static int log10_DIGIT_MAX; /* The powers of ten that can be represented exactly as IEEE754 doubles. */ #define MAXPOW 22 static double pow10 [MAXPOW+1]; static int mmaxpow; /* Largest power of ten that can be * represented exactly in a 'double'. */ /* Inexact higher powers of ten */ static CONST double pow_10_2_n [] = { 1.0, 100.0, 10000.0, 1.0e+8, 1.0e+16, 1.0e+32, 1.0e+64, 1.0e+128, 1.0e+256 }; /* Logarithm of the floating point radix. */ static int log2FLT_RADIX; /* Number of bits in a double's significand */ static int mantBits; /* Table of powers of 5**(2**n), up to 5**256 */ static mp_int pow5[9]; /* The smallest representable double */ static double tiny; /* The maximum number of digits to the left of the decimal point of a * double. */ static int maxDigits; /* The maximum number of digits to the right of the decimal point in a * double. */ static int minDigits; /* Number of mp_digit's needed to hold the significand of a double */ static int mantDIGIT; /* Static functions defined in this file */ static int AccumulateDecimalDigit _ANSI_ARGS_((unsigned, int, Tcl_WideUInt*, mp_int*, int)); static double MakeLowPrecisionDouble _ANSI_ARGS_((int signum, Tcl_WideUInt significand, int nSigDigs, int exponent)); static double MakeHighPrecisionDouble _ANSI_ARGS_((int signum, mp_int* significand, int nSigDigs, int exponent)); static double MakeNaN _ANSI_ARGS_(( int signum, Tcl_WideUInt tag )); static double RefineApproximation _ANSI_ARGS_((double approx, mp_int* exactSignificand, int exponent)); static double AbsoluteValue(double v, int* signum); static int GetIntegerTimesPower(double v, mp_int* r, int* e); static double BignumToBiasedFrExp _ANSI_ARGS_(( mp_int* big, int* machexp )); static double Pow10TimesFrExp _ANSI_ARGS_(( int exponent, double fraction, int* machexp )); static double SafeLdExp _ANSI_ARGS_(( double fraction, int exponent )); /* *---------------------------------------------------------------------- * * TclParseNumber -- * * Place a "numeric" internal representation on a Tcl object. * * Results: * Returns a standard Tcl result. * * Side effects: * Stores an internal representation appropriate to the string. * The internal representation may be an integer, a wide integer, * a bignum, or a double. * * TclMakeObjNumeric is called as a common scanner in routines * that expect numbers in Tcl_Obj's. It scans the string representation * of a given Tcl_Obj and stores an internal rep that represents * a "canonical" version of its numeric value. The value of the * canonicalization is that a routine can determine simply by * examining the type pointer whether an object LooksLikeInt, * what size of integer is needed to hold it, and similar questions, * and never needs to refer back to the string representation, even * for "impure" objects. * * The 'strPtr' and 'endPtrPtr' arguments allow for recognizing a number * that is in a substring of a Tcl_Obj, for example a screen metric or * "end-" index. If 'strPtr' is not NULL, it designates where the * number begins within the string. (The default is the start of * objPtr's string rep, which will be constructed if necessary.) * * If 'strPtr' is supplied, 'objPtr' may be NULL. In this case, * no internal representation will be generated; instead, the routine * will simply check for a syntactically correct number, returning * TCL_OK or TCL_ERROR as appropriate, and setting *endPtrPtr if * necessary. * * If 'endPtrPtr' is not NULL, it designates the first character * after the scanned number. In this case, successfully recognizing * any digits will yield a return code of TCL_OK. Only in the case * where no leading string of 'strPtr' (or of objPtr's internal rep) * represents a number will TCL_ERROR be returned. * * When only a partial string is being recognized, it is the caller's * responsibility to destroy the internal representation, or at * least change its type. Failure to do so will lead to subsequent * problems where a string that does not represent a number will * be recognized as one because it has a numeric internal representation. * * When the 'flags' word includes TCL_PARSE_DECIMAL_ONLY, only decimal * numbers are recognized; leading 0 has no special interpretation as * octal and leading '0x' is forbidden. * *---------------------------------------------------------------------- */ int TclParseNumber( Tcl_Interp* interp, /* Tcl interpreter for error reporting. * May be NULL */ Tcl_Obj* objPtr, /* Object to receive the internal rep */ CONST char* type, /* Type of number being parsed ("integer", * "wide integer", etc. */ CONST char* string, /* Pointer to the start of the string to * scan, see above */ size_t length, /* Maximum length of the string to scan, * see above. */ CONST char** endPtrPtr, /* (Output) pointer to the end of the * scanned number, see above */ int flags) /* Flags governing the parse */ { enum State { INITIAL, SIGNUM, ZERO, ZERO_X, #ifdef TIP_114_FORMATS ZERO_O, ZERO_B, BINARY, #endif HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL, LEADING_RADIX_POINT, FRACTION, EXPONENT_START, EXPONENT_SIGNUM, EXPONENT, sI, sIN, sINF, sINFI, sINFIN, sINFINI, sINFINIT, sINFINITY #ifdef IEEE_FLOATING_POINT , sN, sNA, sNAN, sNANPAREN, sNANHEX, sNANFINISH #endif } state = INITIAL; enum State acceptState = INITIAL; int signum = 0; /* Sign of the number being parsed */ Tcl_WideUInt significandWide = 0; /* Significand of the number being * parsed (if no overflow) */ mp_int significandBig; /* Significand of the number being * parsed (if it overflows significandWide) */ int significandOverflow = 0; /* Flag==1 iff significandBig is used */ Tcl_WideUInt octalSignificandWide = 0; /* Significand of an octal number; needed * because we don't know whether a number * with a leading zero is octal or decimal * until we've scanned forward to a '.' or * 'e' */ mp_int octalSignificandBig; /* Significand of octal number once * octalSignificandWide overflows */ int octalSignificandOverflow = 0; /* Flag==1 if octalSignificandBig is used */ int numSigDigs = 0; /* Number of significant digits in the * decimal significand */ int numTrailZeros = 0; /* Number of trailing zeroes at the * current point in the parse. */ int numDigitsAfterDp = 0; /* Number of digits scanned after the * decimal point */ int exponentSignum = 0; /* Signum of the exponent of a floating * point number */ long exponent = 0; /* Exponent of a floating point number */ CONST char* p; /* Pointer to next character to scan */ size_t len; /* Number of characters remaining after p */ CONST char* acceptPoint; /* Pointer to position after last character * in an acceptable number */ size_t acceptLen; /* Number of characters following that point */ int status = TCL_OK; /* Status to return to caller */ char d; /* Last hexadecimal digit scanned */ int shift = 0; /* Amount to shift when accumulating binary */ #ifdef TIP_114_FORMATS int explicitOctal = 0; #endif /* * Initialize string to start of the object's string rep if * the caller didn't pass anything else. */ if ( string == NULL ) { string = Tcl_GetStringFromObj( objPtr, NULL ); } p = string; len = length; acceptPoint = p; acceptLen = len; while ( 1 ) { char c = len ? *p : '\0'; switch (state) { case INITIAL: /* * Initial state. Acceptable characters are +, -, digits, * period, I, N, and whitespace. */ if (isspace(UCHAR(c))) { break; } else if (c == '+') { state = SIGNUM; break; } else if (c == '-') { signum = 1; state = SIGNUM; break; } /* FALLTHROUGH */ case SIGNUM: /* * Scanned a leading + or -. Acceptable characters are * digits, period, I, and N. */ if (c == '0') { if (flags & TCL_PARSE_DECIMAL_ONLY) { state = DECIMAL; } else { state = ZERO; } break; } else if (flags & TCL_PARSE_HEXADECIMAL_ONLY) { goto zerox; } else if (flags & TCL_PARSE_OCTAL_ONLY) { goto zeroo; } else if (isdigit(UCHAR(c))) { significandWide = c - '0'; numSigDigs = 1; state = DECIMAL; break; } else if (flags & TCL_PARSE_INTEGER_ONLY) { goto endgame; } else if (c == '.') { state = LEADING_RADIX_POINT; break; } else if (c == 'I' || c == 'i') { state = sI; break; #ifdef IEEE_FLOATING_POINT } else if (c == 'N' || c == 'n') { state = sN; break; #endif } goto endgame; case ZERO: /* * Scanned a leading zero (perhaps with a + or -). * Acceptable inputs are digits, period, X, and E. * If 8 or 9 is encountered, the number can't be * octal. This state and the OCTAL state differ only * in whether they recognize 'X'. */ acceptState = state; acceptPoint = p; acceptLen = len; if (c == 'x' || c == 'X') { state = ZERO_X; break; } if (flags & TCL_PARSE_HEXADECIMAL_ONLY) { goto zerox; } #ifdef TIP_114_FORMATS if (flags & TCL_PARSE_SCAN_PREFIXES) { goto zeroo; } if (c == 'b' || c == 'B') { state = ZERO_B; break; } if (c == 'o' || c == 'O') { explicitOctal = 1; state = ZERO_O; break; } #ifdef KILL_OCTAL goto decimal; #endif #endif /* FALLTHROUGH */ case OCTAL: /* * Scanned an optional + or -, followed by a string of * octal digits. Acceptable inputs are more digits, * period, or E. If 8 or 9 is encountered, commit to * floating point. */ acceptState = state; acceptPoint = p; acceptLen = len; #ifdef TIP_114_FORMATS /* FALLTHROUGH */ case ZERO_O: #endif zeroo: if (c == '0') { ++numTrailZeros; state = OCTAL; break; } else if (c >= '1' && c <= '7') { if (objPtr != NULL) { shift = 3 * (numTrailZeros + 1); significandOverflow = AccumulateDecimalDigit((unsigned)(c-'0'), numTrailZeros, &significandWide, &significandBig, significandOverflow); if (!octalSignificandOverflow) { /* * Shifting by more bits than are in the value being * shifted is at least de facto nonportable. Check * for too large shifts first. */ if ((octalSignificandWide != 0) && ((shift >= CHAR_BIT*sizeof(Tcl_WideUInt)) || (octalSignificandWide > (~(Tcl_WideUInt)0 >> shift)))) { octalSignificandOverflow = 1; TclBNInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); } } if (!octalSignificandOverflow) { octalSignificandWide = (octalSignificandWide << shift) + (c - '0'); } else { mp_mul_2d(&octalSignificandBig, shift, &octalSignificandBig); mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'), &octalSignificandBig); } } if ( numSigDigs != 0 ) { numSigDigs += ( numTrailZeros + 1 ); } else { numSigDigs = 1; } numTrailZeros = 0; state = OCTAL; break; } /* FALLTHROUGH */ case BAD_OCTAL: #ifdef TIP_114_FORMATS if (explicitOctal) { /* No forgiveness for bad digits in explicitly octal numbers */ goto endgame; } #endif if (flags & TCL_PARSE_INTEGER_ONLY) { /* No seeking floating point when parsing only integer */ goto endgame; } #ifndef KILL_OCTAL /* * Scanned a number with a leading zero that contains an * 8, 9, radix point or E. This is an invalid octal number, * but might still be floating point. */ if (c == '0') { ++numTrailZeros; state = BAD_OCTAL; break; } else if (isdigit(UCHAR(c))) { if (objPtr != NULL) { significandOverflow = AccumulateDecimalDigit((unsigned)(c-'0'), numTrailZeros, &significandWide, &significandBig, significandOverflow); } if ( numSigDigs != 0 ) { numSigDigs += ( numTrailZeros + 1 ); } else { numSigDigs = 1; } numTrailZeros = 0; state = BAD_OCTAL; break; } else if (c == '.') { state = FRACTION; break; } else if (c == 'E' || c == 'e') { state = EXPONENT_START; break; } #endif goto endgame; /* * Scanned 0x. If state is HEXADECIMAL, scanned at least * one character following the 0x. The only acceptable * inputs are hexadecimal digits. */ case HEXADECIMAL: acceptState = state; acceptPoint = p; acceptLen = len; /* FALLTHROUGH */ case ZERO_X: zerox: if (c == '0') { ++numTrailZeros; state = HEXADECIMAL; break; } else if (isdigit(UCHAR(c))) { d = (c-'0'); } else if (c >= 'A' && c <= 'F') { d = (c-'A'+10); } else if (c >= 'a' && c <= 'f') { d = (c-'a'+10); } else { goto endgame; } if (objPtr != NULL) { shift = 4 * (numTrailZeros + 1); if (!significandOverflow) { /* * Shifting by more bits than are in the value being * shifted is at least de facto nonportable. Check * for too large shifts first. */ if (significandWide != 0 && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (~(Tcl_WideUInt)0 >> shift))) { significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); } } if (!significandOverflow) { significandWide = (significandWide << shift) + d; } else { mp_mul_2d(&significandBig, shift, &significandBig); mp_add_d(&significandBig, (mp_digit) d, &significandBig); } } numTrailZeros = 0; state = HEXADECIMAL; break; #ifdef TIP_114_FORMATS case BINARY: acceptState = state; acceptPoint = p; acceptLen = len; case ZERO_B: if (c == '0') { ++numTrailZeros; state = BINARY; break; } else if (c != '1') { goto endgame; } if (objPtr != NULL) { shift = numTrailZeros + 1; if (!significandOverflow) { /* * Shifting by more bits than are in the value being * shifted is at least de facto nonportable. Check * for too large shifts first. */ if (significandWide != 0 && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (~(Tcl_WideUInt)0 >> shift))) { significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); } } if (!significandOverflow) { significandWide = (significandWide << shift) + 1; } else { mp_mul_2d(&significandBig, shift, &significandBig); mp_add_d(&significandBig, (mp_digit) 1, &significandBig); } } numTrailZeros = 0; state = BINARY; break; #endif case DECIMAL: /* * Scanned an optional + or - followed by a string of * decimal digits. */ #ifdef KILL_OCTAL decimal: #endif acceptState = state; acceptPoint = p; acceptLen = len; if (c == '0') { ++numTrailZeros; state = DECIMAL; break; } else if (isdigit(UCHAR(c))) { if (objPtr != NULL) { significandOverflow = AccumulateDecimalDigit((unsigned)(c - '0'), numTrailZeros, &significandWide, &significandBig, significandOverflow); } numSigDigs += ( numTrailZeros + 1 ); numTrailZeros = 0; state = DECIMAL; break; } else if (flags & TCL_PARSE_INTEGER_ONLY) { goto endgame; } else if (c == '.') { state = FRACTION; break; } else if (c == 'E' || c == 'e') { state = EXPONENT_START; break; } goto endgame; /* * Found a decimal point. If no digits have yet been scanned, * E is not allowed; otherwise, it introduces the exponent. * If at least one digit has been found, we have a possible * complete number. */ case FRACTION: acceptState = state; acceptPoint = p; acceptLen = len; if (c == 'E' || c=='e') { state = EXPONENT_START; break; } /* FALLTHROUGH */ case LEADING_RADIX_POINT: if (c == '0') { ++numDigitsAfterDp; ++numTrailZeros; state = FRACTION; break; } else if (isdigit(UCHAR(c))) { ++numDigitsAfterDp; if (objPtr != NULL) { significandOverflow = AccumulateDecimalDigit((unsigned)(c-'0'), numTrailZeros, &significandWide, &significandBig, significandOverflow); } if ( numSigDigs != 0 ) { numSigDigs += ( numTrailZeros + 1 ); } else { numSigDigs = 1; } numTrailZeros = 0; state = FRACTION; break; } goto endgame; case EXPONENT_START: /* * Scanned the E at the start of an exponent. Make sure * a legal character follows before using the C library * strtol routine, which allows whitespace. */ if (c == '+') { state = EXPONENT_SIGNUM; break; } else if (c == '-') { exponentSignum = 1; state = EXPONENT_SIGNUM; break; } /* FALLTHROUGH */ case EXPONENT_SIGNUM: /* * Found the E at the start of the exponent, followed by * a sign character. */ if (isdigit(UCHAR(c))) { exponent = c - '0'; state = EXPONENT; break; } goto endgame; case EXPONENT: /* * Found an exponent with at least one digit. * Accumulate it, making sure to hard-pin it to LONG_MAX * on overflow. */ acceptState = state; acceptPoint = p; acceptLen = len; if (isdigit(UCHAR(c))) { if (exponent < (LONG_MAX - 9) / 10) { exponent = 10 * exponent + (c - '0'); } else { exponent = LONG_MAX; } state = EXPONENT; break; } goto endgame; /* * Parse out INFINITY by simply spelling it out. * INF is accepted as an abbreviation; other prefices are * not. */ case sI: if ( c == 'n' || c == 'N' ) { state = sIN; break; } goto endgame; case sIN: if ( c == 'f' || c == 'F' ) { state = sINF; break; } goto endgame; case sINF: acceptState = state; acceptPoint = p; acceptLen = len; if ( c == 'i' || c == 'I' ) { state = sINFI; break; } goto endgame; case sINFI: if ( c == 'n' || c == 'N' ) { state = sINFIN; break; } goto endgame; case sINFIN: if ( c == 'i' || c == 'I' ) { state = sINFINI; break; } goto endgame; case sINFINI: if ( c == 't' || c == 'T' ) { state = sINFINIT; break; } goto endgame; case sINFINIT: if ( c == 'y' || c == 'Y' ) { state = sINFINITY; break; } goto endgame; /* * Parse NaN's. */ #ifdef IEEE_FLOATING_POINT case sN: if ( c == 'a' || c == 'A' ) { state = sNA; break; } goto endgame; case sNA: if ( c == 'n' || c == 'N' ) { state = sNAN; break; } case sNAN: acceptState = state; acceptPoint = p; acceptLen = len; if ( c == '(' ) { state = sNANPAREN; break; } goto endgame; /* * Parse NaN(hexdigits) */ case sNANHEX: if ( c == ')' ) { state = sNANFINISH; break; } /* FALLTHROUGH */ case sNANPAREN: if ( isspace(UCHAR(c)) ) { break; } if ( numSigDigs < 13 ) { if ( c >= '0' && c <= '9' ) { d = c - '0'; } else if ( c >= 'a' && c <= 'f' ) { d = 10 + c - 'a'; } else if ( c >= 'A' && c <= 'F' ) { d = 10 + c - 'A'; } significandWide = (significandWide << 4) + d; state = sNANHEX; break; } goto endgame; case sNANFINISH: #endif case sINFINITY: acceptState = state; acceptPoint = p; acceptLen = len; goto endgame; } ++p; --len; } endgame: /* Back up to the last accepting state in the lexer */ if (acceptState == INITIAL) { status = TCL_ERROR; } p = acceptPoint; len = acceptLen; /* Skip past trailing whitespace */ if (endPtrPtr != NULL) { *endPtrPtr = p; } while (len > 0 && isspace(UCHAR(*p))) { ++p; --len; } /* Determine whether a partial string is acceptable. */ if (endPtrPtr == NULL && len != 0 && *p != '\0') { status = TCL_ERROR; } /* Generate and store the appropriate internal rep */ if (status == TCL_OK && objPtr != NULL) { if ( acceptState != INITIAL ) { TclFreeIntRep( objPtr ); } switch (acceptState) { case INITIAL: status = TCL_ERROR; break; case SIGNUM: case BAD_OCTAL: case ZERO_X: #ifdef TIP_114_FORMATS case ZERO_O: case ZERO_B: #endif case LEADING_RADIX_POINT: case EXPONENT_START: case EXPONENT_SIGNUM: case sI: case sIN: case sINFI: case sINFIN: case sINFINI: case sINFINIT: case sN: case sNA: case sNANPAREN: case sNANHEX: panic("in TclParseNumber: bad acceptState, can't happen."); #ifdef TIP_114_FORMATS case BINARY: shift = numTrailZeros; if (!significandOverflow) { if (significandWide !=0 && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (((~(Tcl_WideUInt)0) >> 1) + signum) >> shift )) { significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); } } if (shift) { if ( !significandOverflow ) { significandWide <<= shift; } else { mp_mul_2d( &significandBig, shift, &significandBig ); } } goto returnInteger; #endif case HEXADECIMAL: /* Returning a hex integer. Final scaling step */ shift = 4 * numTrailZeros; if (!significandOverflow) { if (significandWide !=0 && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (((~(Tcl_WideUInt)0) >> 1) + signum) >> shift )) { significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); } } if (shift) { if ( !significandOverflow ) { significandWide <<= shift; } else { mp_mul_2d( &significandBig, shift, &significandBig ); } } goto returnInteger; case OCTAL: /* Returning an octal integer. Final scaling step */ shift = 3 * numTrailZeros; if (!octalSignificandOverflow) { if (octalSignificandWide != 0 && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || octalSignificandWide > (((~(Tcl_WideUInt)0) >> 1) + signum) >> shift )) { octalSignificandOverflow = 1; TclBNInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); } } if ( shift ) { if ( !octalSignificandOverflow ) { octalSignificandWide <<= shift; } else { mp_mul_2d( &octalSignificandBig, shift, &octalSignificandBig ); } } if (!octalSignificandOverflow) { if (octalSignificandWide > (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { #ifndef NO_WIDE_TYPE if (octalSignificandWide <= (((~(Tcl_WideUInt)0) >> 1) + signum)) { objPtr->typePtr = &tclWideIntType; if (signum) { objPtr->internalRep.wideValue = - (Tcl_WideInt) octalSignificandWide; } else { objPtr->internalRep.wideValue = (Tcl_WideInt) octalSignificandWide; } break; } #endif TclBNInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); octalSignificandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.longValue = - (long) octalSignificandWide; } else { objPtr->internalRep.longValue = (long) octalSignificandWide; } } } if (octalSignificandOverflow) { if (signum) { mp_neg(&octalSignificandBig, &octalSignificandBig); } TclSetBignumIntRep(objPtr, &octalSignificandBig); } break; case ZERO: case DECIMAL: significandOverflow = AccumulateDecimalDigit( 0, numTrailZeros-1, &significandWide, &significandBig, significandOverflow ); if (!significandOverflow && (significandWide > (((~(Tcl_WideUInt)0) >> 1) + signum))) { significandOverflow = 1; TclBNInitBignumFromWideUInt(&significandBig, significandWide); } returnInteger: if (!significandOverflow) { if (significandWide > (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { #ifndef NO_WIDE_TYPE if (significandWide <= (((~(Tcl_WideUInt)0) >> 1) + signum)) { objPtr->typePtr = &tclWideIntType; if (signum) { objPtr->internalRep.wideValue = - (Tcl_WideInt) significandWide; } else { objPtr->internalRep.wideValue = (Tcl_WideInt) significandWide; } break; } #endif TclBNInitBignumFromWideUInt(&significandBig, significandWide); significandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.longValue = - (long) significandWide; } else { objPtr->internalRep.longValue = (long) significandWide; } } } if (significandOverflow) { if (signum) { mp_neg(&significandBig, &significandBig); } TclSetBignumIntRep(objPtr, &significandBig); } break; case FRACTION: case EXPONENT: /* * Here, we're parsing a floating-point number. * 'significandWide' or 'significandBig' contains the * exact significand, according to whether * 'significandOverflow' is set. The desired floating * point value is significand * 10**k, where * k = numTrailZeros+exponent-numDigitsAfterDp. */ objPtr->typePtr = &tclDoubleType; if ( exponentSignum ) { exponent = - exponent; } if ( !significandOverflow ) { objPtr->internalRep.doubleValue = MakeLowPrecisionDouble( signum, significandWide, numSigDigs, ( numTrailZeros + exponent - numDigitsAfterDp ) ); } else { objPtr->internalRep.doubleValue = MakeHighPrecisionDouble( signum, &significandBig, numSigDigs, ( numTrailZeros + exponent - numDigitsAfterDp ) ); } break; case sINF: case sINFINITY: if ( signum ) { objPtr->internalRep.doubleValue = -HUGE_VAL; } else { objPtr->internalRep.doubleValue = HUGE_VAL; } objPtr->typePtr = &tclDoubleType; break; case sNAN: case sNANFINISH: objPtr->internalRep.doubleValue = MakeNaN( signum, significandWide ); objPtr->typePtr = &tclDoubleType; break; } } /* Format an error message when an invalid number is encountered. */ if ( status != TCL_OK ) { if ( interp != NULL ) { Tcl_Obj *msg = Tcl_NewStringObj( "expected ", -1 ); Tcl_AppendToObj( msg, type, -1 ); Tcl_AppendToObj( msg, " but got \"", -1 ); TclAppendLimitedToObj( msg, string, length, 50, "" ); Tcl_AppendToObj( msg, "\"", -1 ); if ( state == BAD_OCTAL ) { Tcl_AppendToObj( msg, " (looks like invalid octal number)", -1 ); } Tcl_SetObjResult( interp, msg ); } } /* Free memory */ if (octalSignificandOverflow) { mp_clear(&octalSignificandBig); } if (significandOverflow) { mp_clear(&significandBig); } return status; } /* *---------------------------------------------------------------------- * * AccumulateDecimalDigit -- * * Consume a decimal digit in a number being scanned. * * Results: * Returns 1 if the number has overflowed to a bignum, 0 if it * still fits in a wide integer. * * Side effects: * Updates either the wide or bignum representation. * *---------------------------------------------------------------------- */ static int AccumulateDecimalDigit( unsigned digit, /* Digit being scanned */ int numZeros, /* Count of zero digits preceding the * digit being scanned */ Tcl_WideUInt* wideRepPtr, /* Representation of the partial number * as a wide integer */ mp_int* bignumRepPtr, /* Representation of the partial number * as a bignum */ int bignumFlag ) /* Flag == 1 if the number overflowed * previous to this digit. */ { int i, n; /* Check if the number still fits in a wide */ if (!bignumFlag) { if (*wideRepPtr != 0) { if ((numZeros >= maxpow10_wide) || (*wideRepPtr > (((~(Tcl_WideUInt)0) - digit) / pow10_wide[numZeros+1]))) { /* Oops, it's overflowed, have to allocate a bignum */ TclBNInitBignumFromWideUInt (bignumRepPtr, *wideRepPtr); bignumFlag = 1; } } } /* Multiply the number by 10**numZeros+1 and add in the new digit. */ if (!bignumFlag) { /* Wide multiplication */ *wideRepPtr = *wideRepPtr * pow10_wide[numZeros+1] + digit; } else if (numZeros < log10_DIGIT_MAX ) { /* Up to about 8 zeros - single digit multiplication */ mp_mul_d (bignumRepPtr, (mp_digit) pow10_wide[numZeros+1], bignumRepPtr); mp_add_d (bignumRepPtr, (mp_digit) digit, bignumRepPtr); } else { /* * More than single digit multiplication. Multiply by the appropriate * small powers of 5, and then shift. Large strings of zeroes are * eaten 256 at a time; this is less efficient than it could be, * but seems implausible. We presume that DIGIT_BIT is at least 27. * The first multiplication, by up to 10**7, is done with a * one-DIGIT multiply (this presumes that DIGIT_BIT >= 24). */ n = numZeros + 1; mp_mul_d (bignumRepPtr, (mp_digit) pow10_wide[n&0x7], bignumRepPtr); for (i = 3; i <= 7; ++i) { if (n & (1 << i)) { mp_mul (bignumRepPtr, pow5+i, bignumRepPtr); } } while (n >= 256) { mp_mul (bignumRepPtr, pow5+8, bignumRepPtr); n -= 256; } mp_mul_2d (bignumRepPtr, (int)(numZeros+1)&~0x7, bignumRepPtr); } return bignumFlag; } /* *---------------------------------------------------------------------- * * MakeLowPrecisionDouble -- * * Makes the double precision number, signum*significand*10**exponent. * * Results: * Returns the constructed number. * * Common cases, where there are few enough digits that the number can * be represented with at most roundoff, are handled specially here. * If the number requires more than one rounded operation to compute, * the code promotes the significand to a bignum and calls * MakeHighPrecisionDouble to do it instead. * *---------------------------------------------------------------------- */ static double MakeLowPrecisionDouble( int signum, /* 1 if the number is negative, 0 otherwise */ Tcl_WideUInt significand, /* Significand of the number */ int numSigDigs, /* Number of digits in the significand */ int exponent ) /* Power of ten */ { double retval; /* Value of the number */ mp_int significandBig; /* Significand expressed as a bignum */ /* * With gcc on x86, the floating point rounding mode is double-extended. * This causes the result of double-precision calculations to be rounded * twice: once to the precision of double-extended and then again to the * precision of double. Double-rounding introduces gratuitous errors of * 1 ulp, so we need to change rounding mode to 53-bits. */ #if defined(__GNUC__) && defined(__i386) fpu_control_t roundTo53Bits = 0x027f; fpu_control_t oldRoundingMode; _FPU_GETCW( oldRoundingMode ); _FPU_SETCW( roundTo53Bits ); #endif /* Test for the easy cases */ if ( numSigDigs <= DBL_DIG ) { if ( exponent >= 0 ) { if ( exponent <= mmaxpow ) { /* * The significand is an exact integer, and so is * 10**exponent. The product will be correct to within * 1/2 ulp without special handling. */ retval = (double)(Tcl_WideInt)significand * pow10[ exponent ]; goto returnValue; } else { int diff = DBL_DIG - numSigDigs; if ( exponent-diff <= mmaxpow ) { /* * 10**exponent is not an exact integer, but * 10**(exponent-diff) is exact, and so is * significand*10**diff, so we can still compute * the value with only one roundoff. */ volatile double factor = (double)(Tcl_WideInt)significand * pow10[diff]; retval = factor * pow10[exponent-diff]; goto returnValue; } } } else { if ( exponent >= -mmaxpow ) { /* * 10**-exponent is an exact integer, and so is the * significand. Compute the result by one division, * again with only one rounding. */ retval = (double)(Tcl_WideInt)significand / pow10[-exponent]; goto returnValue; } } } /* * All the easy cases have failed. Promote ths significand * to bignum and call MakeHighPrecisionDouble to do it the hard way. */ TclBNInitBignumFromWideUInt (&significandBig, significand); retval = MakeHighPrecisionDouble( 0, &significandBig, numSigDigs, exponent ); /* Come here to return the computed value */ returnValue: if ( signum ) { retval = -retval; } /* On gcc on x86, restore the floating point mode word. */ #if defined(__GNUC__) && defined(__i386) _FPU_SETCW( oldRoundingMode ); #endif return retval; } /* *---------------------------------------------------------------------- * * MakeHighPrecisionDouble -- * * Makes the double precision number, signum*significand*10**exponent. * * Results: * Returns the constructed number. * * MakeHighPrecisionDouble is used when arbitrary-precision arithmetic * is needed to ensure correct rounding. It begins by calculating a * low-precision approximation to the desired number, and then refines * the answer in high precision. * *---------------------------------------------------------------------- */ static double MakeHighPrecisionDouble( int signum, /* 1=negative, 0=nonnegative */ mp_int* significand, /* Exact significand of the number */ int numSigDigs, /* Number of significant digits */ int exponent ) /* Power of 10 by which to multiply */ { double retval; int machexp; /* Machine exponent of a power of 10 */ /* * With gcc on x86, the floating point rounding mode is double-extended. * This causes the result of double-precision calculations to be rounded * twice: once to the precision of double-extended and then again to the * precision of double. Double-rounding introduces gratuitous errors of * 1 ulp, so we need to change rounding mode to 53-bits. */ #if defined(__GNUC__) && defined(__i386) fpu_control_t roundTo53Bits = 0x027f; fpu_control_t oldRoundingMode; _FPU_GETCW( oldRoundingMode ); _FPU_SETCW( roundTo53Bits ); #endif /* Quick checks for over/underflow */ if ( numSigDigs + exponent - 1 > maxDigits ) { retval = HUGE_VAL; goto returnValue; } if ( numSigDigs + exponent - 1 < minDigits ) { retval = 0; goto returnValue; } /* * Develop a first approximation to the significand. It is tempting * simply to force bignum to double, but that will overflow on input * numbers like 1.[string repeat 0 1000]1; while this is a not terribly * likely scenario, we still have to deal with it. Use fraction and * exponent instead. Once we have the significand, multiply by * 10**exponent. Test for overflow. Convert back to a double, and * test for underflow. */ retval = BignumToBiasedFrExp( significand, &machexp ); retval = Pow10TimesFrExp( exponent, retval, &machexp ); if ( machexp > DBL_MAX_EXP * log2FLT_RADIX ) { retval = HUGE_VAL; goto returnValue; } retval = SafeLdExp( retval, machexp ); if ( retval < tiny ) { retval = tiny; } /* * Refine the result twice. (The second refinement should be * necessary only if the best approximation is a power of 2 * minus 1/2 ulp). */ retval = RefineApproximation( retval, significand, exponent ); retval = RefineApproximation( retval, significand, exponent ); /* Come here to return the computed value */ returnValue: if ( signum ) { retval = -retval; } /* On gcc on x86, restore the floating point mode word. */ #if defined(__GNUC__) && defined(__i386) _FPU_SETCW( oldRoundingMode ); #endif return retval; } /* *---------------------------------------------------------------------- * * MakeNaN -- * * Makes a "Not a Number" given a set of bits to put in the * tag bits * * Note that a signalling NaN is never returned. * *---------------------------------------------------------------------- */ #ifdef IEEE_FLOATING_POINT static double MakeNaN( int signum, /* Sign bit (1=negative, 0=nonnegative */ Tcl_WideUInt tags ) /* Tag bits to put in the NaN */ { union { Tcl_WideUInt iv; double dv; } theNaN; theNaN.iv = tags; theNaN.iv &= ( ((Tcl_WideUInt) 1) << 51 ) - 1; if ( signum ) { theNaN.iv |= ((Tcl_WideUInt) (0x8000 | NAN_START)) << 48; } else { theNaN.iv |= ((Tcl_WideUInt) NAN_START) << 48; } return theNaN.dv; } #endif /* *---------------------------------------------------------------------- * * RefineApproximation -- * * Given a poor approximation to a floating point number, returns * a better one (The better approximation is correct to within * 1 ulp, and is entirely correct if the poor approximation is * correct to 1 ulp.) * * Results: * Returns the improved result. * *---------------------------------------------------------------------- */ static double RefineApproximation( double approxResult, /* Approximate result of conversion */ mp_int* exactSignificand, /* Integer significand */ int exponent ) /* Power of 10 to multiply by significand */ { int M2, M5; /* Powers of 2 and of 5 needed to put * the decimal and binary numbers over * a common denominator. */ double significand; /* Sigificand of the binary number */ int binExponent; /* Exponent of the binary number */ int msb; /* Most significant bit position of an * intermediate result */ int nDigits; /* Number of mp_digit's in an intermediate * result */ mp_int twoMv; /* Approx binary value expressed as an * exact integer scaled by the multiplier 2M */ mp_int twoMd; /* Exact decimal value expressed as an * exact integer scaled by the multiplier 2M */ int scale; /* Scale factor for M */ int multiplier; /* Power of two to scale M */ double num, den; /* Numerator and denominator of the * correction term */ double quot; /* Correction term */ double minincr; /* Lower bound on the absolute value * of the correction term. */ int i; /* * The first approximation is always low. If we find that * it's HUGE_VAL, we're done. */ if ( approxResult == HUGE_VAL ) { return approxResult; } /* * Find a common denominator for the decimal and binary fractions. * The common denominator will be 2**M2 + 5**M5. */ significand = frexp( approxResult, &binExponent ); i = mantBits - binExponent; if ( i < 0 ) { M2 = 0; } else { M2 = i; } if ( exponent > 0 ) { M5 = 0; } else { M5 = -exponent; if ( (M5-1) > M2 ) { M2 = M5-1; } } /* * The floating point number is significand*2**binExponent. * Compute the large integer significand*2**(binExponent+M2+1) * The 2**-1 bit of the significand (the most significant) * corresponds to the 2**(binExponent+M2 + 1) bit of 2*M2*v. * Allocate enough digits to hold that quantity, then * convert the significand to a large integer, scaled * appropriately. Then multiply by the appropriate power of 5. */ msb = binExponent + M2; /* 1008 */ nDigits = msb / DIGIT_BIT + 1; mp_init_size( &twoMv, nDigits ); i = ( msb % DIGIT_BIT + 1 ); twoMv.used = nDigits; significand *= SafeLdExp( 1.0, i ); while ( -- nDigits >= 0 ) { twoMv.dp[nDigits] = (mp_digit) significand; significand -= (mp_digit) significand; significand = SafeLdExp( significand, DIGIT_BIT ); } for ( i = 0; i <= 8; ++i ) { if ( M5 & ( 1 << i ) ) { mp_mul( &twoMv, pow5+i, &twoMv ); } } /* * Collect the decimal significand as a high precision integer. * The least significant bit corresponds to bit M2+exponent+1 * so it will need to be shifted left by that many bits after * being multiplied by 5**(M5+exponent). */ mp_init_copy( &twoMd, exactSignificand ); for ( i = 0; i <= 8; ++i ) { if ( (M5+exponent) & ( 1 << i ) ) { mp_mul( &twoMd, pow5+i, &twoMd ); } } mp_mul_2d( &twoMd, M2+exponent+1, &twoMd ); mp_sub( &twoMd, &twoMv, &twoMd ); /* * The result, 2Mv-2Md, needs to be divided by 2M to yield a correction * term. Because 2M may well overflow a double, we need to scale the * denominator by a factor of 2**binExponent-mantBits */ scale = binExponent - mantBits - 1; mp_set( &twoMv, 1 ); for ( i = 0; i <= 8; ++i ) { if ( M5 & ( 1 << i ) ) { mp_mul( &twoMv, pow5+i, &twoMv ); } } multiplier = M2 + scale + 1; if ( multiplier > 0 ) { mp_mul_2d( &twoMv, multiplier, &twoMv ); } else if ( multiplier < 0 ) { mp_div_2d( &twoMv, -multiplier, &twoMv, NULL ); } /* * If the result is less than unity, the error is less than 1/2 unit * in the last place, so there's no correction to make. */ if ( mp_cmp_mag( &twoMd, &twoMv ) == MP_LT ) { return approxResult; } /* * Convert the numerator and denominator of the corrector term * accurately to floating point numbers. */ num = TclBignumToDouble( &twoMd ); den = TclBignumToDouble( &twoMv ); quot = SafeLdExp( num/den, scale ); minincr = SafeLdExp( 1.0, binExponent - mantBits ); if ( quot < 0. && quot > -minincr ) { quot = -minincr; } else if ( quot > 0. && quot < minincr ) { quot = minincr; } mp_clear( &twoMd ); mp_clear( &twoMv ); return approxResult + quot; } /* *---------------------------------------------------------------------- * * TclDoubleDigits -- * * Converts a double to a string of digits. * * Results: * Returns the position of the character in the string after which the * decimal point should appear. Since the string contains only * significant digits, the position may be less than zero or greater than * the length of the string. * * Side effects: * Stores the digits in the given buffer and sets 'signum' according to * the sign of the number. * *---------------------------------------------------------------------- */ int TclDoubleDigits( char * string, /* Buffer in which to store the result, * must have at least 18 chars */ double v, /* Number to convert. Must be * finite, and not NaN */ int *signum ) /* Output: 1 if the number is negative. * Should handle -0 correctly on the * IEEE architecture. */ { int e; /* Power of FLT_RADIX that satisfies * v = f * FLT_RADIX**e */ int lowOK, highOK; mp_int r; /* Scaled significand. */ mp_int s; /* Divisor such that v = r / s */ int smallestSig; /* Flag == 1 iff v's significand is * the smallest that can be represented. */ mp_int mplus; /* Scaled epsilon: (r + 2* mplus) == v(+) * where v(+) is the floating point successor * of v. */ mp_int mminus; /* Scaled epsilon: (r - 2*mminus) == v(-) * where v(-) is the floating point * predecessor of v. */ mp_int temp; int rfac2 = 0; /* Powers of 2 and 5 by which large */ int rfac5 = 0; /* integers should be scaled. */ int sfac2 = 0; int sfac5 = 0; int mplusfac2 = 0; int mminusfac2 = 0; char c; int i, k, n; /* Split the number into absolute value and signum. */ v = AbsoluteValue(v, signum); /* * Handle zero specially. */ if ( v == 0.0 ) { *string++ = '0'; *string++ = '\0'; return 1; } /* * Find a large integer r, and integer e, such that * v = r * FLT_RADIX**e * and r is as small as possible. Also determine whether the * significand is the smallest possible. */ smallestSig = GetIntegerTimesPower(v, &r, &e); lowOK = highOK = (mp_iseven(&r)); /* * We are going to want to develop integers r, s, mplus, and mminus such * that v = r / s, v(+)-v / 2 = mplus / s; v-v(-) / 2 = mminus / s and * then scale either s or r, mplus, mminus by an appropriate power of ten. * * We actually do this by keeping track of the powers of 2 and 5 by which * f is multiplied to yield v and by which 1 is multiplied to yield s, * mplus, and mminus. */ if (e >= 0) { int bits = e * log2FLT_RADIX; if (!smallestSig) { /* * Normal case, m+ and m- are both FLT_RADIX**e */ rfac2 = bits + 1; sfac2 = 1; mplusfac2 = bits; mminusfac2 = bits; } else { /* * If f is equal to the smallest significand, then we need another * factor of FLT_RADIX in s to cope with stepping to the next * smaller exponent when going to e's predecessor. */ rfac2 = bits + log2FLT_RADIX + 1; sfac2 = 1 + log2FLT_RADIX; mplusfac2 = bits + log2FLT_RADIX; mminusfac2 = bits; } } else { /* * v has digits after the binary point */ if (e <= DBL_MIN_EXP-DBL_MANT_DIG || !smallestSig) { /* * Either f isn't the smallest significand or e is the smallest * exponent. mplus and mminus will both be 1. */ rfac2 = 1; sfac2 = 1 - e * log2FLT_RADIX; mplusfac2 = 0; mminusfac2 = 0; } else { /* * f is the smallest significand, but e is not the smallest * exponent. We need to scale by FLT_RADIX again to cope with the * fact that v's predecessor has a smaller exponent. */ rfac2 = 1 + log2FLT_RADIX; sfac2 = 1 + log2FLT_RADIX * (1 - e); mplusfac2 = FLT_RADIX; mminusfac2 = 0; } } /* * Estimate the highest power of ten that will be needed to hold the * result. */ k = (int) ceil(log(v) / log(10.)); if (k >= 0) { sfac2 += k; sfac5 = k; } else { rfac2 -= k; mplusfac2 -= k; mminusfac2 -= k; rfac5 = -k; } /* * Scale r, s, mplus, mminus by the appropriate powers of 2 and 5. */ mp_init_set(&mplus, 1); for (i=0 ; i<=8 ; ++i) { if (rfac5 & (1 << i)) { mp_mul(&mplus, pow5+i, &mplus); } } mp_mul(&r, &mplus, &r); mp_mul_2d(&r, rfac2, &r); mp_init_copy(&mminus, &mplus); mp_mul_2d(&mplus, mplusfac2, &mplus); mp_mul_2d(&mminus, mminusfac2, &mminus); mp_init_set(&s, 1); for (i=0 ; i<=8 ; ++i) { if (sfac5 & (1 << i)) { mp_mul(&s, pow5+i, &s); } } mp_mul_2d(&s, sfac2, &s); /* * It is possible for k to be off by one because we used an inexact * logarithm. */ mp_init(&temp); mp_add(&r, &mplus, &temp); i = mp_cmp_mag(&temp, &s); if (i>0 || (highOK && i==0)) { mp_mul_d(&s, 10, &s); ++k; } else { mp_mul_d(&temp, 10, &temp); i = mp_cmp_mag(&temp, &s); if (i<0 || (highOK && i==0)) { mp_mul_d(&r, 10, &r); mp_mul_d(&mplus, 10, &mplus); mp_mul_d(&mminus, 10, &mminus); --k; } } /* * At this point, k contains the power of ten by which we're scaling the * result. r/s is at least 1/10 and strictly less than ten, and v = r/s * * 10**k. mplus and mminus give the rounding limits. */ for (;;) { int tc1, tc2; mp_mul_d(&r, 10, &r); mp_div(&r, &s, &temp, &r); /* temp = 10r / s; r = 10r mod s */ i = temp.dp[0]; mp_mul_d(&mplus, 10, &mplus); mp_mul_d(&mminus, 10, &mminus); tc1 = mp_cmp_mag(&r, &mminus); if (lowOK) { tc1 = (tc1 <= 0); } else { tc1 = (tc1 < 0); } mp_add(&r, &mplus, &temp); tc2 = mp_cmp_mag(&temp, &s); if (highOK) { tc2 = (tc2 >= 0); } else { tc2= (tc2 > 0); } if ( ! tc1 ) { if ( !tc2 ) { *string++ = '0' + i; } else { c = (char) (i + '1'); break; } } else { if (!tc2) { c = (char) (i + '0'); } else { mp_mul_2d(&r, 1, &r); n = mp_cmp_mag(&r, &s); if (n < 0) { c = (char) (i + '0'); } else { c = (char) (i + '1'); } } break; } }; *string++ = c; *string++ = '\0'; /* * Free memory, and return. */ mp_clear_multi(&r, &s, &mplus, &mminus, &temp, NULL); return k; } /* *---------------------------------------------------------------------- * * AbsoluteValue -- * * Splits a 'double' into its absolute value and sign. * * Results: * Returns the absolute value. * * Side effects: * Stores the signum in '*signum'. * *---------------------------------------------------------------------- */ static double AbsoluteValue (double v, /* Number to split */ int* signum) /* (Output) Sign of the number 1=-, 0=+ */ { /* * Take the absolute value of the number, and report the number's sign. * Take special steps to preserve signed zeroes in IEEE floating point. * (We can't use fpclassify, because that's a C9x feature and we still * have to build on C89 compilers.) */ #ifndef IEEE_FLOATING_POINT if (v >= 0.0) { *signum = 0; } else { *signum = 1; v = -v; } #else union { Tcl_WideUInt iv; double dv; } bitwhack; bitwhack.dv = v; if (bitwhack.iv & ((Tcl_WideUInt) 1 << 63)) { *signum = 1; bitwhack.iv &= ~((Tcl_WideUInt) 1 << 63); v = bitwhack.dv; } else { *signum = 0; } #endif return v; } /* *---------------------------------------------------------------------- * * GetIntegerTimesPower -- * * Converts a floating point number to an exact integer times a * power of the floating point radix. * * Results: * Returns 1 if it converted the smallest significand, 0 otherwise. * * Side effects: * Initializes the integer value (does not just assign it), * and stores the exponent. * *---------------------------------------------------------------------- */ static int GetIntegerTimesPower(double v, /* Value to convert */ mp_int* rPtr, /* (Output) Integer value */ int* ePtr) /* (Output) Power of FLT_RADIX by which * r must be multiplied to yield v*/ { double a; double f; int e; int i; int n; /* * Develop f and e such that v = f * FLT_RADIX**e, with * 1.0/FLT_RADIX <= f < 1. */ f = frexp(v, &e); #if FLT_RADIX > 2 n = e % log2FLT_RADIX; if (n > 0) { n -= log2FLT_RADIX; e += 1; f *= ldexp(1.0, n); } e = (e - n) / log2FLT_RADIX; #endif if (f == 1.0) { f = 1.0 / FLT_RADIX; e += 1; } /* * If the original number was denormalized, adjust e and f to be denormal * as well. */ if (e < DBL_MIN_EXP) { n = mantBits + (e - DBL_MIN_EXP)*log2FLT_RADIX; f = ldexp(f, (e - DBL_MIN_EXP)*log2FLT_RADIX); e = DBL_MIN_EXP; n = (n + DIGIT_BIT - 1) / DIGIT_BIT; } else { n = mantDIGIT; } /* * Now extract the base-2**DIGIT_BIT digits of f into a multi-precision * integer r. Preserve the invariant v = r * 2**rfac2 * FLT_RADIX**e by * adjusting e. */ a = f; n = mantDIGIT; mp_init_size(rPtr, n); rPtr->used = n; rPtr->sign = MP_ZPOS; i = (mantBits % DIGIT_BIT); if (i == 0) { i = DIGIT_BIT; } while (n > 0) { a *= ldexp(1.0, i); i = DIGIT_BIT; rPtr->dp[--n] = (mp_digit) a; a -= (mp_digit) a; } *ePtr = e - DBL_MANT_DIG; return (f == 1.0 / FLT_RADIX); } /* *---------------------------------------------------------------------- * * TclInitDoubleConversion -- * * Initializes constants that are needed for conversions to and from * 'double' * * Results: * None. * * Side effects: * The log base 2 of the floating point radix, the number of bits in a * double mantissa, and a table of the powers of five and ten are * computed and stored. * *---------------------------------------------------------------------- */ void TclInitDoubleConversion(void) { int i; int x; Tcl_WideUInt u; double d; /* * Initialize table of powers of 10 expressed as wide integers. */ maxpow10_wide = (int) floor(sizeof (Tcl_WideUInt) * CHAR_BIT * log (2.) / log (10.)); pow10_wide = (Tcl_WideUInt*) Tcl_Alloc ((maxpow10_wide + 1) * sizeof (Tcl_WideUInt)); u = 1; for (i = 0; i < maxpow10_wide; ++i) { pow10_wide[i] = u; u *= 10; } pow10_wide[i] = u; /* * Determine how many bits of precision a double has, and how many * decimal digits that represents. */ if ( frexp( (double) FLT_RADIX, &log2FLT_RADIX ) != 0.5 ) { Tcl_Panic( "This code doesn't work on a decimal machine!" ); } --log2FLT_RADIX; mantBits = DBL_MANT_DIG * log2FLT_RADIX; d = 1.0; /* * Initialize a table of powers of ten that can be exactly represented * in a double. */ x = (int) (DBL_MANT_DIG * log((double) FLT_RADIX) / log( 5.0 )); if ( x < MAXPOW ) { mmaxpow = x; } else { mmaxpow = MAXPOW; } for (i=0 ; i<=mmaxpow ; ++i) { pow10[i] = d; d *= 10.0; } /* Initialize a table of large powers of five. */ for ( i = 0; i < 9; ++i ) { mp_init( pow5 + i ); } mp_set( pow5, 5 ); for ( i = 0; i < 8; ++i ) { mp_sqr( pow5+i, pow5+i+1 ); } /* * Determine the number of decimal digits to the left and right of the * decimal point in the largest and smallest double, the smallest double * that differs from zero, and the number of mp_digits needed to represent * the significand of a double. */ tiny = SafeLdExp( 1.0, DBL_MIN_EXP * log2FLT_RADIX - mantBits ); maxDigits = (int) ((DBL_MAX_EXP * log((double) FLT_RADIX) + 0.5 * log(10.)) / log( 10. )); minDigits = (int) floor ( ( DBL_MIN_EXP - DBL_MANT_DIG ) * log( (double) FLT_RADIX ) / log( 10. ) ); mantDIGIT = ( mantBits + DIGIT_BIT - 1 ) / DIGIT_BIT; log10_DIGIT_MAX = (int) floor (DIGIT_BIT * log(2.) / log (10.)); } /* *---------------------------------------------------------------------- * * TclFinalizeDoubleConversion -- * * Cleans up this file on exit. * * Results: * None * * Side effects: * Memory allocated by TclInitDoubleConversion is freed. * *---------------------------------------------------------------------- */ void TclFinalizeDoubleConversion() { int i; Tcl_Free ((char*)pow10_wide); for ( i = 0; i < 9; ++i ) { mp_clear( pow5 + i ); } } /* *---------------------------------------------------------------------- * * TclInitBignumFromDouble -- * * Extracts the integer part of a double and converts it to * an arbitrary precision integer. * * Results: * None. * * Side effects: * Initializes the bignum supplied, and stores the converted number * in it. * *---------------------------------------------------------------------- */ int TclInitBignumFromDouble(Tcl_Interp *interp, /* For error message */ double d, /* Number to convert */ mp_int* b) /* Place to store the result */ { double fract; int expt; /* Infinite values can't convert to bignum */ if (TclIsInfinite(d)) { if (interp != NULL) { char *s = "integer value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; } fract = frexp(d,&expt); if (expt <= 0) { mp_init(b); mp_zero(b); } else { Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits); int shift = expt - mantBits; TclBNInitBignumFromWideInt(b, w); if (shift < 0) { mp_div_2d(b, -shift, b, NULL); } else if (shift > 0) { mp_mul_2d(b, shift, b); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclBignumToDouble -- * * Convert an arbitrary-precision integer to a native floating point * number. * * Results: * Returns the converted number. Sets errno to ERANGE if the number is * too large to convert. * *---------------------------------------------------------------------- */ double TclBignumToDouble(mp_int *a) /* Integer to convert. */ { mp_int b; int bits; int shift; int i; double r; /* * Determine how many bits we need, and extract that many from the input. * Round to nearest unit in the last place. */ bits = mp_count_bits(a); if (bits > DBL_MAX_EXP*log2FLT_RADIX) { errno = ERANGE; if (a->sign == MP_ZPOS) { return HUGE_VAL; } else { return -HUGE_VAL; } } shift = mantBits + 1 - bits; mp_init(&b); if (shift > 0) { mp_mul_2d(a, shift, &b); } else if (shift < 0) { mp_div_2d(a, -shift, &b, NULL); } else { mp_copy(a, &b); } mp_add_d(&b, 1, &b); mp_div_2d(&b, 1, &b, NULL); /* * Accumulate the result, one mp_digit at a time. */ r = 0.0; for (i=b.used-1 ; i>=0 ; --i) { r = ldexp(r, DIGIT_BIT) + b.dp[i]; } mp_clear(&b); /* * Scale the result to the correct number of bits. */ r = ldexp(r, bits - mantBits); /* * Return the result with the appropriate sign. */ if (a->sign == MP_ZPOS) { return r; } else { return -r; } } double TclCeil(mp_int *a) /* Integer to convert. */ { double r = 0.0; mp_int b; mp_init(&b); if (mp_cmp_d(a, 0) == MP_LT) { mp_neg(a, &b); r = -TclFloor(&b); } else { int bits = mp_count_bits(a); if (bits > DBL_MAX_EXP*log2FLT_RADIX) { r = HUGE_VAL; } else { int i, exact = 1, shift = mantBits - bits; if (shift > 0) { mp_mul_2d(a, shift, &b); } else if (shift < 0) { mp_int d; mp_init(&d); mp_div_2d(a, -shift, &b, &d); exact = mp_iszero(&d); mp_clear(&d); } else { mp_copy(a, &b); } if (!exact) { mp_add_d(&b, 1, &b); } for (i=b.used-1 ; i>=0 ; --i) { r = ldexp(r, DIGIT_BIT) + b.dp[i]; } r = ldexp(r, bits - mantBits); } } mp_clear(&b); return r; } double TclFloor(mp_int *a) /* Integer to convert. */ { double r = 0.0; mp_int b; mp_init(&b); if (mp_cmp_d(a, 0) == MP_LT) { mp_neg(a, &b); r = -TclCeil(&b); } else { int bits = mp_count_bits(a); if (bits > DBL_MAX_EXP*log2FLT_RADIX) { r = DBL_MAX; } else { int i, shift = mantBits - bits; if (shift > 0) { mp_mul_2d(a, shift, &b); } else if (shift < 0) { mp_div_2d(a, -shift, &b, NULL); } else { mp_copy(a, &b); } for (i=b.used-1 ; i>=0 ; --i) { r = ldexp(r, DIGIT_BIT) + b.dp[i]; } r = ldexp(r, bits - mantBits); } } mp_clear(&b); return r; } /* *---------------------------------------------------------------------- * * BignumToBiasedFrExp -- * * Convert an arbitrary-precision integer to a native floating * point number in the range [0.5,1) times a power of two. * NOTE: Intentionally converts to a number that's a few * ulp too small, so that RefineApproximation will not overflow * near the high end of the machine's arithmetic range. * * Results: * Returns the converted number. * * Side effects: * Stores the exponent of two in 'machexp'. * *---------------------------------------------------------------------- */ static double BignumToBiasedFrExp( mp_int* a, /* Integer to convert */ int* machexp ) /* Power of two */ { mp_int b; int bits; int shift; int i; double r; /* Determine how many bits we need, and extract that many from * the input. Round to nearest unit in the last place. */ bits = mp_count_bits( a ); shift = mantBits - 2 - bits; mp_init( &b ); if ( shift > 0 ) { mp_mul_2d( a, shift, &b ); } else if ( shift < 0 ) { mp_div_2d( a, -shift, &b, NULL ); } else { mp_copy( a, &b ); } /* Accumulate the result, one mp_digit at a time */ r = 0.0; for ( i = b.used-1; i >= 0; --i ) { r = ldexp( r, DIGIT_BIT ) + b.dp[i]; } mp_clear( &b ); /* Return the result with the appropriate sign. */ *machexp = bits - mantBits + 2; if ( a->sign == MP_ZPOS ) { return r; } else { return -r; } } /* *---------------------------------------------------------------------- * * Pow10TimesFrExp -- * * Multiply a power of ten by a number expressed as fraction and * exponent. * * Results: * Returns the significand of the result. * * Side effects: * Overwrites the 'machexp' parameter with the exponent of the * result. * * Assumes that 'exponent' is such that 10**exponent would be a double, * even though 'fraction*10**(machexp+exponent)' might overflow. * *---------------------------------------------------------------------- */ static double Pow10TimesFrExp( int exponent, /* Power of 10 to multiply by */ double fraction, /* Significand of multiplicand */ int* machexp ) /* On input, exponent of multiplicand. * On output, exponent of result. */ { int i, j; int expt = *machexp; double retval = fraction; if ( exponent > 0 ) { /* Multiply by 10**exponent */ retval = frexp( retval * pow10[ exponent & 0xf ], &j ); expt += j; for ( i = 4; i < 9; ++i ) { if ( exponent & (1<<i) ) { retval = frexp( retval * pow_10_2_n[ i ], &j ); expt += j; } } } else if ( exponent < 0 ) { /* Divide by 10**-exponent */ retval = frexp( retval / pow10[ (-exponent) & 0xf ], &j ); expt += j; for ( i = 4; i < 9; ++i ) { if ( (-exponent) & (1<<i) ) { retval = frexp( retval / pow_10_2_n[ i ], &j ); expt += j; } } } *machexp = expt; return retval; } /* *---------------------------------------------------------------------- * * SafeLdExp -- * * Do an 'ldexp' operation, but handle denormals gracefully. * * Results: * Returns the appropriately scaled value. * * On some platforms, 'ldexp' fails when presented with a number too * small to represent as a normalized double. This routine does 'ldexp' * in two steps for those numbers, to return correctly denormalized * values. * *---------------------------------------------------------------------- */ static double SafeLdExp(double fract, int expt) { int minexpt = DBL_MIN_EXP * log2FLT_RADIX; volatile double a, b, retval; if (expt < minexpt) { a = ldexp(fract, expt - mantBits - minexpt); b = ldexp(1.0, mantBits + minexpt); retval = a * b; } else { retval = ldexp(fract, expt); } return retval; } /* *---------------------------------------------------------------------- * * TclFormatNaN -- * * Makes the string representation of a "Not a Number" * * Results: * None. * * Side effects: * Stores the string representation in the supplied buffer, which must be * at least TCL_DOUBLE_SPACE characters. * *---------------------------------------------------------------------- */ void TclFormatNaN(double value, /* The Not-a-Number to format. */ char *buffer) /* String representation. */ { #ifndef IEEE_FLOATING_POINT strcpy(buffer, "NaN"); return; #else union { double dv; Tcl_WideUInt iv; } bitwhack; bitwhack.dv = value; if (bitwhack.iv & ((Tcl_WideUInt) 1 << 63)) { bitwhack.iv &= ~ ((Tcl_WideUInt) 1 << 63); *buffer++ = '-'; } *buffer++ = 'N'; *buffer++ = 'a'; *buffer++ = 'N'; bitwhack.iv &= (((Tcl_WideUInt) 1) << 51) - 1; if (bitwhack.iv != 0) { sprintf(buffer, "(%" TCL_LL_MODIFIER "x)", bitwhack.iv); } else { *buffer = '\0'; } #endif /* IEEE_FLOATING_POINT */ } |
Changes to generic/tclStringObj.c.
|
| | | | | | | | | | | | | | | | | | | | | > | | | | | < | > > > > > | | | | | | | | | | | | < > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | > < | | | | | | | | < < | | | < < | | | < | | | | | | | | | | < < | | | | | | < < | | | | | | | | | | | < | | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 | /* * tclStringObj.c -- * * This file contains functions that implement string operations on Tcl * objects. Some string operations work with UTF strings and others * require Unicode format. Functions that require knowledge of the width * of each character, such as indexing, operate on Unicode data. * * A Unicode string is an internationalized string. Conceptually, a * Unicode string is an array of 16-bit quantities organized as a * sequence of properly formed UTF-8 characters. There is a one-to-one * map between Unicode and UTF characters. Because Unicode characters * have a fixed width, operations such as indexing operate on Unicode * data. The String object is optimized for the case where each UTF char * in a string is only one byte. In this case, we store the value of * numChars, but we don't store the Unicode data (unless Tcl_GetUnicode * is explicitly called). * * The String object type stores one or both formats. The default * behavior is to store UTF. Once Unicode is calculated by a function, it * is stored in the internal rep for future access (without an additional * O(n) cost). * * To allow many appends to be done to an object without constantly * reallocating the space for the string or Unicode representation, we * allocate double the space for the string or Unicode and use the * internal representation to keep track of how much space is used vs. * allocated. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclStringObj.c,v 1.35.2.11 2005/09/30 17:02:03 dgp Exp $ */ #include "tclInt.h" #include "tommath.h" /* * Prototypes for functions defined later in this file: */ static void AppendUnicodeToUnicodeRep _ANSI_ARGS_(( Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int appendNumChars)); static void AppendUnicodeToUtfRep _ANSI_ARGS_(( Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int numChars)); static void AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr, CONST char *bytes, int numBytes)); static void AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr, CONST char *bytes, int numBytes)); static void FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int FormatObjVA _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, va_list argList)); static int ObjPrintfVA _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, va_list argList)); static void FreeStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static void DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); static int SetStringFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfString _ANSI_ARGS_((Tcl_Obj *objPtr)); /* * The structure below defines the string Tcl object type by means of * functions that can be invoked by generic object code. */ Tcl_ObjType tclStringType = { "string", /* name */ FreeStringInternalRep, /* freeIntRepPro */ DupStringInternalRep, /* dupIntRepProc */ UpdateStringOfString, /* updateStringProc */ SetStringFromAny /* setFromAnyProc */ }; /* * The following structure is the internal rep for a String object. It keeps * track of how much memory has been used and how much has been allocated for * the Unicode and UTF string to enable growing and shrinking of the UTF and * Unicode reps of the String object with fewer mallocs. To optimize string * length and indexing operations, this structure also stores the number of * characters (same of UTF and Unicode!) once that value has been computed. * * Under normal configurations, what Tcl calls "Unicode" is actually UTF-16 * restricted to the Basic Multilingual Plane (i.e. U+00000 to U+0FFFF). This * can be officially modified by altering the definition of Tcl_UniChar in * tcl.h, but do not do that unless you are sure what you're doing! */ typedef struct String { int numChars; /* The number of chars in the string. -1 means * this value has not been calculated. >= 0 * means that there is a valid Unicode rep, or * that the number of UTF bytes == the number * of chars. */ size_t allocated; /* The amount of space actually allocated for * the UTF string (minus 1 byte for the * termination char). */ size_t uallocated; /* The amount of space actually allocated for * the Unicode string (minus 2 bytes for the * termination char). */ int hasUnicode; /* Boolean determining whether the string has * a Unicode representation. */ Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual size * of this field depends on the 'uallocated' * field above. */ } String; #define STRING_UALLOC(numChars) \ (numChars * sizeof(Tcl_UniChar)) #define STRING_SIZE(ualloc) \ ((unsigned) (sizeof(String) - sizeof(Tcl_UniChar) + ualloc)) #define GET_STRING(objPtr) \ ((String *) (objPtr)->internalRep.otherValuePtr) #define SET_STRING(objPtr, stringPtr) \ ((objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr)) /* * TCL STRING GROWTH ALGORITHM * * When growing strings (during an append, for example), the following growth * algorithm is used: * * Attempt to allocate 2 * (originalLength + appendLength) * On failure: * attempt to allocate originalLength + 2*appendLength + * TCL_GROWTH_MIN_ALLOC * * This algorithm allows very good performance, as it rapidly increases the * memory allocated for a given string, which minimizes the number of * reallocations that must be performed. However, using only the doubling * algorithm can lead to a significant waste of memory. In particular, it may * fail even when there is sufficient memory available to complete the append * request (but there is not 2*totalLength memory available). So when the * doubling fails (because there is not enough memory available), the * algorithm requests a smaller amount of memory, which is still enough to * cover the request, but which hopefully will be less than the total * available memory. * * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling of very * small appends. Without this extra slush factor, a sequence of several small * appends would cause several memory allocations. As long as * TCL_GROWTH_MIN_ALLOC is a reasonable size, we can avoid that behavior. * * The growth algorithm can be tuned by adjusting the following parameters: * * TCL_GROWTH_MIN_ALLOC Additional space, in bytes, to allocate when * the double allocation has failed. Default is * 1024 (1 kilobyte). */ #ifndef TCL_GROWTH_MIN_ALLOC #define TCL_GROWTH_MIN_ALLOC 1024 #endif /* *---------------------------------------------------------------------- * * Tcl_NewStringObj -- * * This function is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new string object and * initializes it from the byte pointer and length arguments. * * When TCL_MEM_DEBUG is defined, this function just returns the result * of calling the debugging version Tcl_DbNewStringObj. * * Results: * A newly created string object is returned that has ref count zero. * * Side effects: * The new object's internal string representation will be set to a copy * of the length bytes starting at "bytes". If "length" is negative, use * bytes up to the first NULL byte; i.e., assume "bytes" points to a * C-style NULL-terminated string. The object's type is set to NULL. An * extra NULL is added to the end of the new object's byte array. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewStringObj Tcl_Obj * Tcl_NewStringObj(bytes, length) CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ int length; /* The number of bytes to copy from "bytes" * when initializing the new object. If * negative, use bytes up to the first NULL * byte. */ { return Tcl_DbNewStringObj(bytes, length, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewStringObj(bytes, length) CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ int length; /* The number of bytes to copy from "bytes" * when initializing the new object. If * negative, use bytes up to the first NULL * byte. */ { register Tcl_Obj *objPtr; if (length < 0) { length = (bytes? strlen(bytes) : 0); } TclNewStringObj(objPtr, bytes, length); return objPtr; } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_DbNewStringObj -- * * This function is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new string objects. It is the * same as the Tcl_NewStringObj function above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] * command will report the correct file name and line number when * reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this function just returns the * result of calling Tcl_NewStringObj. * * Results: * A newly created string object is returned that has ref count zero. * * Side effects: * The new object's internal string representation will be set to a copy * of the length bytes starting at "bytes". If "length" is negative, use * bytes up to the first NULL byte; i.e., assume "bytes" points to a * C-style NULL-terminated string. The object's type is set to NULL. An * extra NULL is added to the end of the new object's byte array. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewStringObj(bytes, length, file, line) CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ int length; /* The number of bytes to copy from "bytes" * when initializing the new object. If * negative, use bytes up to the first NULL * byte. */ CONST char *file; /* The name of the source file calling this * function; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ { register Tcl_Obj *objPtr; if (length < 0) { length = (bytes? strlen(bytes) : 0); } TclDbNewObj(objPtr, file, line); TclInitStringRep(objPtr, bytes, length); return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewStringObj(bytes, length, file, line) CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ register int length; /* The number of bytes to copy from "bytes" * when initializing the new object. If * negative, use bytes up to the first NULL * byte. */ CONST char *file; /* The name of the source file calling this * function; used for debugging. */ int line; /* Line number in the source file; used for * debugging. */ { return Tcl_NewStringObj(bytes, length); } #endif /* TCL_MEM_DEBUG */ /* *--------------------------------------------------------------------------- * * Tcl_NewUnicodeObj -- * * This function is creates a new String object and initializes it from * the given Unicode String. If the Utf String is the same size as the * Unicode string, don't duplicate the data. * * Results: * The newly created object is returned. This object will have no initial * string representation. The returned object has a ref count of 0. * * Side effects: * Memory allocated for new object and copy of Unicode argument. * *--------------------------------------------------------------------------- */ Tcl_Obj * Tcl_NewUnicodeObj(unicode, numChars) CONST Tcl_UniChar *unicode; /* The unicode string used to initialize the * new object. */ int numChars; /* Number of characters in the unicode * string. */ { Tcl_Obj *objPtr; String *stringPtr; size_t uallocated; if (numChars < 0) { numChars = 0; if (unicode) { while (unicode[numChars] != 0) { numChars++; } } } uallocated = STRING_UALLOC(numChars); /* * Create a new obj with an invalid string rep. */ |
︙ | ︙ | |||
353 354 355 356 357 358 359 | * * Get the length of the Unicode string from the Tcl object. * * Results: * Pointer to unicode string representing the unicode object. * * Side effects: | | | | > | | | | | | | > > | | > > > | < | | | < < | | | | | | | > | | < | | < | < | | | | | | | | > | | < | | | | | | | | | | | | | > | | | | | < | | | | | | | | | | | | | < | | < | | | | | | | | | | | | | | | < | | | 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 | * * Get the length of the Unicode string from the Tcl object. * * Results: * Pointer to unicode string representing the unicode object. * * Side effects: * Frees old internal rep. Allocates memory for new "String" internal * rep. * *---------------------------------------------------------------------- */ int Tcl_GetCharLength(objPtr) Tcl_Obj *objPtr; /* The String object to get the num chars * of. */ { String *stringPtr; SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); /* * If numChars is unknown, then calculate the number of characaters while * populating the Unicode string. */ if (stringPtr->numChars == -1) { register int i = objPtr->length; register unsigned char *str = (unsigned char *) objPtr->bytes; /* * This is a speed sensitive function, so run specially over the * string to count continuous ascii characters before resorting to the * Tcl_NumUtfChars call. This is a long form of: stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes,objPtr->length); * * TODO: Consider macro-izing this. */ while (i && (*str < 0xC0)) { i--; str++; } stringPtr->numChars = objPtr->length - i; if (i) { stringPtr->numChars += Tcl_NumUtfChars(objPtr->bytes + (objPtr->length - i), i); } if (stringPtr->numChars == objPtr->length) { /* * Since we've just calculated the number of chars, and all UTF * chars are 1-byte long, we don't need to store the unicode * string. */ stringPtr->hasUnicode = 0; } else { /* * Since we've just calucalated the number of chars, and not all * UTF chars are 1-byte long, go ahead and populate the unicode * string. */ FillUnicodeRep(objPtr); /* * We need to fetch the pointer again because we have just * reallocated the structure to make room for the Unicode data. */ stringPtr = GET_STRING(objPtr); } } return stringPtr->numChars; } /* *---------------------------------------------------------------------- * * Tcl_GetUniChar -- * * Get the index'th Unicode character from the String object. The index * is assumed to be in the appropriate range. * * Results: * Returns the index'th Unicode character in the Object. * * Side effects: * Fills unichar with the index'th Unicode character. * *---------------------------------------------------------------------- */ Tcl_UniChar Tcl_GetUniChar(objPtr, index) Tcl_Obj *objPtr; /* The object to get the Unicode charater * from. */ int index; /* Get the index'th Unicode character. */ { Tcl_UniChar unichar; String *stringPtr; SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); if (stringPtr->numChars == -1) { /* * We haven't yet calculated the length, so we don't have the Unicode * str. We need to know the number of chars before we can do indexing. */ Tcl_GetCharLength(objPtr); /* * We need to fetch the pointer again because we may have just * reallocated the structure. */ stringPtr = GET_STRING(objPtr); } if (stringPtr->hasUnicode == 0) { /* * All of the characters in the Utf string are 1 byte chars, so we * don't store the unicode char. We get the Utf string and convert the * index'th byte to a Unicode character. */ unichar = (Tcl_UniChar) objPtr->bytes[index]; } else { unichar = stringPtr->unicode[index]; } return unichar; } /* *---------------------------------------------------------------------- * * Tcl_GetUnicode -- * * Get the Unicode form of the String object. If the object is not * already a String object, it will be converted to one. If the String * object does not have a Unicode rep, then one is create from the UTF * string format. * * Results: * Returns a pointer to the object's internal Unicode string. * * Side effects: * Converts the object to have the String internal rep. * *---------------------------------------------------------------------- */ Tcl_UniChar * Tcl_GetUnicode(objPtr) Tcl_Obj *objPtr; /* The object to find the unicode string * for. */ { String *stringPtr; SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { /* * We haven't yet calculated the length, or all of the characters in * the Utf string are 1 byte chars (so we didn't store the unicode * str). Since this function must return a unicode string, and one has * not yet been stored, force the Unicode to be calculated and stored * now. */ FillUnicodeRep(objPtr); /* * We need to fetch the pointer again because we have just reallocated * the structure to make room for the Unicode data. */ stringPtr = GET_STRING(objPtr); } return stringPtr->unicode; } /* *---------------------------------------------------------------------- * * Tcl_GetUnicodeFromObj -- * * Get the Unicode form of the String object with length. If the object * is not already a String object, it will be converted to one. If the * String object does not have a Unicode rep, then one is create from the * UTF string format. * * Results: * Returns a pointer to the object's internal Unicode string. * * Side effects: * Converts the object to have the String internal rep. * *---------------------------------------------------------------------- */ Tcl_UniChar * Tcl_GetUnicodeFromObj(objPtr, lengthPtr) Tcl_Obj *objPtr; /* The object to find the unicode string * for. */ int *lengthPtr; /* If non-NULL, the location where the string * rep's unichar length should be stored. If * NULL, no length is stored. */ { String *stringPtr; SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { /* * We haven't yet calculated the length, or all of the characters in * the Utf string are 1 byte chars (so we didn't store the unicode * str). Since this function must return a unicode string, and one has * not yet been stored, force the Unicode to be calculated and stored * now. */ FillUnicodeRep(objPtr); /* * We need to fetch the pointer again because we have just reallocated * the structure to make room for the Unicode data. */ stringPtr = GET_STRING(objPtr); } if (lengthPtr != NULL) { *lengthPtr = stringPtr->numChars; } return stringPtr->unicode; } /* *---------------------------------------------------------------------- * * Tcl_GetRange -- * * Create a Tcl Object that contains the chars between first and last of * the object indicated by "objPtr". If the object is not already a * String object, convert it to one. The first and last indices are * assumed to be in the appropriate range. * * Results: * Returns a new Tcl Object of the String type. * * Side effects: * Changes the internal rep of "objPtr" to the String type. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_GetRange(objPtr, first, last) Tcl_Obj *objPtr; /* The Tcl object to find the range of. */ int first; /* First index of the range. */ int last; /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ String *stringPtr; SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); if (stringPtr->numChars == -1) { /* * We haven't yet calculated the length, so we don't have the Unicode * str. We need to know the number of chars before we can do indexing. */ Tcl_GetCharLength(objPtr); /* * We need to fetch the pointer again because we may have just * reallocated the structure. */ stringPtr = GET_STRING(objPtr); } if (stringPtr->numChars == objPtr->length) { char *str = Tcl_GetString(objPtr); /* * All of the characters in the Utf string are 1 byte chars, so we * don't store the unicode char. Create a new string object containing * the specified range of chars. */ newObjPtr = Tcl_NewStringObj(&str[first], last-first+1); /* * Since we know the new string only has 1-byte chars, we can set it's * numChars field. */ SetStringFromAny(NULL, newObjPtr); stringPtr = GET_STRING(newObjPtr); stringPtr->numChars = last-first+1; } else { newObjPtr = Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1); } return newObjPtr; } /* *---------------------------------------------------------------------- * * Tcl_SetStringObj -- * * Modify an object to hold a string that is a copy of the bytes * indicated by the byte pointer and length arguments. * * Results: * None. * * Side effects: * The object's string representation will be set to a copy of the * "length" bytes starting at "bytes". If "length" is negative, use bytes * up to the first NULL byte; i.e., assume "bytes" points to a C-style * NULL-terminated string. The object's old string and internal * representations are freed and the object's type is set NULL. * *---------------------------------------------------------------------- */ void Tcl_SetStringObj(objPtr, bytes, length) register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ CONST char *bytes; /* Points to the first of the length bytes * used to initialize the object. */ register int length; /* The number of bytes to copy from "bytes" * when initializing the object. If negative, * use bytes up to the first NULL byte.*/ { /* * Free any old string rep, then set the string rep to a copy of the * length bytes starting at "bytes". */ if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetStringObj called with shared object"); } /* |
︙ | ︙ | |||
723 724 725 726 727 728 729 | } /* *---------------------------------------------------------------------- * * Tcl_SetObjLength -- * | | | | | | | < | | | | | | > | > | | | | > > > | > > | | | > | > > | | > > | > > | | > | > > | > | | | | | | | | > > | > > | | | | | | | | | < | | | | | > | > | | | > | | | > > | > > | > | > > > > | > > > | > > > | > > | > > | 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 | } /* *---------------------------------------------------------------------- * * Tcl_SetObjLength -- * * This function changes the length of the string representation of an * object. * * Results: * None. * * Side effects: * If the size of objPtr's string representation is greater than length, * then it is reduced to length and a new terminating null byte is stored * in the strength. If the length of the string representation is greater * than length, the storage space is reallocated to the given length; a * null byte is stored at the end, but other bytes past the end of the * original string representation are undefined. The object's internal * representation is changed to "expendable string". * *---------------------------------------------------------------------- */ void Tcl_SetObjLength(objPtr, length) register Tcl_Obj *objPtr; /* Pointer to object. This object must not * currently be shared. */ register int length; /* Number of bytes desired for string * representation of object, not including * terminating null byte. */ { String *stringPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetObjLength called with shared object"); } SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); /* * Check that we're not extending a pure unicode string. */ if (length > (int) stringPtr->allocated && (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) { char *new; /* * Not enough space in current string. Reallocate the string space and * free the old string. */ if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) { new = (char *) ckrealloc((char *)objPtr->bytes, (unsigned)(length+1)); } else { new = (char *) ckalloc((unsigned) (length+1)); if (objPtr->bytes != NULL && objPtr->length != 0) { memcpy((VOID *) new, (VOID *) objPtr->bytes, (size_t) objPtr->length); Tcl_InvalidateStringRep(objPtr); } } objPtr->bytes = new; stringPtr->allocated = length; /* * Invalidate the unicode data. */ stringPtr->hasUnicode = 0; } if (objPtr->bytes != NULL) { objPtr->length = length; if (objPtr->bytes != tclEmptyStringRep) { /* * Ensure the string is NULL-terminated. */ objPtr->bytes[length] = 0; } /* * Invalidate the unicode data. */ stringPtr->numChars = -1; stringPtr->hasUnicode = 0; } else { /* * Changing length of pure unicode string. */ size_t uallocated = STRING_UALLOC(length); if (uallocated > stringPtr->uallocated) { stringPtr = (String *) ckrealloc((char*) stringPtr, STRING_SIZE(uallocated)); SET_STRING(objPtr, stringPtr); stringPtr->uallocated = uallocated; } stringPtr->numChars = length; stringPtr->hasUnicode = (length > 0); /* * Ensure the string is NULL-terminated. */ stringPtr->unicode[length] = 0; stringPtr->allocated = 0; objPtr->length = 0; } } /* *---------------------------------------------------------------------- * * Tcl_AttemptSetObjLength -- * * This function changes the length of the string representation of an * object. It uses the attempt* (non-panic'ing) memory allocators. * * Results: * 1 if the requested memory was allocated, 0 otherwise. * * Side effects: * If the size of objPtr's string representation is greater than length, * then it is reduced to length and a new terminating null byte is stored * in the strength. If the length of the string representation is greater * than length, the storage space is reallocated to the given length; a * null byte is stored at the end, but other bytes past the end of the * original string representation are undefined. The object's internal * representation is changed to "expendable string". * *---------------------------------------------------------------------- */ int Tcl_AttemptSetObjLength(objPtr, length) register Tcl_Obj *objPtr; /* Pointer to object. This object must not * currently be shared. */ register int length; /* Number of bytes desired for string * representation of object, not including * terminating null byte. */ { String *stringPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_AttemptSetObjLength called with shared object"); } SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); /* * Check that we're not extending a pure unicode string. */ if (length > (int) stringPtr->allocated && (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) { char *new; /* * Not enough space in current string. Reallocate the string space and * free the old string. */ if (objPtr->bytes != tclEmptyStringRep && objPtr->bytes != NULL) { new = (char *) attemptckrealloc((char *)objPtr->bytes, (unsigned)(length+1)); if (new == NULL) { return 0; } } else { new = (char *) attemptckalloc((unsigned) (length+1)); if (new == NULL) { return 0; } if (objPtr->bytes != NULL && objPtr->length != 0) { memcpy((VOID *) new, (VOID *) objPtr->bytes, (size_t) objPtr->length); Tcl_InvalidateStringRep(objPtr); } } objPtr->bytes = new; stringPtr->allocated = length; /* * Invalidate the unicode data. */ stringPtr->hasUnicode = 0; } if (objPtr->bytes != NULL) { objPtr->length = length; if (objPtr->bytes != tclEmptyStringRep) { /* * Ensure the string is NULL-terminated. */ objPtr->bytes[length] = 0; } /* * Invalidate the unicode data. */ stringPtr->numChars = -1; stringPtr->hasUnicode = 0; } else { /* * Changing length of pure unicode string. */ size_t uallocated = STRING_UALLOC(length); if (uallocated > stringPtr->uallocated) { stringPtr = (String *) attemptckrealloc((char*) stringPtr, STRING_SIZE(uallocated)); if (stringPtr == NULL) { return 0; } SET_STRING(objPtr, stringPtr); stringPtr->uallocated = uallocated; } stringPtr->numChars = length; stringPtr->hasUnicode = (length > 0); /* * Ensure the string is NULL-terminated. */ stringPtr->unicode[length] = 0; stringPtr->allocated = 0; objPtr->length = 0; } return 1; } |
︙ | ︙ | |||
937 938 939 940 941 942 943 | * *--------------------------------------------------------------------------- */ void Tcl_SetUnicodeObj(objPtr, unicode, numChars) Tcl_Obj *objPtr; /* The object to set the string of. */ | | | | > > | > | | | | | | | | | | | | 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 | * *--------------------------------------------------------------------------- */ void Tcl_SetUnicodeObj(objPtr, unicode, numChars) Tcl_Obj *objPtr; /* The object to set the string of. */ CONST Tcl_UniChar *unicode; /* The unicode string used to initialize the * object. */ int numChars; /* Number of characters in the unicode * string. */ { String *stringPtr; size_t uallocated; if (numChars < 0) { numChars = 0; if (unicode) { while (unicode[numChars] != 0) { numChars++; } } } uallocated = STRING_UALLOC(numChars); /* * Free the internal rep if one exists, and invalidate the string rep. */ TclFreeIntRep(objPtr); objPtr->typePtr = &tclStringType; /* * Allocate enough space for the String structure + Unicode string. */ stringPtr = (String *) ckalloc(STRING_SIZE(uallocated)); stringPtr->numChars = numChars; stringPtr->uallocated = uallocated; stringPtr->hasUnicode = (numChars > 0); stringPtr->allocated = 0; memcpy((VOID *) stringPtr->unicode, (VOID *) unicode, uallocated); stringPtr->unicode[numChars] = 0; SET_STRING(objPtr, stringPtr); Tcl_InvalidateStringRep(objPtr); return; } /* *---------------------------------------------------------------------- * * TclAppendLimitedToObj -- * * This function appends a limited number of bytes from a sequence of * bytes to an object, marking any limitation with an ellipsis. * * Results: * None. * * Side effects: * The bytes at *bytes are appended to the string representation of * objPtr. * *---------------------------------------------------------------------- */ void TclAppendLimitedToObj(objPtr, bytes, length, limit, ellipsis) register Tcl_Obj *objPtr; /* Points to the object to append to. */ CONST char *bytes; /* Points to the bytes to append to the * object. */ register int length; /* The number of bytes available to be * appended from "bytes". If < 0, then all * bytes up to a NULL byte are available. */ register int limit; /* The maximum number of bytes to append to * the object. */ CONST char *ellipsis; /* Ellipsis marker string, appended to the * object to indicate not all available bytes * at "bytes" were appended. */ { String *stringPtr; int toCopy = 0; if (Tcl_IsShared(objPtr)) { Tcl_Panic("TclAppendLimitedToObj called with shared object"); } |
︙ | ︙ | |||
1034 1035 1036 1037 1038 1039 1040 | if (ellipsis == NULL) { ellipsis = "..."; } toCopy = Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes; } /* | | | | < | | | | | | | | | | | | | | | | < | < < | | | | | | 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 | if (ellipsis == NULL) { ellipsis = "..."; } toCopy = Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes; } /* * If objPtr has a valid Unicode rep, then append the Unicode conversion * of "bytes" to the objPtr's Unicode rep, otherwise append "bytes" to * objPtr's string rep. */ stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode != 0) { AppendUtfToUnicodeRep(objPtr, bytes, toCopy); } else { AppendUtfToUtfRep(objPtr, bytes, toCopy); } if (length <= limit) { return; } stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode != 0) { AppendUtfToUnicodeRep(objPtr, ellipsis, -1); } else { AppendUtfToUtfRep(objPtr, ellipsis, -1); } } /* *---------------------------------------------------------------------- * * Tcl_AppendToObj -- * * This function appends a sequence of bytes to an object. * * Results: * None. * * Side effects: * The bytes at *bytes are appended to the string representation of * objPtr. * *---------------------------------------------------------------------- */ void Tcl_AppendToObj(objPtr, bytes, length) register Tcl_Obj *objPtr; /* Points to the object to append to. */ CONST char *bytes; /* Points to the bytes to append to the * object. */ register int length; /* The number of bytes to append from "bytes". * If < 0, then append all bytes up to NULL * byte. */ { TclAppendLimitedToObj(objPtr, bytes, length, INT_MAX, NULL); } /* *---------------------------------------------------------------------- * * Tcl_AppendUnicodeToObj -- * * This function appends a Unicode string to an object in the most * efficient manner possible. Length must be >= 0. * * Results: * None. * * Side effects: * Invalidates the string rep and creates a new Unicode string. * *---------------------------------------------------------------------- */ void Tcl_AppendUnicodeToObj(objPtr, unicode, length) register Tcl_Obj *objPtr; /* Points to the object to append to. */ CONST Tcl_UniChar *unicode; /* The unicode string to append to the * object. */ int length; /* Number of chars in "unicode". */ { String *stringPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_AppendUnicodeToObj called with shared object"); } if (length == 0) { return; } SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); /* * If objPtr has a valid Unicode rep, then append the "unicode" to the * objPtr's Unicode rep, otherwise the UTF conversion of "unicode" to * objPtr's string rep. */ if (stringPtr->hasUnicode != 0) { AppendUnicodeToUnicodeRep(objPtr, unicode, length); } else { AppendUnicodeToUtfRep(objPtr, unicode, length); } } /* *---------------------------------------------------------------------- * * Tcl_AppendObjToObj -- * * This function appends the string rep of one object to another. * "objPtr" cannot be a shared object. * * Results: * None. * * Side effects: * The string rep of appendObjPtr is appended to the string * representation of objPtr. * *---------------------------------------------------------------------- */ void Tcl_AppendObjToObj(objPtr, appendObjPtr) Tcl_Obj *objPtr; /* Points to the object to append to. */ Tcl_Obj *appendObjPtr; /* Object to append. */ { String *stringPtr; int length, numChars, allOneByteChars; char *bytes; SetStringFromAny(NULL, objPtr); /* * If objPtr has a valid Unicode rep, then get a Unicode string from * appendObjPtr and append it. */ stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode != 0) { /* * If appendObjPtr is not of the "String" type, don't convert it. */ if (appendObjPtr->typePtr == &tclStringType) { stringPtr = GET_STRING(appendObjPtr); if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { /* * If appendObjPtr is a string obj with no valid Unicode rep, * then fill its unicode rep. */ FillUnicodeRep(appendObjPtr); stringPtr = GET_STRING(appendObjPtr); } AppendUnicodeToUnicodeRep(objPtr, stringPtr->unicode, stringPtr->numChars); } else { bytes = Tcl_GetStringFromObj(appendObjPtr, &length); AppendUtfToUnicodeRep(objPtr, bytes, length); } return; } /* * Append to objPtr's UTF string rep. If we know the number of characters * in both objects before appending, then set the combined number of * characters in the final (appended-to) object. */ bytes = Tcl_GetStringFromObj(appendObjPtr, &length); allOneByteChars = 0; numChars = stringPtr->numChars; if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) { |
︙ | ︙ | |||
1232 1233 1234 1235 1236 1237 1238 | } /* *---------------------------------------------------------------------- * * AppendUnicodeToUnicodeRep -- * | | | | | | | > > | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * AppendUnicodeToUnicodeRep -- * * This function appends the contents of "unicode" to the Unicode rep of * "objPtr". objPtr must already have a valid Unicode rep. * * Results: * None. * * Side effects: * objPtr's internal rep is reallocated. * *---------------------------------------------------------------------- */ static void AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars) Tcl_Obj *objPtr; /* Points to the object to append to. */ CONST Tcl_UniChar *unicode; /* String to append. */ int appendNumChars; /* Number of chars of "unicode" to append. */ { String *stringPtr, *tmpString; size_t numChars; if (appendNumChars < 0) { appendNumChars = 0; if (unicode) { while (unicode[appendNumChars] != 0) { appendNumChars++; } } } if (appendNumChars == 0) { return; } SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); /* * If not enough space has been allocated for the unicode rep, reallocate * the internal rep object with additional space. First try to double the * required allocation; if that fails, try a more modest increase. See the * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an * explanation of this growth algorithm. */ numChars = stringPtr->numChars + appendNumChars; if (STRING_UALLOC(numChars) >= stringPtr->uallocated) { stringPtr->uallocated = STRING_UALLOC(2 * numChars); tmpString = (String *) attemptckrealloc((char *)stringPtr, STRING_SIZE(stringPtr->uallocated)); if (tmpString == NULL) { stringPtr->uallocated = STRING_UALLOC(numChars + appendNumChars) + TCL_GROWTH_MIN_ALLOC; tmpString = (String *) ckrealloc((char *)stringPtr, STRING_SIZE(stringPtr->uallocated)); } stringPtr = tmpString; SET_STRING(objPtr, stringPtr); } |
︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 | } /* *---------------------------------------------------------------------- * * AppendUnicodeToUtfRep -- * | | | | | | | | > > | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * AppendUnicodeToUtfRep -- * * This function converts the contents of "unicode" to UTF and appends * the UTF to the string rep of "objPtr". * * Results: * None. * * Side effects: * objPtr's internal rep is reallocated. * *---------------------------------------------------------------------- */ static void AppendUnicodeToUtfRep(objPtr, unicode, numChars) Tcl_Obj *objPtr; /* Points to the object to append to. */ CONST Tcl_UniChar *unicode; /* String to convert to UTF. */ int numChars; /* Number of chars of "unicode" to convert. */ { Tcl_DString dsPtr; CONST char *bytes; if (numChars < 0) { numChars = 0; if (unicode) { while (unicode[numChars] != 0) { numChars++; } } } if (numChars == 0) { return; } Tcl_DStringInit(&dsPtr); bytes = Tcl_UniCharToUtfDString(unicode, numChars, &dsPtr); AppendUtfToUtfRep(objPtr, bytes, Tcl_DStringLength(&dsPtr)); Tcl_DStringFree(&dsPtr); } /* *---------------------------------------------------------------------- * * AppendUtfToUnicodeRep -- * * This function converts the contents of "bytes" to Unicode and appends * the Unicode to the Unicode rep of "objPtr". objPtr must already have a * valid Unicode rep. * * Results: * None. * * Side effects: * objPtr's internal rep is reallocated. * *---------------------------------------------------------------------- */ static void AppendUtfToUnicodeRep(objPtr, bytes, numBytes) Tcl_Obj *objPtr; /* Points to the object to append to. */ CONST char *bytes; /* String to convert to Unicode. */ int numBytes; /* Number of bytes of "bytes" to convert. */ { Tcl_DString dsPtr; int numChars; Tcl_UniChar *unicode; if (numBytes < 0) { numBytes = (bytes ? strlen(bytes) : 0); } if (numBytes == 0) { return; } Tcl_DStringInit(&dsPtr); numChars = Tcl_NumUtfChars(bytes, numBytes); unicode = (Tcl_UniChar *)Tcl_UtfToUniCharDString(bytes, numBytes, &dsPtr); AppendUnicodeToUnicodeRep(objPtr, unicode, numChars); Tcl_DStringFree(&dsPtr); } /* *---------------------------------------------------------------------- * * AppendUtfToUtfRep -- * * This function appends "numBytes" bytes of "bytes" to the UTF string * rep of "objPtr". objPtr must already have a valid String rep. * * Results: * None. * * Side effects: * objPtr's internal rep is reallocated. * *---------------------------------------------------------------------- */ static void AppendUtfToUtfRep(objPtr, bytes, numBytes) Tcl_Obj *objPtr; /* Points to the object to append to. */ CONST char *bytes; /* String to append. */ int numBytes; /* Number of bytes of "bytes" to append. */ { String *stringPtr; int newLength, oldLength; if (numBytes < 0) { numBytes = (bytes ? strlen(bytes) : 0); } |
︙ | ︙ | |||
1431 1432 1433 1434 1435 1436 1437 | */ oldLength = objPtr->length; newLength = numBytes + oldLength; stringPtr = GET_STRING(objPtr); if (newLength > (int) stringPtr->allocated) { | < | | | | | | | | | | | 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 | */ oldLength = objPtr->length; newLength = numBytes + oldLength; stringPtr = GET_STRING(objPtr); if (newLength > (int) stringPtr->allocated) { /* * There isn't currently enough space in the string representation so * allocate additional space. First, try to double the length * required. If that fails, try a more modest allocation. See the "TCL * STRING GROWTH ALGORITHM" comment at the top of this file for an * explanation of this growth algorithm. */ if (Tcl_AttemptSetObjLength(objPtr, 2 * newLength) == 0) { Tcl_SetObjLength(objPtr, newLength + numBytes + TCL_GROWTH_MIN_ALLOC); } } /* * Invalidate the unicode data. */ stringPtr->numChars = -1; stringPtr->hasUnicode = 0; memcpy((VOID *) (objPtr->bytes + oldLength), (VOID *) bytes, (size_t) numBytes); objPtr->bytes[newLength] = 0; objPtr->length = newLength; } /* *---------------------------------------------------------------------- * * Tcl_AppendStringsToObjVA -- * * This function appends one or more null-terminated strings to an * object. * * Results: * None. * * Side effects: * The contents of all the string arguments are appended to the string * representation of objPtr. * *---------------------------------------------------------------------- */ void Tcl_AppendStringsToObjVA (objPtr, argList) Tcl_Obj *objPtr; /* Points to the object to append to. */ |
︙ | ︙ | |||
1498 1499 1500 1501 1502 1503 1504 | if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_AppendStringsToObj called with shared object"); } SetStringFromAny(NULL, objPtr); /* | | | | | | | | | > | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | < | | | | | | | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | < < | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_AppendStringsToObj called with shared object"); } SetStringFromAny(NULL, objPtr); /* * Figure out how much space is needed for all the strings, and expand the * string representation if it isn't big enough. If no bytes would be * appended, just return. Note that on some platforms (notably OS/390) the * argList is an array so we need to use memcpy. */ nargs = 0; newLength = 0; oldLength = objPtr->length; while (1) { string = va_arg(argList, char *); if (string == NULL) { break; } if (nargs >= nargs_space) { /* * Expand the args buffer. */ nargs_space += STATIC_LIST_SIZE; if (args == static_list) { args = (void *) ckalloc(nargs_space * sizeof(char *)); for (i = 0; i < nargs; ++i) { args[i] = static_list[i]; } } else { args = (void *) ckrealloc((void *) args, nargs_space * sizeof(char *)); } } newLength += strlen(string); args[nargs++] = string; } if (newLength == 0) { goto done; } stringPtr = GET_STRING(objPtr); if (oldLength + newLength > (int) stringPtr->allocated) { /* * There isn't currently enough space in the string representation, so * allocate additional space. If the current string representation * isn't empty (i.e. it looks like we're doing a series of appends) * then try to allocate extra space to accomodate future growth: first * try to double the required memory; if that fails, try a more modest * allocation. See the "TCL STRING GROWTH ALGORITHM" comment at the * top of this file for an explanation of this growth algorithm. * Otherwise, if the current string representation is empty, exactly * enough memory is allocated. */ if (oldLength == 0) { Tcl_SetObjLength(objPtr, newLength); } else { attemptLength = 2 * (oldLength + newLength); if (Tcl_AttemptSetObjLength(objPtr, attemptLength) == 0) { attemptLength = oldLength + (2 * newLength) + TCL_GROWTH_MIN_ALLOC; Tcl_SetObjLength(objPtr, attemptLength); } } } /* * Make a second pass through the arguments, appending all the strings to * the object. */ dst = objPtr->bytes + oldLength; for (i = 0; i < nargs; ++i) { string = args[i]; if (string == NULL) { break; } while (*string != 0) { *dst = *string; dst++; string++; } } /* * Add a null byte to terminate the string. However, be careful: it's * possible that the object is totally empty (if it was empty originally * and there was nothing to append). In this case dst is NULL; just leave * everything alone. */ if (dst != NULL) { *dst = 0; } objPtr->length = oldLength + newLength; done: /* * If we had to allocate a buffer from the heap, free it now. */ if (args != static_list) { ckfree((void *)args); } #undef STATIC_LIST_SIZE } /* *---------------------------------------------------------------------- * * Tcl_AppendStringsToObj -- * * This function appends one or more null-terminated strings to an * object. * * Results: * None. * * Side effects: * The contents of all the string arguments are appended to the string * representation of objPtr. * *---------------------------------------------------------------------- */ void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...) { va_list argList; va_start(argList, objPtr); Tcl_AppendStringsToObjVA(objPtr, argList); va_end(argList); } /* *---------------------------------------------------------------------- * * TclAppendFormattedObjs -- * * This function appends a list of Tcl_Obj's to a Tcl_Obj according * to the formatting instructions embedded in the format string. The * formatting instructions are inspired by sprintf(). Returns TCL_OK * when successful. If there's an error in the arguments, TCL_ERROR is * returned, and an error message is written to the interp, if non-NULL. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclAppendFormattedObjs(interp, appendObj, format, objc, objv) Tcl_Interp *interp; Tcl_Obj *appendObj; CONST char *format; int objc; Tcl_Obj *CONST objv[]; { CONST char *span = format; int numBytes = 0; int objIndex = 0; int gotXpg = 0, gotSequential = 0; int originalLength; CONST char *msg; CONST char *mixedXPG = "cannot mix \"%\" and \"%n$\" conversion specifiers"; CONST char *badIndex[2] = { "not enough arguments for all format specifiers", "\"%n$\" argument index out of range" }; if (Tcl_IsShared(appendObj)) { Tcl_Panic("TclAppendFormattedObjs called with shared object"); } Tcl_GetStringFromObj(appendObj, &originalLength); /* format string is NUL-terminated */ while (*format != '\0') { char *end; int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag; int width, gotPrecision, precision, useShort, useWide, useBig; int newXpg, numChars, allocSegment = 0; Tcl_Obj *segment; Tcl_UniChar ch; int step = Tcl_UtfToUniChar(format, &ch); format += step; if (ch != '%') { numBytes += step; continue; } if (numBytes) { Tcl_AppendToObj(appendObj, span, numBytes); numBytes = 0; } /* Saw a % : process the format specifier */ /* 0. %% : Escape format handling */ step = Tcl_UtfToUniChar(format, &ch); if (ch == '%') { span = format; numBytes = step; format += step; continue; } /* 1. XPG3 position specifier */ newXpg = 0; if (isdigit(UCHAR(ch))) { int position = strtoul(format, &end, 10); if (*end == '$') { newXpg = 1; objIndex = position - 1; format = end + 1; step = Tcl_UtfToUniChar(format, &ch); } } if (newXpg) { if (gotSequential) { msg = mixedXPG; goto errorMsg; } gotXpg = 1; } else { if (gotXpg) { msg = mixedXPG; goto errorMsg; } gotSequential = 1; } if ((objIndex < 0) || (objIndex >= objc)) { msg = badIndex[gotXpg]; goto errorMsg; } /* 2. Set of flags */ gotMinus = gotHash = gotZero = gotSpace = gotPlus = 0; sawFlag = 1; do { switch (ch) { case '-': gotMinus = 1; break; case '#': gotHash = 1; break; case '0': gotZero = 1; break; case ' ': gotSpace = 1; break; case '+': gotPlus = 1; break; default: sawFlag = 0; } if (sawFlag) { format += step; step = Tcl_UtfToUniChar(format, &ch); } } while (sawFlag); /* 3. Minimum field width */ width = 0; if (isdigit(UCHAR(ch))) { width = strtoul(format, &end, 10); format = end; step = Tcl_UtfToUniChar(format, &ch); } else if (ch == '*') { if (objIndex >= objc - 1) { msg = badIndex[gotXpg]; goto errorMsg; } if (Tcl_GetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) { goto error; } if (width < 0) { width = -width; gotMinus = 1; } objIndex++; format += step; step = Tcl_UtfToUniChar(format, &ch); } /* 4. Precision */ gotPrecision = precision = 0; if (ch == '.') { gotPrecision = 1; format += step; step = Tcl_UtfToUniChar(format, &ch); } if (isdigit(UCHAR(ch))) { precision = strtoul(format, &end, 10); format = end; step = Tcl_UtfToUniChar(format, &ch); } else if (ch == '*') { if (objIndex >= objc - 1) { msg = badIndex[gotXpg]; goto errorMsg; } if (Tcl_GetIntFromObj(interp, objv[objIndex], &precision) != TCL_OK) { goto error; } /* TODO: Check this truncation logic */ if (precision < 0) { precision = 0; } objIndex++; format += step; step = Tcl_UtfToUniChar(format, &ch); } /* 5. Length modifier */ useShort = useWide = useBig = 0; if (ch == 'h') { useShort = 1; format += step; step = Tcl_UtfToUniChar(format, &ch); } else if (ch == 'l') { format += step; step = Tcl_UtfToUniChar(format, &ch); if (ch == 'l') { useBig = 1; format += step; step = Tcl_UtfToUniChar(format, &ch); } else { #ifndef TCL_WIDE_INT_IS_LONG useWide = 1; #endif } } format += step; span = format; /* 6. Conversion character */ segment = objv[objIndex]; if (ch == 'i') { ch = 'd'; } switch (ch) { case '\0': msg = "format string ended in middle of field specifier"; goto errorMsg; case 's': { numChars = Tcl_GetCharLength(segment); if (gotPrecision && (precision < numChars)) { segment = Tcl_GetRange(segment, 0, precision - 1); Tcl_IncrRefCount(segment); allocSegment = 1; } break; } case 'c': { char buf[TCL_UTF_MAX]; int code, length; if (Tcl_GetIntFromObj(interp, segment, &code) != TCL_OK) { goto error; } length = Tcl_UniCharToUtf(code, buf); segment = Tcl_NewStringObj(buf, length); Tcl_IncrRefCount(segment); allocSegment = 1; break; } case 'u': if (useBig) { msg = "unsigned bignum format is invalid"; goto errorMsg; } case 'd': case 'o': case 'x': case 'X': { short int s; long l; Tcl_WideInt w; mp_int big; int isNegative = 0; if (useBig) { if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { goto error; } isNegative = (mp_cmp_d(&big, 0) == MP_LT); } else if (useWide) { if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { Tcl_Obj *objPtr; if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { goto error; } mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big); objPtr = Tcl_NewBignumObj(&big); Tcl_IncrRefCount(objPtr); Tcl_GetWideIntFromObj(NULL, objPtr, &w); Tcl_DecrRefCount(objPtr); } isNegative = (w < (Tcl_WideInt)0); } else if (Tcl_GetLongFromObj(NULL, segment, &l) != TCL_OK) { if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { Tcl_Obj *objPtr; if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { goto error; } mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); objPtr = Tcl_NewBignumObj(&big); Tcl_IncrRefCount(objPtr); Tcl_GetLongFromObj(NULL, objPtr, &l); Tcl_DecrRefCount(objPtr); } else { l = Tcl_WideAsLong(w); } if (useShort) { s = (short int) l; isNegative = (s < (short int)0); } else { isNegative = (l < (long)0); } } else { if (useShort) { s = (short int) l; isNegative = (s < (short int)0); } else { isNegative = (l < (long)0); } } segment = Tcl_NewObj(); allocSegment = 1; Tcl_IncrRefCount(segment); if (isNegative || gotPlus) { if (useBig || (ch == 'd')) { if (isNegative) { Tcl_AppendToObj(segment, "-", 1); } else { Tcl_AppendToObj(segment, "+", 1); } } } if (gotHash) { switch (ch) { case 'o': Tcl_AppendToObj(segment, "0", 1); precision--; break; case 'x': case 'X': Tcl_AppendToObj(segment, "0x", 2); break; } } switch (ch) { case 'd': { int length; Tcl_Obj *pure; CONST char *bytes; if (useShort) { pure = Tcl_NewIntObj((int)(s)); } else if (useWide) { pure = Tcl_NewWideIntObj(w); } else if (useBig) { pure = Tcl_NewBignumObj(&big); } else { pure = Tcl_NewLongObj(l); } Tcl_IncrRefCount(pure); bytes = Tcl_GetStringFromObj(pure, &length); /* Already did the sign above */ if (*bytes == '-') { length--; bytes++; } /* Canonical decimal string reps for integers are composed * entirely of one-byte encoded characters, so "length" is * the number of chars */ if (gotPrecision) { while (length < precision) { Tcl_AppendToObj(segment, "0", 1); length++; } gotZero = 0; } if (gotZero) { length += Tcl_GetCharLength(segment); while (length < width) { Tcl_AppendToObj(segment, "0", 1); length++; } } Tcl_AppendToObj(segment, bytes, -1); Tcl_DecrRefCount(pure); break; } case 'u': case 'o': case 'x': case 'X': { Tcl_WideUInt bits = (Tcl_WideUInt)0; int length, numBits = 4, numDigits = 0, base = 16; int index = 0, shift = 0; Tcl_Obj *pure; char *bytes; if (ch == 'u') { base = 10; } if (ch == 'o') { base = 8; numBits = 3; } if (useShort) { unsigned short int us = (unsigned short int) s; bits = (Tcl_WideUInt) us; while (us) { numDigits++; us /= base; } } else if (useWide) { Tcl_WideUInt uw = (Tcl_WideUInt) w; bits = uw; while (uw) { numDigits++; uw /= base; } } else if (useBig) { int leftover = (big.used * DIGIT_BIT) % numBits; mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover); numDigits = 1 + ((big.used * DIGIT_BIT) / numBits); while ((mask & big.dp[big.used-1]) == 0) { numDigits--; mask >>= numBits; } } else { unsigned long int ul = (unsigned long int) l; bits = (Tcl_WideUInt) ul; while (ul) { numDigits++; ul /= base; } } /* Need to be sure zero becomes "0", not "" */ if ((numDigits == 0) && !((ch == 'o') && gotHash)) { numDigits = 1; } pure = Tcl_NewObj(); Tcl_SetObjLength(pure, numDigits); bytes = Tcl_GetString(pure); length = numDigits; while (numDigits--) { int digitOffset; if (useBig) { if (shift<CHAR_BIT*sizeof(Tcl_WideUInt)-DIGIT_BIT) { bits |= (((Tcl_WideUInt)big.dp[index++]) << shift); shift += DIGIT_BIT; } shift -= numBits; } digitOffset = (int) (bits % base); if (digitOffset > 9) { bytes[numDigits] = 'a' + digitOffset - 10; } else { bytes[numDigits] = '0' + digitOffset; } bits /= base; } if (gotPrecision) { while (length < precision) { Tcl_AppendToObj(segment, "0", 1); length++; } gotZero = 0; } if (gotZero) { length += Tcl_GetCharLength(segment); while (length < width) { Tcl_AppendToObj(segment, "0", 1); length++; } } Tcl_AppendObjToObj(segment, pure); Tcl_DecrRefCount(pure); break; } } break; } case 'e': case 'E': case 'f': case 'g': case 'G': { #define MAX_FLOAT_SIZE 320 char spec[2*TCL_INTEGER_SPACE + 9], *p = spec; double d; int length = MAX_FLOAT_SIZE; char *bytes; if (Tcl_GetDoubleFromObj(interp, segment, &d) != TCL_OK) { goto error; } *p++ = '%'; if (gotMinus) { *p++ = '-'; } if (gotHash) { *p++ = '#'; } if (gotZero) { *p++ = '0'; } if (gotSpace) { *p++ = ' '; } if (gotPlus) { *p++ = '+'; } if (width) { p += sprintf(p, "%d", width); } if (gotPrecision) { *p++ = '.'; p += sprintf(p, "%d", precision); length += precision; } /* Don't pass length modifiers ! */ *p++ = (char) ch; *p = '\0'; segment = Tcl_NewObj(); allocSegment = 1; Tcl_SetObjLength(segment, length); bytes = Tcl_GetString(segment); Tcl_SetObjLength(segment, sprintf(bytes, spec, d)); break; } default: { char buf[40]; sprintf(buf, "bad field specifier \"%c\"", ch); msg = buf; goto errorMsg; } } switch (ch) { case 'E': case 'G': case 'X': { Tcl_SetObjLength(segment, Tcl_UtfToUpper(Tcl_GetString(segment))); } } numChars = Tcl_GetCharLength(segment); if (!gotMinus) { while (numChars < width) { Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1); numChars++; } } Tcl_AppendObjToObj(appendObj, segment); if (allocSegment) { Tcl_DecrRefCount(segment); } while (numChars < width) { Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1); numChars++; } objIndex += gotSequential; } if (numBytes) { Tcl_AppendToObj(appendObj, span, numBytes); numBytes = 0; } return TCL_OK; errorMsg: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); } error: Tcl_SetObjLength(appendObj, originalLength); return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * FormatObjVA -- * * Populate the Unicode internal rep with the Unicode form of its string * rep. The object must alread have a "String" internal rep. * * Results: * None. * * Side effects: * Reallocates the String internal rep. * *--------------------------------------------------------------------------- */ static int FormatObjVA(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, va_list argList) { int code, objc; Tcl_Obj **objv, *element, *list = Tcl_NewObj(); Tcl_IncrRefCount(list); element = va_arg(argList, Tcl_Obj *); while (element != NULL) { Tcl_ListObjAppendElement(NULL, list, element); element = va_arg(argList, Tcl_Obj *); } Tcl_ListObjGetElements(NULL, list, &objc, &objv); code = TclAppendFormattedObjs(interp, objPtr, format, objc, objv); Tcl_DecrRefCount(list); return code; } /* *--------------------------------------------------------------------------- * * TclFormatObj -- * * Results: * A standard Tcl result. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...) { va_list argList; int result; va_start(argList, format); result = FormatObjVA(interp, objPtr, format, argList); va_end(argList); return result; } /* *--------------------------------------------------------------------------- * * ObjPrintfVA -- * * Results: * * Side effects: * *--------------------------------------------------------------------------- */ static int ObjPrintfVA( Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, va_list argList) { int code, objc; Tcl_Obj **objv, *list = Tcl_NewObj(); CONST char *p; char *end; p = format; Tcl_IncrRefCount(list); while (*p != '\0') { int size = 0, seekingConversion = 1, gotPrecision = 0; int lastNum = -1, numBytes = -1; if (*p++ != '%') { continue; } if (*p == '%') { p++; continue; } do { switch (*p) { case '\0': seekingConversion = 0; break; case 's': { char *bytes = va_arg(argList, char *); seekingConversion = 0; if (gotPrecision) { char *end = bytes + lastNum; char *q = bytes; while ((q < end) && (*q != '\0')) { q++; } numBytes = (int)(q - bytes); } Tcl_ListObjAppendElement(NULL, list, Tcl_NewStringObj(bytes , numBytes)); /* We took no more than numBytes bytes from the (char *). * In turn, [format] will take no more than numBytes * characters from the Tcl_Obj. Since numBytes characters * must be no less than numBytes bytes, the character limit * will have no effect and we can just pass it through. */ break; } case 'c': case 'i': case 'u': case 'd': case 'o': case 'x': case 'X': seekingConversion = 0; switch (size) { case -1: case 0: Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( (long int)va_arg(argList, int))); break; case 1: Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( va_arg(argList, long int))); break; } break; case 'e': case 'E': case 'f': case 'g': case 'G': Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( va_arg(argList, double))); seekingConversion = 0; break; case '*': lastNum = (int)va_arg(argList, int); Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum)); p++; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': lastNum = (int) strtoul(p, &end, 10); p = end; break; case '.': gotPrecision = 1; p++; break; /* TODO: support for wide (and bignum?) arguments */ case 'l': size = 1; p++; break; case 'h': size = -1; default: p++; } } while (seekingConversion); } Tcl_ListObjGetElements(NULL, list, &objc, &objv); code = TclAppendFormattedObjs(interp, objPtr, format, objc, objv); Tcl_DecrRefCount(list); return code; } /* *--------------------------------------------------------------------------- * * TclObjPrintf -- * * Results: * A standard Tcl result. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...) { va_list argList; int result; va_start(argList, format); result = ObjPrintfVA(interp, objPtr, format, argList); va_end(argList); return result; } /* *---------------------------------------------------------------------- * * TclFormatToErrorInfo -- * * Results: * * Side effects: * *---------------------------------------------------------------------- */ int TclFormatToErrorInfo(Tcl_Interp *interp, CONST char *format, ...) { int code; va_list argList; Tcl_Obj *objPtr = Tcl_NewObj(); va_start(argList, format); code = ObjPrintfVA(interp, objPtr, format, argList); va_end(argList); if (code != TCL_OK) { return code; } TclAppendObjToErrorInfo(interp, objPtr); Tcl_DecrRefCount(objPtr); return TCL_OK; } /* *--------------------------------------------------------------------------- * * FillUnicodeRep -- * * Populate the Unicode internal rep with the Unicode form of its string * rep. The object must alread have a "String" internal rep. * * Results: * None. * * Side effects: * Reallocates the String internal rep. * *--------------------------------------------------------------------------- */ static void FillUnicodeRep(objPtr) Tcl_Obj *objPtr; /* The object in which to fill the unicode * rep. */ { String *stringPtr; size_t uallocated; char *src, *srcEnd; Tcl_UniChar *dst; src = objPtr->bytes; stringPtr = GET_STRING(objPtr); if (stringPtr->numChars == -1) { stringPtr->numChars = Tcl_NumUtfChars(src, objPtr->length); } stringPtr->hasUnicode = (stringPtr->numChars > 0); uallocated = STRING_UALLOC(stringPtr->numChars); if (uallocated > stringPtr->uallocated) { /* * If not enough space has been allocated for the unicode rep, * reallocate the internal rep object. * * There isn't currently enough space in the Unicode representation so * allocate additional space. If the current Unicode representation * isn't empty (i.e. it looks like we've done some appends) then * overallocate the space so that we won't have to do as much * reallocation in the future. */ if (stringPtr->uallocated > 0) { uallocated *= 2; } stringPtr = (String *) ckrealloc((char*) stringPtr, STRING_SIZE(uallocated)); stringPtr->uallocated = uallocated; } /* * Convert src to Unicode and store the coverted data in "unicode". */ srcEnd = src + objPtr->length; for (dst = stringPtr->unicode; src < srcEnd; dst++) { src += TclUtfToUniChar(src, dst); } *dst = 0; SET_STRING(objPtr, stringPtr); } /* *---------------------------------------------------------------------- * * DupStringInternalRep -- * * Initialize the internal representation of a new Tcl_Obj to a copy of * the internal representation of an existing string object. * * Results: * None. * * Side effects: * copyPtr's internal rep is set to a copy of srcPtr's internal * representation. * *---------------------------------------------------------------------- */ static void DupStringInternalRep(srcPtr, copyPtr) register Tcl_Obj *srcPtr; /* Object with internal rep to copy. Must have * an internal rep of type "String". */ register Tcl_Obj *copyPtr; /* Object with internal rep to set. Must not * currently have an internal rep.*/ { String *srcStringPtr = GET_STRING(srcPtr); String *copyStringPtr = NULL; /* * If the src obj is a string of 1-byte Utf chars, then copy the string * rep of the source object and create an "empty" Unicode internal rep for * the new object. Otherwise, copy Unicode internal rep, and invalidate * the string rep of the new object. */ if (srcStringPtr->hasUnicode == 0) { copyStringPtr = (String *) ckalloc(STRING_SIZE(STRING_UALLOC(0))); copyStringPtr->uallocated = STRING_UALLOC(0); } else { copyStringPtr = (String *) ckalloc( STRING_SIZE(srcStringPtr->uallocated)); copyStringPtr->uallocated = srcStringPtr->uallocated; memcpy((VOID *) copyStringPtr->unicode, (VOID *) srcStringPtr->unicode, (size_t) srcStringPtr->numChars * sizeof(Tcl_UniChar)); copyStringPtr->unicode[srcStringPtr->numChars] = 0; } copyStringPtr->numChars = srcStringPtr->numChars; copyStringPtr->hasUnicode = srcStringPtr->hasUnicode; copyStringPtr->allocated = srcStringPtr->allocated; /* * Tricky point: the string value was copied by generic object management * code, so it doesn't contain any extra bytes that might exist in the * source object. */ copyStringPtr->allocated = copyPtr->length; SET_STRING(copyPtr, copyStringPtr); copyPtr->typePtr = &tclStringType; } /* *---------------------------------------------------------------------- * * SetStringFromAny -- * * Create an internal representation of type "String" for an object. * * Results: * This operation always succeeds and returns TCL_OK. * * Side effects: * Any old internal reputation for objPtr is freed and the internal * representation is set to "String". * *---------------------------------------------------------------------- */ static int SetStringFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { /* * The Unicode object is optimized for the case where each UTF char in a * string is only one byte. In this case, we store the value of numChars, * but we don't copy the bytes to the unicodeObj->unicode. */ if (objPtr->typePtr != &tclStringType) { String *stringPtr; if (objPtr->typePtr != NULL) { if (objPtr->bytes == NULL) { |
︙ | ︙ | |||
1815 1816 1817 1818 1819 1820 1821 | stringPtr = (String *) ckalloc(STRING_SIZE(STRING_UALLOC(0))); stringPtr->numChars = -1; stringPtr->uallocated = STRING_UALLOC(0); stringPtr->hasUnicode = 0; if (objPtr->bytes != NULL) { | | | | | < < | | | | | | | | > > > > > > > > | 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 | stringPtr = (String *) ckalloc(STRING_SIZE(STRING_UALLOC(0))); stringPtr->numChars = -1; stringPtr->uallocated = STRING_UALLOC(0); stringPtr->hasUnicode = 0; if (objPtr->bytes != NULL) { stringPtr->allocated = objPtr->length; objPtr->bytes[objPtr->length] = 0; } else { objPtr->length = 0; } SET_STRING(objPtr, stringPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * UpdateStringOfString -- * * Update the string representation for an object whose internal * representation is "String". * * Results: * None. * * Side effects: * The object's string may be set by converting its Unicode represention * to UTF format. * *---------------------------------------------------------------------- */ static void UpdateStringOfString(objPtr) Tcl_Obj *objPtr; /* Object with string rep to update. */ { int i, size; Tcl_UniChar *unicode; char dummy[TCL_UTF_MAX]; char *dst; String *stringPtr; stringPtr = GET_STRING(objPtr); if ((objPtr->bytes == NULL) || (stringPtr->allocated == 0)) { if (stringPtr->numChars <= 0) { /* * If there is no Unicode rep, or the string has 0 chars, then set * the string rep to an empty string. */ objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; return; } unicode = stringPtr->unicode; /* * Translate the Unicode string to UTF. "size" will hold the amount of * space the UTF string needs. */ size = 0; for (i = 0; i < stringPtr->numChars; i++) { size += Tcl_UniCharToUtf((int) unicode[i], dummy); } dst = (char *) ckalloc((unsigned) (size + 1)); objPtr->bytes = dst; objPtr->length = size; stringPtr->allocated = size; for (i = 0; i < stringPtr->numChars; i++) { dst += Tcl_UniCharToUtf(unicode[i], dst); } *dst = '\0'; } return; } /* *---------------------------------------------------------------------- * * FreeStringInternalRep -- * * Deallocate the storage associated with a String data object's internal * representation. * * Results: * None. * * Side effects: * Frees memory. * *---------------------------------------------------------------------- */ static void FreeStringInternalRep(objPtr) Tcl_Obj *objPtr; /* Object with internal rep to free. */ { ckfree((char *) GET_STRING(objPtr)); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
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.109.2.17 2005/09/20 14:11:52 dgp Exp $ */ #include "tclInt.h" /* * Remove macros that will interfere with the definitions below. */ |
︙ | ︙ | |||
99 100 101 102 103 104 105 | NULL, /* 17 */ NULL, /* 18 */ NULL, /* 19 */ NULL, /* 20 */ NULL, /* 21 */ TclFindElement, /* 22 */ TclFindProc, /* 23 */ | | | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 | NULL, /* 17 */ NULL, /* 18 */ NULL, /* 19 */ NULL, /* 20 */ NULL, /* 21 */ TclFindElement, /* 22 */ TclFindProc, /* 23 */ NULL, /* 24 */ TclFreePackageInfo, /* 25 */ NULL, /* 26 */ NULL, /* 27 */ TclpGetDefaultStdChannel, /* 28 */ NULL, /* 29 */ NULL, /* 30 */ TclGetExtension, /* 31 */ |
︙ | ︙ | |||
124 125 126 127 128 129 130 | TclpGetUserHome, /* 42 */ NULL, /* 43 */ TclGuessPackageName, /* 44 */ TclHideUnsafeCommands, /* 45 */ TclInExit, /* 46 */ NULL, /* 47 */ NULL, /* 48 */ | | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | TclpGetUserHome, /* 42 */ NULL, /* 43 */ TclGuessPackageName, /* 44 */ TclHideUnsafeCommands, /* 45 */ TclInExit, /* 46 */ NULL, /* 47 */ NULL, /* 48 */ NULL, /* 49 */ TclInitCompiledLocals, /* 50 */ TclInterpInit, /* 51 */ NULL, /* 52 */ TclInvokeObjectCommand, /* 53 */ TclInvokeStringCommand, /* 54 */ TclIsProc, /* 55 */ NULL, /* 56 */ |
︙ | ︙ | |||
220 221 222 223 224 225 226 | TclpGetDate, /* 133 */ NULL, /* 134 */ NULL, /* 135 */ NULL, /* 136 */ NULL, /* 137 */ TclGetEnv, /* 138 */ NULL, /* 139 */ | | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 | TclpGetDate, /* 133 */ NULL, /* 134 */ NULL, /* 135 */ NULL, /* 136 */ NULL, /* 137 */ TclGetEnv, /* 138 */ NULL, /* 139 */ NULL, /* 140 */ TclpGetCwd, /* 141 */ TclSetByteCodeFromAny, /* 142 */ TclAddLiteralObj, /* 143 */ TclHideLiteral, /* 144 */ TclGetAuxDataType, /* 145 */ TclHandleCreate, /* 146 */ TclHandleFree, /* 147 */ |
︙ | ︙ | |||
254 255 256 257 258 259 260 | TclSetStartupScriptPath, /* 167 */ TclGetStartupScriptPath, /* 168 */ TclpUtfNcmp2, /* 169 */ TclCheckInterpTraces, /* 170 */ TclCheckExecutionTraces, /* 171 */ TclInThreadExit, /* 172 */ TclUniCharMatch, /* 173 */ | | | | | | | | | | | | | | | | | | > > > > > > > > > > > | 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 | TclSetStartupScriptPath, /* 167 */ TclGetStartupScriptPath, /* 168 */ TclpUtfNcmp2, /* 169 */ TclCheckInterpTraces, /* 170 */ TclCheckExecutionTraces, /* 171 */ TclInThreadExit, /* 172 */ TclUniCharMatch, /* 173 */ NULL, /* 174 */ TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ Tcl_SetStartupScript, /* 178 */ Tcl_GetStartupScript, /* 179 */ NULL, /* 180 */ NULL, /* 181 */ TclpLocaltime, /* 182 */ TclpGmtime, /* 183 */ NULL, /* 184 */ NULL, /* 185 */ NULL, /* 186 */ NULL, /* 187 */ NULL, /* 188 */ NULL, /* 189 */ NULL, /* 190 */ NULL, /* 191 */ NULL, /* 192 */ NULL, /* 193 */ NULL, /* 194 */ NULL, /* 195 */ NULL, /* 196 */ TclCompEvalObj, /* 197 */ TclObjGetFrame, /* 198 */ NULL, /* 199 */ TclpObjRemoveDirectory, /* 200 */ TclpObjCopyDirectory, /* 201 */ TclpObjCreateDirectory, /* 202 */ TclpObjDeleteFile, /* 203 */ TclpObjCopyFile, /* 204 */ TclpObjRenameFile, /* 205 */ TclpObjStat, /* 206 */ TclpObjAccess, /* 207 */ TclpOpenFileChannel, /* 208 */ TclGetEncodingSearchPath, /* 209 */ TclSetEncodingSearchPath, /* 210 */ TclpGetEncodingNameFromEnvironment, /* 211 */ TclpFindExecutable, /* 212 */ TclGetObjNameOfExecutable, /* 213 */ TclSetObjNameOfExecutable, /* 214 */ TclStackAlloc, /* 215 */ TclStackFree, /* 216 */ TclPushStackFrame, /* 217 */ TclPopStackFrame, /* 218 */ TclBN_mp_div_d, /* 219 */ TclBN_mp_mul_d, /* 220 */ TclBN_mp_clear, /* 221 */ TclBN_mp_init, /* 222 */ TclBN_mp_read_radix, /* 223 */ TclGetPlatform, /* 224 */ TclTraceDictPath, /* 225 */ }; TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, NULL, #if !defined(__WIN32__) /* UNIX */ TclGetAndDetachPids, /* 0 */ |
︙ | ︙ | |||
343 344 345 346 347 348 349 | TclpMakeFile, /* 18 */ TclpOpenFile, /* 19 */ TclWinAddProcess, /* 20 */ NULL, /* 21 */ TclpCreateTempFile, /* 22 */ TclpGetTZName, /* 23 */ TclWinNoBackslash, /* 24 */ | | | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 | TclpMakeFile, /* 18 */ TclpOpenFile, /* 19 */ TclWinAddProcess, /* 20 */ NULL, /* 21 */ TclpCreateTempFile, /* 22 */ TclpGetTZName, /* 23 */ TclWinNoBackslash, /* 24 */ NULL, /* 25 */ TclWinSetInterfaces, /* 26 */ TclWinFlushDirtyChannels, /* 27 */ TclWinResetInterfaces, /* 28 */ TclWinCPUID, /* 29 */ #endif /* __WIN32__ */ #ifdef MAC_OSX_TCL TclMacOSXGetFileAttribute, /* 15 */ |
︙ | ︙ | |||
948 949 950 951 952 953 954 955 956 957 | Tcl_LimitGetTime, /* 533 */ Tcl_LimitGetGranularity, /* 534 */ Tcl_SaveInterpState, /* 535 */ Tcl_RestoreInterpState, /* 536 */ Tcl_DiscardInterpState, /* 537 */ Tcl_SetReturnOptions, /* 538 */ Tcl_GetReturnOptions, /* 539 */ }; /* !END!: Do not edit above this line. */ | > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Tcl_LimitGetTime, /* 533 */ Tcl_LimitGetGranularity, /* 534 */ Tcl_SaveInterpState, /* 535 */ Tcl_RestoreInterpState, /* 536 */ Tcl_DiscardInterpState, /* 537 */ Tcl_SetReturnOptions, /* 538 */ Tcl_GetReturnOptions, /* 539 */ Tcl_IsEnsemble, /* 540 */ Tcl_CreateEnsemble, /* 541 */ Tcl_FindEnsemble, /* 542 */ Tcl_SetEnsembleSubcommandList, /* 543 */ Tcl_SetEnsembleMappingDict, /* 544 */ Tcl_SetEnsembleUnknownHandler, /* 545 */ Tcl_SetEnsembleFlags, /* 546 */ Tcl_GetEnsembleSubcommandList, /* 547 */ Tcl_GetEnsembleMappingDict, /* 548 */ Tcl_GetEnsembleUnknownHandler, /* 549 */ Tcl_GetEnsembleFlags, /* 550 */ Tcl_GetEnsembleNamespace, /* 551 */ Tcl_SetTimeProc, /* 552 */ Tcl_QueryTimeProc, /* 553 */ Tcl_ChannelThreadActionProc, /* 554 */ Tcl_NewBignumObj, /* 555 */ Tcl_DbNewBignumObj, /* 556 */ Tcl_SetBignumObj, /* 557 */ Tcl_GetBignumFromObj, /* 558 */ Tcl_GetBignumAndClearObj, /* 559 */ Tcl_TruncateChannel, /* 560 */ Tcl_ChannelTruncateProc, /* 561 */ Tcl_SetChannelErrorInterp, /* 562 */ Tcl_GetChannelErrorInterp, /* 563 */ Tcl_SetChannelError, /* 564 */ Tcl_GetChannelError, /* 565 */ }; /* !END!: Do not edit above this line. */ |
Changes to generic/tclTest.c.
︙ | ︙ | |||
10 11 12 13 14 15 16 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Ajuba Solutions. * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Ajuba Solutions. * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclTest.c,v 1.86.2.7 2005/09/09 18:48:40 dgp Exp $ */ #define TCL_TEST #include "tclInt.h" /* * Required for Testregexp*Cmd |
︙ | ︙ | |||
116 117 118 119 120 121 122 123 124 125 126 127 128 129 | */ typedef struct TestEvent { Tcl_Event header; /* Header common to all events */ Tcl_Interp* interp; /* Interpreter that will handle the event */ Tcl_Obj* command; /* Command to evaluate when the event occurs */ Tcl_Obj* tag; /* Tag for this event used to delete it */ } TestEvent; /* * Forward declarations for procedures defined later in this file: */ int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData, | > > > > > > > > > > > > > > | 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 | */ typedef struct TestEvent { Tcl_Event header; /* Header common to all events */ Tcl_Interp* interp; /* Interpreter that will handle the event */ Tcl_Obj* command; /* Command to evaluate when the event occurs */ Tcl_Obj* tag; /* Tag for this event used to delete it */ } TestEvent; /* * Simple detach/attach facility for testchannel cut|splice. * Allow testing of channel transfer in core testsuite. */ typedef struct TestChannel { Tcl_Channel chan; /* Detached channel */ struct TestChannel* nextPtr; /* Next in pool of detached channels */ } TestChannel; static TestChannel* firstDetached; /* * Forward declarations for procedures defined later in this file: */ int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData, |
︙ | ︙ | |||
240 241 242 243 244 245 246 247 248 249 250 251 252 253 | static int TesteventDeleteProc _ANSI_ARGS_(( Tcl_Event* event, ClientData clientData)); 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[])); | > > > > > > > > | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 | static int TesteventDeleteProc _ANSI_ARGS_(( Tcl_Event* event, ClientData clientData)); 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 TestexprlongobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestexprdoubleCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestexprdoubleobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); 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[])); |
︙ | ︙ | |||
304 305 306 307 308 309 310 311 312 313 314 315 316 317 | 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)); | > > > | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 | 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 int TestreturnObjCmd _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)); |
︙ | ︙ | |||
619 620 621 622 623 624 625 626 627 628 629 630 631 632 | (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand( interp, "testevent", TesteventObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc*) NULL ); Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd, (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, | > > > > > > | 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 | (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand( interp, "testevent", TesteventObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc*) NULL ); Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testexprlongobj", TestexprlongobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testexprdouble", TestexprdoubleCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testexprdoubleobj", TestexprdoubleobjCmd, (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, |
︙ | ︙ | |||
659 660 661 662 663 664 665 666 667 668 669 670 671 672 | Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); | > > | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 | Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); |
︙ | ︙ | |||
2273 2274 2275 2276 2277 2278 2279 | 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; | | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 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; if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], " expression\"", (char *) NULL); return TCL_ERROR; } Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprLong(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; } sprintf(buf, ": %ld", exprResult); Tcl_AppendResult(interp, buf, NULL); return TCL_OK; } /* *---------------------------------------------------------------------- * * TestexprlongobjCmd -- * * This procedure verifies that Tcl_ExprLongObj does not modify the * interpreter result if there is no error. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TestexprlongobjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST *objv; /* Argument objects. */ { long exprResult; char buf[4 + TCL_INTEGER_SPACE]; int result; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprLongObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; } sprintf(buf, ": %ld", exprResult); Tcl_AppendResult(interp, buf, NULL); return TCL_OK; } /* *---------------------------------------------------------------------- * * TestexprdoubleCmd -- * * This procedure verifies that Tcl_ExprDouble does not modify the * interpreter result if there is no error. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TestexprdoubleCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ CONST char **argv; /* Argument strings. */ { double exprResult; char buf[4 + TCL_DOUBLE_SPACE]; int result; if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], " expression\"", (char *) NULL); return TCL_ERROR; } Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprDouble(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; } strcpy(buf, ": "); Tcl_PrintDouble(interp, exprResult, buf+2); Tcl_AppendResult(interp, buf, NULL); return TCL_OK; } /* *---------------------------------------------------------------------- * * TestexprdoubleobjCmd -- * * This procedure verifies that Tcl_ExprLongObj does not modify the * interpreter result if there is no error. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TestexprdoubleobjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST *objv; /* Argument objects. */ { double exprResult; char buf[4 + TCL_DOUBLE_SPACE]; int result; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; } strcpy(buf, ": "); Tcl_PrintDouble(interp, exprResult, buf+2); Tcl_AppendResult(interp, buf, NULL); return TCL_OK; } /* *---------------------------------------------------------------------- * * TestexprstringCmd -- * * This procedure tests the basic operation of Tcl_ExprString. |
︙ | ︙ | |||
2448 2449 2450 2451 2452 2453 2454 | Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ CONST char **argv; /* Argument strings. */ { static CONST char *platformStrings[] = { "unix", "mac", "windows" }; TclPlatformType *platform; | < | < < < | 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 | Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ CONST char **argv; /* Argument strings. */ { static CONST char *platformStrings[] = { "unix", "mac", "windows" }; TclPlatformType *platform; platform = TclGetPlatform(); if (argc != 1) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], (char *) NULL); return TCL_ERROR; } |
︙ | ︙ | |||
2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 | 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; char buffer[2*TCL_DOUBLE_SPACE]; int writable, flag; Tcl_Obj *tmp; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], | > > > > > > > > > | > | | > > > > > > > > > > > | 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 | 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 char charVar = '@'; static unsigned char ucharVar = 130; static short shortVar = 3000; static unsigned short ushortVar = 60000; static unsigned int uintVar = 0xbeeffeed; static long longVar = 123456789L; static unsigned long ulongVar = 3456789012UL; static float floatVar = 4.5; static Tcl_WideUInt uwideVar = (Tcl_WideUInt) Tcl_LongAsWide(123); static int created = 0; char buffer[2*TCL_DOUBLE_SPACE]; int writable, flag; Tcl_Obj *tmp; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option ?arg arg arg arg arg arg arg arg arg arg arg arg", " arg arg?\"", (char *) NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { if (argc != 16) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " intRO realRO boolRO stringRO wideRO charRO ucharRO shortRO", " ushortRO uintRO longRO ulongRO floatRO uwideRO\"", (char *) NULL); return TCL_ERROR; } if (created) { Tcl_UnlinkVar(interp, "int"); Tcl_UnlinkVar(interp, "real"); Tcl_UnlinkVar(interp, "bool"); Tcl_UnlinkVar(interp, "string"); Tcl_UnlinkVar(interp, "wide"); Tcl_UnlinkVar(interp, "char"); Tcl_UnlinkVar(interp, "uchar"); Tcl_UnlinkVar(interp, "short"); Tcl_UnlinkVar(interp, "ushort"); Tcl_UnlinkVar(interp, "uint"); Tcl_UnlinkVar(interp, "long"); Tcl_UnlinkVar(interp, "ulong"); Tcl_UnlinkVar(interp, "float"); Tcl_UnlinkVar(interp, "uwide"); } created = 1; if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "int", (char *) &intVar, |
︙ | ︙ | |||
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 | return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "wide", (char *) &wideVar, TCL_LINK_WIDE_INT | flag) != TCL_OK) { return TCL_ERROR; } } else if (strcmp(argv[1], "delete") == 0) { Tcl_UnlinkVar(interp, "int"); Tcl_UnlinkVar(interp, "real"); Tcl_UnlinkVar(interp, "bool"); Tcl_UnlinkVar(interp, "string"); Tcl_UnlinkVar(interp, "wide"); created = 0; } else if (strcmp(argv[1], "get") == 0) { TclFormatInt(buffer, intVar); Tcl_AppendElement(interp, buffer); Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer); Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, boolVar); Tcl_AppendElement(interp, buffer); Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); /* * Wide ints only have an object-based interface. */ tmp = Tcl_NewWideIntObj(wideVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); } else if (strcmp(argv[1], "set") == 0) { | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > | 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 | return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "wide", (char *) &wideVar, TCL_LINK_WIDE_INT | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[7], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "char", (char *) &charVar, TCL_LINK_CHAR | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[8], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "uchar", (char *) &ucharVar, TCL_LINK_UCHAR | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[9], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "short", (char *) &shortVar, TCL_LINK_SHORT | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[10], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "ushort", (char *) &ushortVar, TCL_LINK_USHORT | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[11], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "uint", (char *) &uintVar, TCL_LINK_UINT | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[12], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "long", (char *) &longVar, TCL_LINK_LONG | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[13], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "ulong", (char *) &ulongVar, TCL_LINK_ULONG | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[14], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "float", (char *) &floatVar, TCL_LINK_FLOAT | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[15], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "uwide", (char *) &uwideVar, TCL_LINK_WIDE_UINT | flag) != TCL_OK) { return TCL_ERROR; } } else if (strcmp(argv[1], "delete") == 0) { Tcl_UnlinkVar(interp, "int"); Tcl_UnlinkVar(interp, "real"); Tcl_UnlinkVar(interp, "bool"); Tcl_UnlinkVar(interp, "string"); Tcl_UnlinkVar(interp, "wide"); Tcl_UnlinkVar(interp, "char"); Tcl_UnlinkVar(interp, "uchar"); Tcl_UnlinkVar(interp, "short"); Tcl_UnlinkVar(interp, "ushort"); Tcl_UnlinkVar(interp, "uint"); Tcl_UnlinkVar(interp, "long"); Tcl_UnlinkVar(interp, "ulong"); Tcl_UnlinkVar(interp, "float"); Tcl_UnlinkVar(interp, "uwide"); created = 0; } else if (strcmp(argv[1], "get") == 0) { TclFormatInt(buffer, intVar); Tcl_AppendElement(interp, buffer); Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer); Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, boolVar); Tcl_AppendElement(interp, buffer); Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); /* * Wide ints only have an object-based interface. */ tmp = Tcl_NewWideIntObj(wideVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); TclFormatInt(buffer, (int) charVar); Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) ucharVar); Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) shortVar); Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) ushortVar); Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) uintVar); Tcl_AppendElement(interp, buffer); tmp = Tcl_NewLongObj(longVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); tmp = Tcl_NewLongObj((long)ulongVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); Tcl_PrintDouble((Tcl_Interp *) NULL, (double)floatVar, buffer); Tcl_AppendElement(interp, buffer); tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); } else if (strcmp(argv[1], "set") == 0) { int v; if (argc != 16) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " intValue realValue boolValue stringValue wideValue", " charValue ucharValue shortValue ushortValue uintValue", " longValue ulongValue floatValue uwideValue\"", (char *) NULL); return TCL_ERROR; } if (argv[2][0] != 0) { if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { return TCL_ERROR; } |
︙ | ︙ | |||
2664 2665 2666 2667 2668 2669 2670 2671 | tmp = Tcl_NewStringObj(argv[6], -1); if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { Tcl_DecrRefCount(tmp); return TCL_ERROR; } Tcl_DecrRefCount(tmp); } } else if (strcmp(argv[1], "update") == 0) { | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > | 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 | tmp = Tcl_NewStringObj(argv[6], -1); if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { Tcl_DecrRefCount(tmp); return TCL_ERROR; } Tcl_DecrRefCount(tmp); } if (argv[7][0]) { if (Tcl_GetInt(interp, argv[7], &v) != TCL_OK) { return TCL_ERROR; } charVar = (char) v; } if (argv[8][0]) { if (Tcl_GetInt(interp, argv[8], &v) != TCL_OK) { return TCL_ERROR; } ucharVar = (unsigned char) v; } if (argv[9][0]) { if (Tcl_GetInt(interp, argv[9], &v) != TCL_OK) { return TCL_ERROR; } shortVar = (short) v; } if (argv[10][0]) { if (Tcl_GetInt(interp, argv[10], &v) != TCL_OK) { return TCL_ERROR; } ushortVar = (unsigned short) v; } if (argv[11][0]) { if (Tcl_GetInt(interp, argv[11], &v) != TCL_OK) { return TCL_ERROR; } uintVar = (unsigned int) v; } if (argv[12][0]) { if (Tcl_GetInt(interp, argv[12], &v) != TCL_OK) { return TCL_ERROR; } longVar = (long) v; } if (argv[13][0]) { if (Tcl_GetInt(interp, argv[13], &v) != TCL_OK) { return TCL_ERROR; } ulongVar = (unsigned long) v; } if (argv[14][0]) { double d; if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) { return TCL_ERROR; } floatVar = (float) d; } if (argv[15][0]) { Tcl_WideInt w; tmp = Tcl_NewStringObj(argv[15], -1); if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) { Tcl_DecrRefCount(tmp); return TCL_ERROR; } Tcl_DecrRefCount(tmp); uwideVar = (Tcl_WideUInt) w; } } else if (strcmp(argv[1], "update") == 0) { int v; if (argc != 16) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " intValue realValue boolValue stringValue wideValue", " charValue ucharValue shortValue ushortValue uintValue", " longValue ulongValue floatValue uwideValue\"", (char *) NULL); return TCL_ERROR; } if (argv[2][0] != 0) { if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { return TCL_ERROR; } |
︙ | ︙ | |||
2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 | if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { Tcl_DecrRefCount(tmp); return TCL_ERROR; } Tcl_DecrRefCount(tmp); Tcl_UpdateLinkedVar(interp, "wide"); } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be create, delete, get, set, or update", (char *) NULL); return TCL_ERROR; } return TCL_OK; | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { Tcl_DecrRefCount(tmp); return TCL_ERROR; } Tcl_DecrRefCount(tmp); Tcl_UpdateLinkedVar(interp, "wide"); } if (argv[7][0]) { if (Tcl_GetInt(interp, argv[7], &v) != TCL_OK) { return TCL_ERROR; } charVar = (char) v; Tcl_UpdateLinkedVar(interp, "char"); } if (argv[8][0]) { if (Tcl_GetInt(interp, argv[8], &v) != TCL_OK) { return TCL_ERROR; } ucharVar = (unsigned char) v; Tcl_UpdateLinkedVar(interp, "uchar"); } if (argv[9][0]) { if (Tcl_GetInt(interp, argv[9], &v) != TCL_OK) { return TCL_ERROR; } shortVar = (short) v; Tcl_UpdateLinkedVar(interp, "short"); } if (argv[10][0]) { if (Tcl_GetInt(interp, argv[10], &v) != TCL_OK) { return TCL_ERROR; } ushortVar = (unsigned short) v; Tcl_UpdateLinkedVar(interp, "ushort"); } if (argv[11][0]) { if (Tcl_GetInt(interp, argv[11], &v) != TCL_OK) { return TCL_ERROR; } uintVar = (unsigned int) v; Tcl_UpdateLinkedVar(interp, "uint"); } if (argv[12][0]) { if (Tcl_GetInt(interp, argv[12], &v) != TCL_OK) { return TCL_ERROR; } longVar = (long) v; Tcl_UpdateLinkedVar(interp, "long"); } if (argv[13][0]) { if (Tcl_GetInt(interp, argv[13], &v) != TCL_OK) { return TCL_ERROR; } ulongVar = (unsigned long) v; Tcl_UpdateLinkedVar(interp, "ulong"); } if (argv[14][0]) { double d; if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) { return TCL_ERROR; } floatVar = (float) d; Tcl_UpdateLinkedVar(interp, "float"); } if (argv[15][0]) { Tcl_WideInt w; tmp = Tcl_NewStringObj(argv[15], -1); if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) { Tcl_DecrRefCount(tmp); return TCL_ERROR; } Tcl_DecrRefCount(tmp); uwideVar = (Tcl_WideUInt) w; Tcl_UpdateLinkedVar(interp, "uwide"); } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be create, delete, get, set, or update", (char *) NULL); return TCL_ERROR; } return TCL_OK; |
︙ | ︙ | |||
3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 | *cflagsPtr = cflags; *eflagsPtr = eflags; } /* *---------------------------------------------------------------------- * * TestsetassocdataCmd -- * * This procedure implements the "testsetassocdata" command. It is used * to test Tcl_SetAssocData. * * Results: * A standard Tcl result. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | *cflagsPtr = cflags; *eflagsPtr = eflags; } /* *---------------------------------------------------------------------- * * TestreturnObjCmd -- * * This procedure implements the "testreturn" command. It is * used to verify that a * return TCL_RETURN; * has same behavior as * return Tcl_SetReturnOptions(interp, Tcl_NewObj()); * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestreturnObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { return TCL_RETURN; } /* *---------------------------------------------------------------------- * * TestsetassocdataCmd -- * * This procedure implements the "testsetassocdata" command. It is used * to test Tcl_SetAssocData. * * Results: * A standard Tcl result. |
︙ | ︙ | |||
3688 3689 3690 3691 3692 3693 3694 | Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ CONST char **argv; /* Argument strings. */ { size_t length; TclPlatformType *platform; | < | < < < | 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 | Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ CONST char **argv; /* Argument strings. */ { size_t length; TclPlatformType *platform; platform = TclGetPlatform(); if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], " platform\"", (char *) NULL); return TCL_ERROR; } |
︙ | ︙ | |||
4187 4188 4189 4190 4191 4192 4193 | Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* The argument objects. */ { char *name, *arg; int flags = 0; Tcl_Namespace *namespacePtr; | | | 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 | Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* The argument objects. */ { char *name, *arg; int flags = 0; Tcl_Namespace *namespacePtr; Tcl_CallFrame *framePtr; Tcl_Var variable; int result; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "name scope"); return TCL_ERROR; } |
︙ | ︙ | |||
4218 4219 4220 4221 4222 4223 4224 | if (flags == TCL_NAMESPACE_ONLY) { namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var", (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG); if (namespacePtr == NULL) { return TCL_ERROR; } | | | | 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 | if (flags == TCL_NAMESPACE_ONLY) { namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var", (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG); if (namespacePtr == NULL) { return TCL_ERROR; } result = TclPushStackFrame(interp, &framePtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; } } variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL, (flags | TCL_LEAVE_ERR_MSG)); if (flags == TCL_NAMESPACE_ONLY) { TclPopStackFrame(interp); } if (variable == (Tcl_Var) NULL) { return TCL_ERROR; } Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp)); return TCL_OK; } |
︙ | ︙ | |||
5315 5316 5317 5318 5319 5320 5321 | } cmdName = argv[1]; len = strlen(cmdName); chanPtr = (Channel *) NULL; if (argc > 2) { | > > > > > > > > > > > > > > > > > > > > > > | > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } cmdName = argv[1]; len = strlen(cmdName); chanPtr = (Channel *) NULL; if (argc > 2) { if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { /* For splice access the pool of detached channels. * Locate channel, remove from the list. */ TestChannel** nextPtrPtr; TestChannel* curPtr; chan = (Tcl_Channel) NULL; for (nextPtrPtr = &firstDetached, curPtr = firstDetached; curPtr != NULL; nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) { if (strcmp (argv[2], Tcl_GetChannelName (curPtr->chan)) == 0) { *nextPtrPtr = curPtr->nextPtr; curPtr->nextPtr = NULL; chan = curPtr->chan; ckfree ((char*) curPtr); break; } } } else { chan = Tcl_GetChannel(interp, argv[2], &mode); } if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } chanPtr = (Channel *) chan; statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; chan = (Tcl_Channel) chanPtr; } else { /* lint */ statePtr = NULL; chan = NULL; } if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) { Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1); Tcl_IncrRefCount (msg); Tcl_SetChannelError (chan, msg); Tcl_DecrRefCount (msg); Tcl_GetChannelError (chan, &msg); Tcl_SetObjResult (interp, msg); Tcl_DecrRefCount (msg); return TCL_OK; } if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) { Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1); Tcl_IncrRefCount (msg); Tcl_SetChannelErrorInterp (interp, msg); Tcl_DecrRefCount (msg); Tcl_GetChannelErrorInterp (interp, &msg); Tcl_SetObjResult (interp, msg); Tcl_DecrRefCount (msg); return TCL_OK; } /* * "cut" is actually more a simplified detach facility as provided * by the Thread package. Without the safeguards of a regular * command (no checking that the command is truly cut'able, no * mutexes for thread-safety). Its complementary command is * "splice", see below. */ if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) { TestChannel* det; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " cut channelName\"", (char *) NULL); return TCL_ERROR; } Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); /* prevent closing */ Tcl_UnregisterChannel(interp, chan); Tcl_CutChannel(chan); /* Remember the channel in the pool of detached channels */ det = (TestChannel*) ckalloc (sizeof(TestChannel)); det->chan = chan; det->nextPtr = firstDetached; firstDetached = det; return TCL_OK; } if ((cmdName[0] == 'c') && (strncmp(cmdName, "clearchannelhandlers", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], |
︙ | ︙ | |||
5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 | } TclFormatInt(buf, statePtr->refCount); Tcl_AppendResult(interp, buf, (char *) NULL); return TCL_OK; } if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", (char *) NULL); return TCL_ERROR; } Tcl_SpliceChannel(chan); return TCL_OK; } if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", (char *) NULL); | > > > > > > > > > > > > | 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 | } TclFormatInt(buf, statePtr->refCount); Tcl_AppendResult(interp, buf, (char *) NULL); return TCL_OK; } /* * "splice" is actually more a simplified attach facility as * provided by the Thread package. Without the safeguards of a * regular command (no checking that the command is truly * cut'able, no mutexes for thread-safety). Its complementary * command is "cut", see above. */ if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", (char *) NULL); return TCL_ERROR; } Tcl_SpliceChannel(chan); Tcl_RegisterChannel(interp, chan); Tcl_UnregisterChannel((Tcl_Interp *)NULL, chan); return TCL_OK; } if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", (char *) NULL); |
︙ | ︙ | |||
6635 6636 6637 6638 6639 6640 6641 | total += val; } TclFormatInt(buf, total); Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } } | > > > > > > > > | 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 | total += val; } TclFormatInt(buf, total); Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclTestObj.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclTestObj.c -- * * This file contains C command procedures for the additional Tcl * commands that are used for testing implementations of the Tcl object * types. These commands are not normally included in Tcl * applications; they're only used for testing. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | /* * tclTestObj.c -- * * This file contains C command procedures for the additional Tcl * commands that are used for testing implementations of the Tcl object * types. These commands are not normally included in Tcl * applications; they're only used for testing. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * Copyright (c) 2005 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: tclTestObj.c,v 1.12.6.5 2005/08/22 16:11:37 dgp Exp $ */ #include "tclInt.h" #include "tommath.h" /* * An array of Tcl_Obj pointers used in the commands that operate on or get * the values of Tcl object-valued variables. varPtr[i] is the i-th * variable's Tcl_Obj *. */ |
︙ | ︙ | |||
33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | static int CheckIfVarUnset _ANSI_ARGS_((Tcl_Interp *interp, int varIndex)); static int GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *indexPtr)); static void SetVarToObj _ANSI_ARGS_((int varIndex, Tcl_Obj *objPtr)); int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); static int TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestconvertobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestindexobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestintobjCmd _ANSI_ARGS_((ClientData dummy, | > > > > > | 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 | static int CheckIfVarUnset _ANSI_ARGS_((Tcl_Interp *interp, int varIndex)); static int GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *indexPtr)); static void SetVarToObj _ANSI_ARGS_((int varIndex, Tcl_Obj *objPtr)); int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); static int TestbignumobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); #if 0 static int TestconvertobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); #endif static int TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestindexobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestintobjCmd _ANSI_ARGS_((ClientData dummy, |
︙ | ︙ | |||
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 | { register int i; for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { varPtr[i] = NULL; } Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); return TCL_OK; } /* *---------------------------------------------------------------------- * * TestbooleanobjCmd -- * * This procedure implements the "testbooleanobj" command. It is used | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | { register int i; for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { varPtr[i] = NULL; } Tcl_CreateObjCommand( interp, "testbignumobj", TestbignumobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc*) NULL ); Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); #if 0 Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); #endif Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); return TCL_OK; } /* *---------------------------------------------------------------------- * * TestbignumobjCmd -- * * This procedure implmenets the "testbignumobj" command. It is used * to exercise the bignum Tcl object type implementation. * * Results: * Returns a standard Tcl object result. * * Side effects: * Creates and frees bignum objects; converts objects to have bignum * type. * *---------------------------------------------------------------------- */ static int TestbignumobjCmd( clientData, interp, objc, objv ) ClientData clientData; /* unused */ Tcl_Interp* interp; /* Tcl interpreter */ int objc; /* Argument count */ Tcl_Obj* CONST objv[]; /* Argument vector */ { const char * subcmds[] = { "set", "get", "mult10", "div10", NULL }; enum options { BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10 }; int index, varIndex; char* string; mp_int bignumValue, newValue; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?..."); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } string = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) { return TCL_ERROR; } switch (index) { case BIGNUM_SET: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "var value"); return TCL_ERROR; } string = Tcl_GetString(objv[3]); if (mp_init(&bignumValue) != MP_OKAY) { Tcl_SetObjResult(interp, Tcl_NewStringObj("error in mp_init", -1)); return TCL_ERROR; } if (mp_read_radix(&bignumValue, string, 10) != MP_OKAY) { mp_clear(&bignumValue); Tcl_SetObjResult(interp, Tcl_NewStringObj("error in mp_read_radix", -1)); return TCL_ERROR; } /* * If the object currently bound to the variable with index * varIndex has ref count 1 (i.e. the object is unshared) we can * modify that object directly. Otherwise, if RC>1 (i.e. the * object is shared), we must create a new object to modify/set and * decrement the old formerly-shared object's ref count. This is * "copy on write". */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetBignumObj(varPtr[varIndex], &bignumValue); } else { SetVarToObj(varIndex, Tcl_NewBignumObj(&bignumValue)); } break; case BIGNUM_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } break; case BIGNUM_MULT10: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], &bignumValue) != TCL_OK) { return TCL_ERROR; } if (mp_init(&newValue) != MP_OKAY || (mp_mul_d(&bignumValue, 10, &newValue) != MP_OKAY)) { mp_clear(&bignumValue); mp_clear(&newValue); Tcl_SetObjResult(interp, Tcl_NewStringObj("error in mp_mul_d", -1)); return TCL_ERROR; } mp_clear(&bignumValue); if (!Tcl_IsShared(varPtr[varIndex])) { Tcl_SetBignumObj(varPtr[varIndex], &newValue); } else { SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue)); } break; case BIGNUM_DIV10: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], &bignumValue) != TCL_OK) { return TCL_ERROR; } if (mp_init(&newValue) != MP_OKAY || (mp_div_d(&bignumValue, 10, &newValue, NULL) != MP_OKAY)) { mp_clear(&bignumValue); mp_clear(&newValue); Tcl_SetObjResult(interp, Tcl_NewStringObj("error in mp_div_d", -1)); return TCL_ERROR; } mp_clear(&bignumValue); if (!Tcl_IsShared(varPtr[varIndex])) { Tcl_SetBignumObj(varPtr[varIndex], &newValue); } else { SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue)); } } Tcl_SetObjResult(interp, varPtr[varIndex]); return TCL_OK; } /* *---------------------------------------------------------------------- * * TestbooleanobjCmd -- * * This procedure implements the "testbooleanobj" command. It is used |
︙ | ︙ | |||
204 205 206 207 208 209 210 211 212 213 214 215 216 217 | "bad option \"", Tcl_GetString(objv[1]), "\": must be set, get, or not", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * TestconvertobjCmd -- * * This procedure implements the "testconvertobj" command. It is used * to test converting objects to new types. | > | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 | "bad option \"", Tcl_GetString(objv[1]), "\": must be set, get, or not", (char *) NULL); return TCL_ERROR; } return TCL_OK; } #if 0 /* *---------------------------------------------------------------------- * * TestconvertobjCmd -- * * This procedure implements the "testconvertobj" command. It is used * to test converting objects to new types. |
︙ | ︙ | |||
257 258 259 260 261 262 263 264 265 266 267 268 269 270 | Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", Tcl_GetString(objv[1]), "\": must be double", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * TestdoubleobjCmd -- * * This procedure implements the "testdoubleobj" command. It is used | > | 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 | Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", Tcl_GetString(objv[1]), "\": must be double", (char *) NULL); return TCL_ERROR; } return TCL_OK; } #endif /* *---------------------------------------------------------------------- * * TestdoubleobjCmd -- * * This procedure implements the "testdoubleobj" command. It is used |
︙ | ︙ |
Changes to generic/tclThread.c.
1 2 3 | /* * tclThread.c -- * | | | | | | | < | | | | | > | | | | < < < < < < < < < < < < < < < < < < < < < | | | | | | | | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | /* * tclThread.c -- * * This file implements Platform independent thread operations. Most of * the real work is done in the platform dependent files. * * Copyright (c) 1998 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclThread.c,v 1.8.2.4 2005/08/15 18:13:59 dgp Exp $ */ #include "tclInt.h" /* * There are three classes of synchronization objects: mutexes, thread data * keys, and condition variables. The following are used to record the memory * used for these objects so they can be finalized. * * These statics are guarded by the mutex in the caller of * TclRememberThreadData, e.g., TclpThreadDataKeyInit */ typedef struct { int num; /* Number of objects remembered */ int max; /* Max size of the array */ char **list; /* List of pointers */ } SyncObjRecord; static SyncObjRecord keyRecord = {0, 0, NULL}; static SyncObjRecord mutexRecord = {0, 0, NULL}; static SyncObjRecord condRecord = {0, 0, NULL}; /* * Prototypes of functions used only in this file. */ static void RememberSyncObject _ANSI_ARGS_((char *objPtr, SyncObjRecord *recPtr)); static void ForgetSyncObject _ANSI_ARGS_((char *objPtr, SyncObjRecord *recPtr)); /* * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not * specified. Here we undo that so the functions are defined in the stubs * table. */ #ifndef TCL_THREADS #undef Tcl_MutexLock #undef Tcl_MutexUnlock #undef Tcl_MutexFinalize #undef Tcl_ConditionNotify #undef Tcl_ConditionWait #undef Tcl_ConditionFinalize #endif /* *---------------------------------------------------------------------- * * Tcl_GetThreadData -- * * This function allocates and initializes a chunk of thread local * storage. * * Results: * A thread-specific pointer to the data structure. * * Side effects: * Will allocate memory the first time this thread calls for this chunk * of storage. * *---------------------------------------------------------------------- */ VOID * Tcl_GetThreadData(keyPtr, size) Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk */ int size; /* Size of storage block */ { VOID *result; #ifdef TCL_THREADS /* * Initialize the key for this thread. */ result = TclpThreadDataKeyGet(keyPtr); if (result == NULL) { result = (VOID *)ckalloc((size_t)size); memset(result, 0, (size_t)size); TclpThreadDataKeySet(keyPtr, result); } #else /* TCL_THREADS */ if (*keyPtr == NULL) { result = (VOID *)ckalloc((size_t)size); memset((char *)result, 0, (size_t)size); *keyPtr = (Tcl_ThreadDataKey)result; RememberSyncObject((char *)keyPtr, &keyRecord); } result = *(VOID **)keyPtr; #endif /* TCL_THREADS */ return result; } /* *---------------------------------------------------------------------- * * TclThreadDataKeyGet -- * * This function returns a pointer to a block of thread local storage. * * Results: * A thread-specific pointer to the data structure, or NULL if the memory * has not been assigned to this key for this thread. * * Side effects: * None. * *---------------------------------------------------------------------- */ VOID * TclThreadDataKeyGet(keyPtr) Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really * (pthread_key_t **) */ { #ifdef TCL_THREADS return (VOID *)TclpThreadDataKeyGet(keyPtr); #else /* TCL_THREADS */ char *result = *(char **)keyPtr; return (VOID *)result; #endif /* TCL_THREADS */ } /* *---------------------------------------------------------------------- * * RememberSyncObject * * Keep a list of (mutexes/condition variable/data key) used during * finalization. * * Results: * None. * * Side effects: * Add to the appropriate list. * *---------------------------------------------------------------------- */ static void RememberSyncObject(objPtr, recPtr) char *objPtr; /* Pointer to sync object */ SyncObjRecord *recPtr; /* Record of sync objects */ { char **newList; int i, j; /* * Save the pointer to the allocated object so it can be finalized. Grow * the list of pointers if necessary, copying only non-NULL pointers to * the new list. */ if (recPtr->num >= recPtr->max) { recPtr->max += 8; newList = (char **)ckalloc(recPtr->max * sizeof(char *)); for (i=0,j=0 ; i<recPtr->num ; i++) { if (recPtr->list[i] != NULL) { newList[j++] = recPtr->list[i]; } } if (recPtr->list != NULL) { ckfree((char *)recPtr->list); } recPtr->list = newList; recPtr->num = j; } recPtr->list[recPtr->num] = objPtr; recPtr->num++; } /* *---------------------------------------------------------------------- * * ForgetSyncObject * * Remove a single object from the list. * * Results: * None. * * Side effects: * Remove from the appropriate list. * |
︙ | ︙ | |||
284 285 286 287 288 289 290 | } /* *---------------------------------------------------------------------- * * TclRememberMutex * | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TclRememberMutex * * Keep a list of mutexes used during finalization. * * Results: * None. * * Side effects: * Add to the mutex list. * *---------------------------------------------------------------------- */ void TclRememberMutex(mutexPtr) Tcl_Mutex *mutexPtr; { RememberSyncObject((char *)mutexPtr, &mutexRecord); } /* *---------------------------------------------------------------------- * * Tcl_MutexFinalize -- * * Finalize a single mutex and remove it from the list of remembered * objects. * * Results: * None. * * Side effects: * Remove the mutex from the list. * |
︙ | ︙ | |||
332 333 334 335 336 337 338 | #endif ForgetSyncObject((char *)mutexPtr, &mutexRecord); } /* *---------------------------------------------------------------------- * | < < < < < < < < < < < < < < < < < < < < < < < | | | | | 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 | #endif ForgetSyncObject((char *)mutexPtr, &mutexRecord); } /* *---------------------------------------------------------------------- * * TclRememberCondition * * Keep a list of condition variables used during finalization. * * Results: * None. * * Side effects: * Add to the condition variable list. * *---------------------------------------------------------------------- */ void TclRememberCondition(condPtr) Tcl_Condition *condPtr; { RememberSyncObject((char *)condPtr, &condRecord); } /* *---------------------------------------------------------------------- * * Tcl_ConditionFinalize -- * * Finalize a single condition variable and remove it from the list of * remembered objects. * * Results: * None. * * Side effects: * Remove the condition variable from the list. * |
︙ | ︙ | |||
407 408 409 410 411 412 413 | } /* *---------------------------------------------------------------------- * * TclFinalizeThreadData -- * | | | < < < < < < < < < < | < < < < < < < < < | | > > > > > > > < | < | < < > | > > < | 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 | } /* *---------------------------------------------------------------------- * * TclFinalizeThreadData -- * * This function cleans up the thread-local storage. This is called once * for each thread. * * Results: * None. * * Side effects: * Frees up all thread local storage. * *---------------------------------------------------------------------- */ void TclFinalizeThreadData() { TclpFinalizeThreadDataThread(); } /* *---------------------------------------------------------------------- * * TclFinalizeSynchronization -- * * This function cleans up all synchronization objects: mutexes, * condition variables, and thread-local storage. * * Results: * None. * * Side effects: * Frees up the memory. * *---------------------------------------------------------------------- */ void TclFinalizeSynchronization() { #ifdef TCL_THREADS void* blockPtr; Tcl_ThreadDataKey *keyPtr; Tcl_Mutex *mutexPtr; Tcl_Condition *condPtr; int i; TclpMasterLock(); /* * If we're running unthreaded, the TSD blocks are simply stored * inside their thread data keys. Free them here. */ for (i=0 ; i<keyRecord.num ; i++) { keyPtr = (Tcl_ThreadDataKey *)keyRecord.list[i]; blockPtr = (void*) *keyPtr; ckfree(blockPtr); } if (keyRecord.list != NULL) { ckfree((char *)keyRecord.list); keyRecord.list = NULL; } keyRecord.max = 0; keyRecord.num = 0; /* * Call thread storage master cleanup. */ TclFinalizeThreadStorage(); for (i=0 ; i<mutexRecord.num ; i++) { mutexPtr = (Tcl_Mutex *)mutexRecord.list[i]; if (mutexPtr != NULL) { TclpFinalizeMutex(mutexPtr); } } |
︙ | ︙ | |||
518 519 520 521 522 523 524 | ckfree((char *)condRecord.list); condRecord.list = NULL; } condRecord.max = 0; condRecord.num = 0; TclpMasterUnlock(); | | | | | | | 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 | ckfree((char *)condRecord.list); condRecord.list = NULL; } condRecord.max = 0; condRecord.num = 0; TclpMasterUnlock(); #else /* TCL_THREADS */ if (keyRecord.list != NULL) { ckfree((char *)keyRecord.list); keyRecord.list = NULL; } keyRecord.max = 0; keyRecord.num = 0; #endif /* TCL_THREADS */ } /* *---------------------------------------------------------------------- * * Tcl_ExitThread -- * * This function is called to terminate the current thread. This should * be used by extensions that create threads with additional interpreters * in them. * * Results: * None. * * Side effects: * All thread exit handlers are invoked, then the thread dies. * |
︙ | ︙ | |||
564 565 566 567 568 569 570 | #ifndef TCL_THREADS /* *---------------------------------------------------------------------- * * Tcl_ConditionWait, et al. -- * | | | | < | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 | #ifndef TCL_THREADS /* *---------------------------------------------------------------------- * * Tcl_ConditionWait, et al. -- * * These noop functions are provided so the stub table does not have to * be conditionalized for threads. The real implementations of these * functions live in the platform specific files. * * Results: * None. * * Side effects: * None. * |
︙ | ︙ | |||
607 608 609 610 611 612 613 | #undef Tcl_MutexUnlock void Tcl_MutexUnlock(mutexPtr) Tcl_Mutex *mutexPtr; { } | | > > > > > > > > | 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 | #undef Tcl_MutexUnlock void Tcl_MutexUnlock(mutexPtr) Tcl_Mutex *mutexPtr; { } #endif /* !TCL_THREADS */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclThreadAlloc.c.
1 2 3 4 | /* * tclThreadAlloc.c -- * * This is a very fast storage allocator for used with threads (designed | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | 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 | /* * tclThreadAlloc.c -- * * This is a very fast storage allocator for used with threads (designed * avoid lock contention). The basic strategy is to allocate memory in * fixed size blocks from block caches. * * The Initial Developer of the Original Code is America Online, Inc. * Portions created by AOL are Copyright (C) 1999 America Online, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclThreadAlloc.c,v 1.14.2.2 2005/08/02 18:16:10 dgp Exp $ */ #include "tclInt.h" #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) /* * If range checking is enabled, an additional byte will be allocated to store * the magic number at the end of the requested memory. */ #ifndef RCHECK #ifdef NDEBUG #define RCHECK 0 #else #define RCHECK 1 #endif #endif /* * The following define the number of Tcl_Obj's to allocate/move at a time and * the high water mark to prune a per-thread cache. On a 32 bit system, * sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k. */ #define NOBJALLOC 800 #define NOBJHIGH 1200 /* * The following defines the number of buckets in the bucket cache and those * block sizes from (1<<4) to (1<<(3+NBUCKETS)) */ #define NBUCKETS 11 #define MAXALLOC 16284 /* * The following union stores accounting information for each block including * two small magic numbers and a bucket number when in use or a next pointer * when free. The original requested size (not including the Block overhead) * is also maintained. */ typedef struct Block { union { struct Block *next; /* Next in free list. */ struct { unsigned char magic1; /* First magic number. */ unsigned char bucket; /* Bucket block allocated from. */ unsigned char unused; /* Padding. */ unsigned char magic2; /* Second magic number. */ } s; } u; size_t reqSize; /* Requested allocation size. */ } Block; #define nextBlock u.next #define sourceBucket u.s.bucket #define magicNum1 u.s.magic1 #define magicNum2 u.s.magic2 #define MAGIC 0xEF /* * The following structure defines a bucket of blocks with various accounting * and statistics information. */ typedef struct Bucket { Block *firstPtr; /* First block available */ int numFree; /* Number of blocks available */ /* All fields below for accounting only */ int numRemoves; /* Number of removes from bucket */ int numInserts; /* Number of inserts into bucket */ int numWaits; /* Number of waits to acquire a lock */ int numLocks; /* Number of locks acquired */ int totalAssigned; /* Total space assigned to bucket */ } Bucket; /* * The following structure defines a cache of buckets and objs, of which there * will be (at most) one per thread. */ typedef struct Cache { struct Cache *nextPtr; /* Linked list of cache entries */ Tcl_ThreadId owner; /* Which thread's cache is this? */ Tcl_Obj *firstObjPtr; /* List of free objects for thread */ int numObjects; /* Number of objects for thread */ int totalAssigned; /* Total space assigned to thread */ Bucket buckets[NBUCKETS]; /* The buckets for this thread */ } Cache; /* * The following array specifies various per-bucket limits and locks. The * values are statically initialized to avoid calculating them repeatedly. */ static struct { size_t blockSize; /* Bucket blocksize. */ int maxBlocks; /* Max blocks before move to share. */ int numMove; /* Num blocks to move to share. */ Tcl_Mutex *lockPtr; /* Share bucket lock. */ } bucketInfo[NBUCKETS] = { { 16, 1024, 512, NULL}, { 32, 512, 256, NULL}, { 64, 256, 128, NULL}, { 128, 128, 64, NULL}, { 256, 64, 32, NULL}, { 512, 32, 16, NULL}, |
︙ | ︙ | |||
142 143 144 145 146 147 148 | static Block * Ptr2Block _ANSI_ARGS_((char *ptr)); static char * Block2Ptr _ANSI_ARGS_((Block *blockPtr, int bucket, unsigned int reqSize)); static void MoveObjs _ANSI_ARGS_((Cache *fromPtr, Cache *toPtr, int numMove)); /* | | < | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | static Block * Ptr2Block _ANSI_ARGS_((char *ptr)); static char * Block2Ptr _ANSI_ARGS_((Block *blockPtr, int bucket, unsigned int reqSize)); static void MoveObjs _ANSI_ARGS_((Cache *fromPtr, Cache *toPtr, int numMove)); /* * Local variables defined in this file and initialized at startup. */ static Tcl_Mutex *listLockPtr; static Tcl_Mutex *objLockPtr; static Cache sharedCache; static Cache *sharedPtr = &sharedCache; static Cache *firstCachePtr = &sharedCache; |
︙ | ︙ | |||
302 303 304 305 306 307 308 | size_t size; if (cachePtr == NULL) { cachePtr = GetCache(); } /* | | < | | | 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | size_t size; if (cachePtr == NULL) { cachePtr = GetCache(); } /* * Increment the requested size to include room for the Block structure. * Call malloc() directly if the required amount is greater than the * largest block, otherwise pop the smallest block large enough, * allocating more blocks if necessary. */ blockPtr = NULL; size = reqSize + sizeof(Block); #if RCHECK ++size; |
︙ | ︙ | |||
373 374 375 376 377 378 379 | cachePtr = TclpGetAllocCache(); if (cachePtr == NULL) { cachePtr = GetCache(); } /* | | | | < > > | 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 | cachePtr = TclpGetAllocCache(); if (cachePtr == NULL) { cachePtr = GetCache(); } /* * Get the block back from the user pointer and call system free directly * for large blocks. Otherwise, push the block back on the bucket and move * blocks to the shared cache if there are now too many free. */ blockPtr = Ptr2Block(ptr); bucket = blockPtr->sourceBucket; if (bucket == NBUCKETS) { cachePtr->totalAssigned -= blockPtr->reqSize; free(blockPtr); return; } cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize; blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr; cachePtr->buckets[bucket].firstPtr = blockPtr; ++cachePtr->buckets[bucket].numFree; ++cachePtr->buckets[bucket].numInserts; if (cachePtr != sharedPtr && cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) { PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove); } } /* |
︙ | ︙ | |||
433 434 435 436 437 438 439 | } if (cachePtr == NULL) { cachePtr = GetCache(); } /* | | < | | | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 | } if (cachePtr == NULL) { cachePtr = GetCache(); } /* * If the block is not a system block and fits in place, simply return the * existing pointer. Otherwise, if the block is a system block and the new * size would also require a system block, call realloc() directly. */ blockPtr = Ptr2Block(ptr); size = reqSize + sizeof(Block); #if RCHECK ++size; #endif |
︙ | ︙ | |||
492 493 494 495 496 497 498 | * * Allocate a Tcl_Obj from the per-thread cache. * * Results: * Pointer to uninitialized Tcl_Obj. * * Side effects: | | | < < | | > > > > | 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 | * * Allocate a Tcl_Obj from the per-thread cache. * * Results: * Pointer to uninitialized Tcl_Obj. * * Side effects: * May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's if * list is empty. * *---------------------------------------------------------------------- */ Tcl_Obj * TclThreadAllocObj(void) { register Cache *cachePtr = TclpGetAllocCache(); register Tcl_Obj *objPtr; if (cachePtr == NULL) { cachePtr = GetCache(); } /* * Get this thread's obj list structure and move or allocate new objs if * necessary. */ if (cachePtr->numObjects == 0) { register int numMove; Tcl_MutexLock(objLockPtr); numMove = sharedPtr->numObjects; if (numMove > 0) { if (numMove > NOBJALLOC) { numMove = NOBJALLOC; } MoveObjs(sharedPtr, cachePtr, numMove); } Tcl_MutexUnlock(objLockPtr); if (cachePtr->numObjects == 0) { Tcl_Obj *newObjsPtr; cachePtr->numObjects = numMove = NOBJALLOC; newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); if (newObjsPtr == NULL) { Tcl_Panic("alloc: could not allocate %d new objects", numMove); } while (--numMove >= 0) { objPtr = &newObjsPtr[numMove]; |
︙ | ︙ | |||
560 561 562 563 564 565 566 | * * Return a free Tcl_Obj to the per-thread cache. * * Results: * None. * * Side effects: | | < | 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 | * * Return a free Tcl_Obj to the per-thread cache. * * Results: * None. * * Side effects: * May move free Tcl_Obj's to shared list upon hitting high water mark. * *---------------------------------------------------------------------- */ void TclThreadFreeObj(objPtr) Tcl_Obj *objPtr; |
︙ | ︙ | |||
585 586 587 588 589 590 591 | */ objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; cachePtr->firstObjPtr = objPtr; ++cachePtr->numObjects; /* | | | | 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 | */ objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; cachePtr->firstObjPtr = objPtr; ++cachePtr->numObjects; /* * If the number of free objects has exceeded the high water mark, move * some blocks to the shared list. */ if (cachePtr->numObjects > NOBJHIGH) { Tcl_MutexLock(objLockPtr); MoveObjs(cachePtr, sharedPtr, NOBJALLOC); Tcl_MutexUnlock(objLockPtr); } |
︙ | ︙ | |||
675 676 677 678 679 680 681 | register Tcl_Obj *objPtr = fromPtr->firstObjPtr; Tcl_Obj *fromFirstObjPtr = objPtr; toPtr->numObjects += numMove; fromPtr->numObjects -= numMove; /* | | | < | | | 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 | register Tcl_Obj *objPtr = fromPtr->firstObjPtr; Tcl_Obj *fromFirstObjPtr = objPtr; toPtr->numObjects += numMove; fromPtr->numObjects -= numMove; /* * Find the last object to be moved; set the next one (the first one not * to be moved) as the first object in the 'from' cache. */ while (--numMove) { objPtr = objPtr->internalRep.otherValuePtr; } fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr; /* * Move all objects as a block - they are already linked to each other, we * just have to update the first and last. */ objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr; toPtr->firstObjPtr = fromFirstObjPtr; } /* |
︙ | ︙ | |||
760 761 762 763 764 765 766 | * * Set/unset the lock to access a bucket in the shared cache. * * Results: * None. * * Side effects: | | | | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 | * * Set/unset the lock to access a bucket in the shared cache. * * Results: * None. * * Side effects: * Lock activity and contention are monitored globally and on a per-cache * basis. * *---------------------------------------------------------------------- */ static void LockBucket(cachePtr, bucket) Cache *cachePtr; |
︙ | ︙ | |||
817 818 819 820 821 822 823 | Cache *cachePtr; int bucket, numMove; { register Block *lastPtr, *firstPtr; register int n = numMove; /* | | | | | | 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 | Cache *cachePtr; int bucket, numMove; { register Block *lastPtr, *firstPtr; register int n = numMove; /* * Before acquiring the lock, walk the block list to find the last block * to be moved. */ firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr; while (--n > 0) { lastPtr = lastPtr->nextBlock; } cachePtr->buckets[bucket].firstPtr = lastPtr->nextBlock; cachePtr->buckets[bucket].numFree -= numMove; /* * Aquire the lock and place the list of blocks at the front of the shared * cache bucket. */ LockBucket(cachePtr, bucket); lastPtr->nextBlock = sharedPtr->buckets[bucket].firstPtr; sharedPtr->buckets[bucket].firstPtr = firstPtr; sharedPtr->buckets[bucket].numFree += numMove; UnlockBucket(cachePtr, bucket); |
︙ | ︙ | |||
863 864 865 866 867 868 869 | static int GetBlocks(cachePtr, bucket) Cache *cachePtr; int bucket; { register Block *blockPtr; register int n; | < | | | | | | | 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 | static int GetBlocks(cachePtr, bucket) Cache *cachePtr; int bucket; { register Block *blockPtr; register int n; /* * First, atttempt to move blocks from the shared cache. Note the * potentially dirty read of numFree before acquiring the lock which is a * slight performance enhancement. The value is verified after the lock is * actually acquired. */ if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) { LockBucket(cachePtr, bucket); if (sharedPtr->buckets[bucket].numFree > 0) { /* * Either move the entire list or walk the list to find the last * block to move. */ n = bucketInfo[bucket].numMove; if (n >= sharedPtr->buckets[bucket].numFree) { cachePtr->buckets[bucket].firstPtr = sharedPtr->buckets[bucket].firstPtr; cachePtr->buckets[bucket].numFree = |
︙ | ︙ | |||
905 906 907 908 909 910 911 912 913 | blockPtr->nextBlock = NULL; } } UnlockBucket(cachePtr, bucket); } if (cachePtr->buckets[bucket].numFree == 0) { /* | > | | | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 | blockPtr->nextBlock = NULL; } } UnlockBucket(cachePtr, bucket); } if (cachePtr->buckets[bucket].numFree == 0) { register size_t size; /* * If no blocks could be moved from shared, first look for a larger * block in this cache to split up. */ blockPtr = NULL; n = NBUCKETS; size = 0; /* lint */ while (--n > bucket) { if (cachePtr->buckets[n].numFree > 0) { |
︙ | ︙ | |||
958 959 960 961 962 963 964 | } /* *---------------------------------------------------------------------- * * TclFinalizeThreadAlloc -- * | | | | > > < | | > | | > > > > > > | 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 | } /* *---------------------------------------------------------------------- * * TclFinalizeThreadAlloc -- * * This procedure is used to destroy all private resources used in this * file. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TclFinalizeThreadAlloc() { int i; for (i = 0; i < NBUCKETS; ++i) { TclpFreeAllocMutex(bucketInfo[i].lockPtr); bucketInfo[i].lockPtr = NULL; } TclpFreeAllocMutex(objLockPtr); objLockPtr = NULL; TclpFreeAllocMutex(listLockPtr); listLockPtr = NULL; TclpFreeAllocCache(NULL); } #else /* *---------------------------------------------------------------------- * * TclFinalizeThreadAlloc -- * * This procedure is used to destroy all private resources used in this * file. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TclFinalizeThreadAlloc() { Tcl_Panic("TclFinalizeThreadAlloc called when threaded memory allocator not in use."); } #endif /* TCL_THREADS */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclThreadJoin.c.
|
| | | | | | | | | | > | | | | | | < | | | | | < | | < | | | | | < | > | | > | | | < < | | | | | | | > > > | | | < < | | | | < < | > | > | | | | > | | | | | | > | | | | < | > | | > | | | | | | | | | > | | | | | < | | < < | | > | | | | | | > | | | | | | | < | < | | | | | | | | | | | | | | | | | | | < < | > | > | | > | | | | | | | | | > | | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 | /* * tclThreadJoin.c -- * * This file implements a platform independent emulation layer for the * handling of joinable threads. The Windows platform uses this code to * provide the functionality of joining threads. This code is currently * not necessary on Unix. * * Copyright (c) 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: tclThreadJoin.c,v 1.5.2.1 2005/08/02 18:16:10 dgp Exp $ */ #include "tclInt.h" #ifdef WIN32 /* * The information about each joinable thread is remembered in a structure as * defined below. */ typedef struct JoinableThread { Tcl_ThreadId id; /* The id of the joinable thread. */ int result; /* A place for the result after the demise of * the thread. */ int done; /* Boolean flag. Initialized to 0 and set to 1 * after the exit of the thread. This allows a * thread requesting a join to detect when * waiting is not necessary. */ int waitedUpon; /* Boolean flag. Initialized to 0 and set to 1 * by the thread waiting for this one via * Tcl_JoinThread. Used to lock any other * thread trying to wait on this one. */ Tcl_Mutex threadMutex; /* The mutex used to serialize access to this * structure. */ Tcl_Condition cond; /* This is the condition a thread has to wait * upon to get notified of the end of the * described thread. It is signaled indirectly * by Tcl_ExitThread. */ struct JoinableThread *nextThreadPtr; /* Reference to the next thread in the list of * joinable threads. */ } JoinableThread; /* * The following variable is used to maintain the global list of all joinable * threads. Usage by a thread is allowed only if the thread acquired the * 'joinMutex'. */ TCL_DECLARE_MUTEX(joinMutex) static JoinableThread* firstThreadPtr; /* *---------------------------------------------------------------------- * * TclJoinThread -- * * This procedure waits for the exit of the thread with the specified id * and returns its result. * * Results: * A standard tcl result signaling the overall success/failure of the * operation and an integer result delivered by the thread which was * waited upon. * * Side effects: * Deallocates the memory allocated by TclRememberJoinableThread. * Removes the data associated to the thread waited upon from the list of * joinable threads. * *---------------------------------------------------------------------- */ int TclJoinThread(id, result) Tcl_ThreadId id; /* The id of the thread to wait upon. */ int *result; /* Reference to a location for the result of * the thread we are waiting upon. */ { JoinableThread *threadPtr; /* * Steps done here: * i. Acquire the joinMutex and search for the thread. * ii. Error out if it could not be found. * iii. If found, switch from exclusive access to the list to exclusive * access to the thread structure. * iv. Error out if some other is already waiting. * v. Skip the waiting part of the thread is already done. * vi. Wait for the thread to exit, mark it as waited upon too. * vii. Get the result form the structure, * viii. switch to exclusive access of the list, * ix. remove the structure from the list, * x. then switch back to exclusive access to the structure * xi. and delete it. */ Tcl_MutexLock(&joinMutex); threadPtr = firstThreadPtr; while (threadPtr!=NULL && threadPtr->id!=id) { threadPtr = threadPtr->nextThreadPtr; } if (threadPtr == NULL) { /* * Thread not found. Either not joinable, or already waited upon and * exited. Whatever, an error is in order. */ Tcl_MutexUnlock(&joinMutex); return TCL_ERROR; } /* * [1] If we don't lock the structure before giving up exclusive access to * the list some other thread just completing its wait on the same thread * can delete the structure from under us, leaving us with a dangling * pointer. */ Tcl_MutexLock(&threadPtr->threadMutex); Tcl_MutexUnlock(&joinMutex); /* * [2] Now that we have the structure mutex any other thread that just * tries to delete structure will wait at location [3] until we are done * with the structure. And in that case we are done with it rather quickly * as 'waitedUpon' will be set and we will have to error out. */ if (threadPtr->waitedUpon) { Tcl_MutexUnlock(&threadPtr->threadMutex); return TCL_ERROR; } /* * We are waiting now, let other threads recognize this. */ threadPtr->waitedUpon = 1; while (!threadPtr->done) { Tcl_ConditionWait(&threadPtr->cond, &threadPtr->threadMutex, NULL); } /* * We have to release the structure before trying to access the list again * or we can run into deadlock with a thread at [1] (see above) because of * us holding the structure and the other holding the list. There is no * problem with dangling pointers here as 'waitedUpon == 1' is still valid * and any other thread will error out and not come to this place. IOW, * the fact that we are here also means that no other thread came here * before us and is able to delete the structure. */ Tcl_MutexUnlock(&threadPtr->threadMutex); Tcl_MutexLock(&joinMutex); /* * We have to search the list again as its structure may (may, almost * certainly) have changed while we were waiting. Especially now is the * time to compute the predecessor in the list. Any earlier result can be * dangling by now. */ if (firstThreadPtr == threadPtr) { firstThreadPtr = threadPtr->nextThreadPtr; } else { JoinableThread *prevThreadPtr = firstThreadPtr; while (prevThreadPtr->nextThreadPtr != threadPtr) { prevThreadPtr = prevThreadPtr->nextThreadPtr; } prevThreadPtr->nextThreadPtr = threadPtr->nextThreadPtr; } Tcl_MutexUnlock(&joinMutex); /* * [3] Now that the structure is not part of the list anymore no other * thread can acquire its mutex from now on. But it is possible that * another thread is still holding the mutex though, see location [2]. So * we have to acquire the mutex one more time to wait for that thread to * finish. We can (and have to) release the mutex immediately. */ Tcl_MutexLock(&threadPtr->threadMutex); Tcl_MutexUnlock(&threadPtr->threadMutex); /* * Copy the result to us, finalize the synchronisation objects, then free * the structure and return. */ *result = threadPtr->result; Tcl_ConditionFinalize(&threadPtr->cond); Tcl_MutexFinalize(&threadPtr->threadMutex); ckfree((char *) threadPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclRememberJoinableThread -- * * This procedure remebers a thread as joinable. Only a call to * TclJoinThread will remove the structre created (and initialized) here. * IOW, not waiting upon a joinable thread will cause memory leaks. * * Results: * None. * * Side effects: * Allocates memory, adds it to the global list of all joinable threads. * *---------------------------------------------------------------------- */ VOID TclRememberJoinableThread(id) Tcl_ThreadId id; /* The thread to remember as joinable */ { JoinableThread *threadPtr; threadPtr = (JoinableThread *) ckalloc(sizeof(JoinableThread)); threadPtr->id = id; threadPtr->done = 0; threadPtr->waitedUpon = 0; threadPtr->threadMutex = (Tcl_Mutex) NULL; threadPtr->cond = (Tcl_Condition) NULL; Tcl_MutexLock(&joinMutex); threadPtr->nextThreadPtr = firstThreadPtr; firstThreadPtr = threadPtr; Tcl_MutexUnlock(&joinMutex); } /* *---------------------------------------------------------------------- * * TclSignalExitThread -- * * This procedure signals that the specified thread is done with its * work. If the thread is joinable this signal is propagated to the * thread waiting upon it. * * Results: * None. * * Side effects: * Modifies the associated structure to hold the result. * *---------------------------------------------------------------------- */ VOID TclSignalExitThread(id,result) Tcl_ThreadId id; /* Id of the thread signaling its exit. */ int result; /* The result from the thread. */ { JoinableThread *threadPtr; Tcl_MutexLock(&joinMutex); threadPtr = firstThreadPtr; while ((threadPtr != NULL) && (threadPtr->id != id)) { threadPtr = threadPtr->nextThreadPtr; } if (threadPtr == NULL) { /* * Thread not found. Not joinable. No problem, nothing to do. */ Tcl_MutexUnlock(&joinMutex); return; } /* * Switch over the exclusive access from the list to the structure, then * store the result, set the flag and notify the waiting thread, provided * that it exists. The order of lock/unlock ensures that a thread entering * 'TclJoinThread' will not interfere with us. */ Tcl_MutexLock(&threadPtr->threadMutex); Tcl_MutexUnlock(&joinMutex); threadPtr->done = 1; threadPtr->result = result; if (threadPtr->waitedUpon) { Tcl_ConditionNotify(&threadPtr->cond); } Tcl_MutexUnlock(&threadPtr->threadMutex); } #endif /* WIN32 */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclThreadStorage.c.
1 2 3 4 5 6 7 | /* * tclThreadStorage.c -- * * This file implements platform independent thread storage operations. * * Copyright (c) 2003-2004 by Joe Mistachkin * | | | | | | | | | | < | | | | | | | | | | > | > | | | | | | | | | | | < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | 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 | /* * tclThreadStorage.c -- * * This file implements platform independent thread storage operations. * * Copyright (c) 2003-2004 by Joe Mistachkin * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclThreadStorage.c,v 1.4.4.2 2005/08/15 18:13:59 dgp Exp $ */ #include "tclInt.h" #if defined(TCL_THREADS) /* * This is the thread storage cache array and it's accompanying mutex. The * elements are pairs of thread Id and an associated hash table pointer; the * hash table being pointed to contains the thread storage for it's associated * thread. The purpose of this cache is to minimize the number of hash table * lookups in the master thread storage hash table. */ static Tcl_Mutex threadStorageLock; /* * This is the struct used for a thread storage cache slot. It contains the * owning thread Id and the associated hash table pointer. */ typedef struct ThreadStorage { Tcl_ThreadId id; /* the owning thread id */ Tcl_HashTable *hashTablePtr;/* the hash table for the thread */ } ThreadStorage; /* * These are the prototypes for the custom hash table allocation functions * used by the thread storage subsystem. */ static Tcl_HashEntry * AllocThreadStorageEntry(Tcl_HashTable *tablePtr, void *keyPtr); static void FreeThreadStorageEntry(Tcl_HashEntry *hPtr); static Tcl_HashTable * ThreadStorageGetHashTable(Tcl_ThreadId id); /* * This is the hash key type for thread storage. We MUST use this in * combination with the new hash key type flag TCL_HASH_KEY_SYSTEM_HASH * because these hash tables MAY be used by the threaded memory allocator. */ Tcl_HashKeyType tclThreadStorageHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ TCL_HASH_KEY_SYSTEM_HASH | TCL_HASH_KEY_RANDOMIZE_HASH, /* flags */ NULL, /* hashKeyProc */ NULL, /* compareKeysProc */ AllocThreadStorageEntry, /* allocEntryProc */ FreeThreadStorageEntry /* freeEntryProc */ }; /* * This is an invalid thread value. */ #define STORAGE_INVALID_THREAD (Tcl_ThreadId)0 /* * This is the value for an invalid thread storage key. */ #define STORAGE_INVALID_KEY 0 /* * This is the first valid key for use by external callers. All the values * below this are RESERVED for future use. */ #define STORAGE_FIRST_KEY 1 /* * This is the default number of thread storage cache slots. This define may * need to be fine tuned for maximum performance. */ #define STORAGE_CACHE_SLOTS 97 /* * This is the master thread storage hash table. It is keyed on thread Id and * contains values that are hash tables for each thread. The thread specific * hash tables contain the actual thread storage. */ static Tcl_HashTable threadStorageHashTable; /* * This is the next thread data key value to use. We increment this everytime * we "allocate" one. It is initially set to 1 in TclInitThreadStorage. */ static int nextThreadStorageKey = STORAGE_INVALID_KEY; /* * This is the master thread storage cache. Per Kevin Kenny's idea, this * prevents unnecessary lookups for threads that use a lot of thread storage. */ static volatile ThreadStorage threadStorageCache[STORAGE_CACHE_SLOTS]; /* *---------------------------------------------------------------------- * * AllocThreadStorageEntry -- * * Allocate space for a Tcl_HashEntry using TclpSysAlloc (not ckalloc). * We do this because the threaded memory allocator MAY use the thread * storage hash tables. * * Results: * The return value is a pointer to the created entry. * * Side effects: * None. * |
︙ | ︙ | |||
229 230 231 232 233 234 235 | } /* *---------------------------------------------------------------------- * * FreeThreadStorageEntry -- * | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | < < < < < < < | | | | | | | | | > | | | | | > | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | < < < < < < | | | < < | < < < < > < | > > > > > > > > > > > < < < < < < < < | | < < < < | < < < < < | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | < < < < < | | | < < < < < < | < | | | | < | | | | | | < | < < < < < | > | < < < < | | | > | < > > < | | > > > > > | | | | | > | | | | | < < < < < < < < < < < < < < < | < < | | | | | | | | | | < | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | < < < | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < | | < | | | < < < < < < < < < < < < < < < < | < < < | < < < < < < < < < < < < < < < < < < | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < > > > > > > > > | 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 | } /* *---------------------------------------------------------------------- * * FreeThreadStorageEntry -- * * Frees space for a Tcl_HashEntry using TclpSysFree (not ckfree). We do * this because the threaded memory allocator MAY use the thread storage * hash tables. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void FreeThreadStorageEntry(hPtr) Tcl_HashEntry *hPtr; /* Hash entry to free. */ { TclpSysFree((char *)hPtr); } /* *---------------------------------------------------------------------- * * ThreadStorageGetHashTable -- * * This procedure returns a hash table pointer to be used for thread * storage for the specified thread. * * This assumes that thread storage lock is held. * * Results: * A hash table pointer for the specified thread, or NULL if the hash * table has not been created yet. * * Side effects: * May change an entry in the master thread storage cache to point to the * specified thread and it's associated hash table. * *---------------------------------------------------------------------- */ static Tcl_HashTable * ThreadStorageGetHashTable(id) Tcl_ThreadId id; /* Id of thread to get hash table for */ { int index = (unsigned int)id % STORAGE_CACHE_SLOTS; Tcl_HashEntry *hPtr; int new; /* * It's important that we pick up the hash table pointer BEFORE comparing * thread Id in case another thread is in the critical region changing * things out from under you. */ Tcl_HashTable *hashTablePtr = threadStorageCache[index].hashTablePtr; if (threadStorageCache[index].id != id) { Tcl_MutexLock(&threadStorageLock); /* * It's not in the cache, so we look it up... */ hPtr = Tcl_FindHashEntry(&threadStorageHashTable, (char *)id); if (hPtr != NULL) { /* * We found it, extract the hash table pointer. */ hashTablePtr = Tcl_GetHashValue(hPtr); } else { /* * The thread specific hash table is not found. */ hashTablePtr = NULL; } if (hashTablePtr == NULL) { hashTablePtr = (Tcl_HashTable *) TclpSysAlloc(sizeof(Tcl_HashTable), 0); if (hashTablePtr == NULL) { Tcl_Panic("could not allocate thread specific hash " "table, TclpSysAlloc failed from " "ThreadStorageGetHashTable!"); } Tcl_InitCustomHashTable(hashTablePtr, TCL_CUSTOM_TYPE_KEYS, &tclThreadStorageHashKeyType); /* * Add new thread storage hash table to the master hash table. */ hPtr = Tcl_CreateHashEntry(&threadStorageHashTable, (char *)id, &new); if (hPtr == NULL) { Tcl_Panic("Tcl_CreateHashEntry failed from " "ThreadStorageGetHashTable!"); } Tcl_SetHashValue(hPtr, hashTablePtr); } /* * Now, we put it in the cache since it is highly likely it will * be needed again shortly. */ threadStorageCache[index].id = id; threadStorageCache[index].hashTablePtr = hashTablePtr; Tcl_MutexUnlock(&threadStorageLock); } return hashTablePtr; } /* *---------------------------------------------------------------------- * * TclInitThreadStorage -- * * Initializes the thread storage allocator. * * Results: * None. * * Side effects: * This procedure initializes the master hash table that maps * thread ID onto the individual index tables that map thread data * key to thread data. It also creates a cache that enables * fast lookup of the thread data block array for a recently * executing thread without using spinlocks. * * This procedure is called from an extremely early point in Tcl's * initialization. In particular, it may not use ckalloc/ckfree * because they may depend on thread-local storage (it uses TclpSysAlloc * and TclpSysFree instead). It may not depend on synchronization * primitives - but no threads other than the master thread have yet * been launched. * *---------------------------------------------------------------------- */ void TclInitThreadStorage() { Tcl_InitCustomHashTable(&threadStorageHashTable, TCL_CUSTOM_TYPE_KEYS, &tclThreadStorageHashKeyType); /* * We also initialize the cache. */ memset((ThreadStorage *)&threadStorageCache, 0, sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS); /* * Now, we set the first value to be used for a thread data key. */ nextThreadStorageKey = STORAGE_FIRST_KEY; } /* *---------------------------------------------------------------------- * * TclpThreadDataKeyGet -- * * This procedure returns a pointer to a block of thread local storage. * * Results: * A thread-specific pointer to the data structure, or NULL if the memory * has not been assigned to this key for this thread. * * Side effects: * None. * *---------------------------------------------------------------------- */ void * TclpThreadDataKeyGet(keyPtr) Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really * (int**) */ { Tcl_HashTable *hashTablePtr = ThreadStorageGetHashTable(Tcl_GetCurrentThread()); Tcl_HashEntry *hPtr = Tcl_FindHashEntry(hashTablePtr, (char *) keyPtr); if (hPtr == NULL) { return NULL; } return (void *) Tcl_GetHashValue(hPtr); } /* *---------------------------------------------------------------------- * * TclpThreadDataKeySet -- * * This procedure sets the pointer to a block of thread local storage. * * Results: * None. * * Side effects: * Sets up the thread so future calls to TclpThreadDataKeyGet with * this key will return the data pointer. * *---------------------------------------------------------------------- */ void TclpThreadDataKeySet(keyPtr, data) Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really * (pthread_key_t **) */ void *data; /* Thread local storage */ { Tcl_HashTable *hashTablePtr; Tcl_HashEntry *hPtr; hashTablePtr = ThreadStorageGetHashTable(Tcl_GetCurrentThread()); hPtr = Tcl_FindHashEntry(hashTablePtr, (char *)keyPtr); /* * Does the item need to be created? */ if (hPtr == NULL) { int new; hPtr = Tcl_CreateHashEntry(hashTablePtr, (char *)keyPtr, &new); } Tcl_SetHashValue(hPtr, data); } /* *---------------------------------------------------------------------- * * TclpFinalizeThreadDataThread -- * * This procedure cleans up the thread storage hash table for the * current thread. * * Results: * None. * * Side effects: * Frees all associated thread storage, all hash table entries for * the thread's thread storage, and the hash table itself. * *---------------------------------------------------------------------- */ void TclpFinalizeThreadDataThread() { Tcl_ThreadId id = Tcl_GetCurrentThread(); /* Id of the thread to finalize. */ int index = (unsigned int)id % STORAGE_CACHE_SLOTS; Tcl_HashEntry *hPtr; /* Hash entry for current thread in master * table. */ Tcl_HashTable* hashTablePtr; /* Pointer to the hash table holding * TSD blocks for the current thread*/ Tcl_HashSearch search; /* Search object to walk the TSD blocks * in the designated thread */ Tcl_HashEntry *hPtr2; /* Hash entry for a TSD block in the * designated thread. */ Tcl_MutexLock(&threadStorageLock); hPtr = Tcl_FindHashEntry(&threadStorageHashTable, (char*)id); if (hPtr == NULL) { hashTablePtr = NULL; } else { /* * We found it, extract the hash table pointer. */ hashTablePtr = Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); /* * Make sure cache entry for this thread is NULL. */ if (threadStorageCache[index].id == id) { /* * We do not step on another thread's cache entry. This is * especially important if we are creating and exiting a lot * of threads. */ threadStorageCache[index].id = STORAGE_INVALID_THREAD; threadStorageCache[index].hashTablePtr = NULL; } } Tcl_MutexUnlock(&threadStorageLock); /* * The thread's hash table has been extracted and removed from the master * hash table. Now clean up the thread. */ if (hashTablePtr != NULL) { /* Free all TSD */ for (hPtr2 = Tcl_FirstHashEntry(hashTablePtr, &search); hPtr2 != NULL; hPtr2 = Tcl_NextHashEntry(&search)) { void* blockPtr = Tcl_GetHashValue(hPtr2); if (blockPtr != NULL) { /* * The block itself was allocated in Tcl_GetThreadData * using ckalloc; use ckfree to dispose of it. */ ckfree(blockPtr); } } /* * Delete thread specific hash table and free the struct. */ Tcl_DeleteHashTable(hashTablePtr); TclpSysFree((char *)hashTablePtr); } } /* *---------------------------------------------------------------------- * * TclFinalizeThreadStorage -- * * This procedure cleans up the master thread storage hash table, all * thread specific hash tables, and the thread storage cache. * * Results: * None. * * Side effects: * The master thread storage hash table and thread storage cache are * reset to their initial (empty) state. * *---------------------------------------------------------------------- */ void TclFinalizeThreadStorage() { Tcl_HashSearch search; /* We need to hit every thread with * this search. */ Tcl_HashEntry *hPtr; /* Hash entry for current thread in * master table. */ Tcl_MutexLock(&threadStorageLock); /* * We are going to delete the hash table for every thread now. This * hash table should be empty at this point, except for one entry for * the current thread. */ for (hPtr = Tcl_FirstHashEntry(&threadStorageHashTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_HashTable *hashTablePtr = Tcl_GetHashValue(hPtr); if (hashTablePtr != NULL) { /* * Delete thread specific hash table for the thread in * question and free the struct. */ Tcl_DeleteHashTable(hashTablePtr); TclpSysFree((char *)hashTablePtr); } /* * Delete thread specific entry from master hash table. */ Tcl_SetHashValue(hPtr, NULL); } Tcl_DeleteHashTable(&threadStorageHashTable); /* * Clear out the thread storage cache as well. */ memset((ThreadStorage *)&threadStorageCache, 0, sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS); /* * Reset this to zero, it will be set to STORAGE_FIRST_KEY if the thread * storage subsystem gets reinitialized */ nextThreadStorageKey = STORAGE_INVALID_KEY; Tcl_MutexUnlock(&threadStorageLock); } #else /* !defined(TCL_THREADS) */ /* * Stub functions for non-threaded builds */ void TclInitThreadStorage() { } void TclpFinalizeThreadDataThread() { } void TclFinalizeThreadStorage() { } #endif /* defined(TCL_THREADS) && defined(USE_THREAD_STORAGE) */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclThreadTest.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclThreadTest.c -- * * This file implements the testthread command. Eventually this * should be tclThreadCmd.c * Some of this code is based on work done by Richard Hipp on behalf of * Conservation Through Innovation, Limited, with their permission. * * Copyright (c) 1998 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | /* * tclThreadTest.c -- * * This file implements the testthread command. Eventually this * should be tclThreadCmd.c * Some of this code is based on work done by Richard Hipp on behalf of * Conservation Through Innovation, Limited, with their permission. * * Copyright (c) 1998 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclThreadTest.c,v 1.17.2.4 2005/09/26 20:16:53 kennykb Exp $ */ #include "tclInt.h" extern int Tcltest_Init( Tcl_Interp* ); #ifdef TCL_THREADS /* * Each thread has an single instance of the following structure. There * is one instance of this structure per thread even if that thread contains * multiple interpreters. The interpreter identified by this structure is * the main interpreter for the thread. |
︙ | ︙ | |||
132 133 134 135 136 137 138 139 140 141 142 143 144 145 | static int ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask)); static void ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp)); static void ThreadFreeProc _ANSI_ARGS_((ClientData clientData)); static int ThreadDeleteEvent _ANSI_ARGS_((Tcl_Event *eventPtr, ClientData clientData)); static void ThreadExitProc _ANSI_ARGS_((ClientData clientData)); /* *---------------------------------------------------------------------- * * TclThread_Init -- * * Initialize the test thread command. | > > > > > > | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 | static int ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask)); static void ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp)); static void ThreadFreeProc _ANSI_ARGS_((ClientData clientData)); static int ThreadDeleteEvent _ANSI_ARGS_((Tcl_Event *eventPtr, ClientData clientData)); static void ThreadExitProc _ANSI_ARGS_((ClientData clientData)); /* Forward declaration of function import from "tclTest.c". */ int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); /* *---------------------------------------------------------------------- * * TclThread_Init -- * * Initialize the test thread command. |
︙ | ︙ | |||
156 157 158 159 160 161 162 | int TclThread_Init(interp) Tcl_Interp *interp; /* The current Tcl interpreter */ { Tcl_CreateObjCommand(interp,"testthread", Tcl_ThreadObjCmd, (ClientData)NULL ,NULL); | < < < | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 | int TclThread_Init(interp) Tcl_Interp *interp; /* The current Tcl interpreter */ { Tcl_CreateObjCommand(interp,"testthread", Tcl_ThreadObjCmd, (ClientData)NULL ,NULL); return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
478 479 480 481 482 483 484 485 486 487 488 489 490 491 | * Initialize the interpreter. This should be more general. */ tsdPtr->interp = Tcl_CreateInterp(); result = Tcl_Init(tsdPtr->interp); result = TclThread_Init(tsdPtr->interp); /* * Update the list of threads. */ Tcl_MutexLock(&threadMutex); ListUpdateInner(tsdPtr); /* | > > > > > > | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 | * Initialize the interpreter. This should be more general. */ tsdPtr->interp = Tcl_CreateInterp(); result = Tcl_Init(tsdPtr->interp); result = TclThread_Init(tsdPtr->interp); /* This is part of the test facility. * Initialize _ALL_ test commands for * use by the new thread. */ result = Tcltest_Init(tsdPtr->interp); /* * Update the list of threads. */ Tcl_MutexLock(&threadMutex); ListUpdateInner(tsdPtr); /* |
︙ | ︙ |
Changes to generic/tclTimer.c.
|
| | | | | | | | | | < | > | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | /* * tclTimer.c -- * * This file provides timer event management facilities for Tcl, * including the "after" command. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclTimer.c,v 1.12.2.6 2005/10/08 13:44:37 dgp Exp $ */ #include "tclInt.h" /* * For each timer callback that's pending there is one record of the following * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained * together in a list sorted by time (earliest event first). */ typedef struct TimerHandler { Tcl_Time time; /* When timer is to fire. */ Tcl_TimerProc *proc; /* Function to call. */ ClientData clientData; /* Argument to pass to proc. */ Tcl_TimerToken token; /* Identifies handler so it can be deleted. */ struct TimerHandler *nextPtr; /* Next event in queue, or NULL for end of * queue. */ } TimerHandler; /* * The data structure below is used by the "after" command to remember the * command to be executed later. All of the pending "after" commands for an * interpreter are linked together in a list. */ typedef struct AfterInfo { struct AfterAssocData *assocPtr; /* Pointer to the "tclAfter" assocData for the * interp in which command will be * executed. */ Tcl_Obj *commandPtr; /* Command to execute. */ int id; /* Integer identifier for command; used to * cancel it. */ Tcl_TimerToken token; /* Used to cancel the "after" command. NULL * means that the command is run as an idle * handler rather than as a timer handler. * NULL means this is an "after idle" handler * rather than a timer handler. */ struct AfterInfo *nextPtr; /* Next in list of all "after" commands for * this interpreter. */ } AfterInfo; /* * One of the following structures is associated with each interpreter for * which an "after" command has ever been invoked. A pointer to this structure * is stored in the AssocData for the "tclAfter" key. */ typedef struct AfterAssocData { Tcl_Interp *interp; /* The interpreter for which this data is * registered. */ AfterInfo *firstAfterPtr; /* First in list of all "after" commands still * pending for this interpreter, or NULL if * none. */ } AfterAssocData; /* * There is one of the following structures for each of the handlers declared * in a call to Tcl_DoWhenIdle. All of the currently-active handlers are * linked together into a list. */ typedef struct IdleHandler { Tcl_IdleProc (*proc); /* Function to call. */ ClientData clientData; /* Value to pass to proc. */ int generation; /* Used to distinguish older handlers from * recently-created ones. */ struct IdleHandler *nextPtr;/* Next in list of active handlers. */ } IdleHandler; /* * The timer and idle queues are per-thread because they are associated with * the notifier, which is also per-thread. * * All static variables used in this file are collected into a single instance * of the following structure. For multi-threaded implementations, there is * one instance of this structure for each thread. * * Notice that different structures with the same name appear in other files. * The structure defined below is used in this file only. */ typedef struct ThreadSpecificData { TimerHandler *firstTimerHandlerPtr; /* First event in queue. */ int lastTimerId; /* Timer identifier of most recently created * timer. */ int timerPending; /* 1 if a timer event is in the queue. */ IdleHandler *idleList; /* First in list of all idle handlers. */ IdleHandler *lastIdlePtr; /* Last in list (or NULL for empty list). */ int idleGeneration; /* Used to fill in the "generation" fields of * IdleHandler structures. Increments each * time Tcl_DoOneEvent starts calling idle * handlers, so that all old handlers can be * called without calling any of the new ones * created by old ones. */ int afterId; /* For unique identifiers of after events. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * Helper macros for working with times. TCL_TIME_BEFORE encodes how to write * the ordering relation on (normalized) times, and TCL_TIME_DIFF_MS computes * the number of milliseconds difference between two times. Both macros use * both of their arguments multiple times, so make sure they are cheap and * side-effect free. The "prototypes" for these macros are: * * static int TCL_TIME_BEFORE(Tcl_Time t1, Tcl_Time t2); * static long TCL_TIME_DIFF_MS(Tcl_Time t1, Tcl_Time t2); */ #define TCL_TIME_BEFORE(t1, t2) \ (((t1).sec<(t2).sec) || ((t1).sec==(t2).sec && (t1).usec<(t2).usec)) #define TCL_TIME_DIFF_MS(t1, t2) \ (1000*((long)(t1).sec - (long)(t2).sec) + \ ((long)(t1).usec - (long)(t2).usec)/1000) /* * Prototypes for functions referenced only in this file: */ static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); static int AfterDelay _ANSI_ARGS_((Tcl_Interp *interp, int ms)); static void AfterProc _ANSI_ARGS_((ClientData clientData)); static void FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr)); static AfterInfo * GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr, Tcl_Obj *commandPtr)); static ThreadSpecificData *InitTimer _ANSI_ARGS_((void)); static void TimerExitProc _ANSI_ARGS_((ClientData clientData)); static int TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, |
︙ | ︙ | |||
146 147 148 149 150 151 152 | * *---------------------------------------------------------------------- */ static ThreadSpecificData * InitTimer() { | | | | | | | > | | | | | < | | | < < < < < < | | | | | > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | < < | 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 | * *---------------------------------------------------------------------- */ static ThreadSpecificData * InitTimer() { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL); Tcl_CreateThreadExitHandler(TimerExitProc, NULL); } return tsdPtr; } /* *---------------------------------------------------------------------- * * TimerExitProc -- * * This function is call at exit or unload time to remove the timer and * idle event sources. * * Results: * None. * * Side effects: * Removes the timer and idle event sources and remaining events. * *---------------------------------------------------------------------- */ static void TimerExitProc(clientData) ClientData clientData; /* Not used. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL); if (tsdPtr != NULL) { register TimerHandler *timerHandlerPtr; timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; while (timerHandlerPtr != NULL) { tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; ckfree((char *) timerHandlerPtr); timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; } } } /* *-------------------------------------------------------------- * * Tcl_CreateTimerHandler -- * * Arrange for a given function to be invoked at a particular time in the * future. * * Results: * The return value is a token for the timer event, which may be used to * delete the event before it fires. * * Side effects: * When milliseconds have elapsed, proc will be invoked exactly once. * *-------------------------------------------------------------- */ Tcl_TimerToken Tcl_CreateTimerHandler(milliseconds, proc, clientData) int milliseconds; /* How many milliseconds to wait before * invoking proc. */ Tcl_TimerProc *proc; /* Function to invoke. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { Tcl_Time time; /* * Compute when the event should fire. */ Tcl_GetTime(&time); time.sec += milliseconds/1000; time.usec += (milliseconds%1000)*1000; if (time.usec >= 1000000) { time.usec -= 1000000; time.sec += 1; } return TclCreateAbsoluteTimerHandler(&time, proc, clientData); } /* *-------------------------------------------------------------- * * TclCreateAbsoluteTimerHandler -- * * Arrange for a given function to be invoked at a particular time in the * future. * * Results: * The return value is a token for the timer event, which may be used to * delete the event before it fires. * * Side effects: * When the time in timePtr has been reached, proc will be invoked * exactly once. * *-------------------------------------------------------------- */ Tcl_TimerToken TclCreateAbsoluteTimerHandler(timePtr, proc, clientData) Tcl_Time *timePtr; Tcl_TimerProc *proc; ClientData clientData; { register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; ThreadSpecificData *tsdPtr; tsdPtr = InitTimer(); timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); /* * Fill in fields for the event. */ memcpy((void *)&timerHandlerPtr->time, (void *)timePtr, sizeof(Tcl_Time)); timerHandlerPtr->proc = proc; timerHandlerPtr->clientData = clientData; tsdPtr->lastTimerId++; timerHandlerPtr->token = (Tcl_TimerToken) tsdPtr->lastTimerId; /* * Add the event to the queue in the correct position * (ordered by event firing time). */ for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) { if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) { break; } } timerHandlerPtr->nextPtr = tPtr2; if (prevPtr == NULL) { tsdPtr->firstTimerHandlerPtr = timerHandlerPtr; } else { |
︙ | ︙ | |||
284 285 286 287 288 289 290 | * * Delete a previously-registered timer handler. * * Results: * None. * * Side effects: | | < | | | > > > | | 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 | * * Delete a previously-registered timer handler. * * Results: * None. * * Side effects: * Destroy the timer callback identified by TimerToken, so that its * associated function will not be called. If the callback has already * fired, or if the given token doesn't exist, then nothing happens. * *-------------------------------------------------------------- */ void Tcl_DeleteTimerHandler(token) Tcl_TimerToken token; /* Result previously returned by * Tcl_DeleteTimerHandler. */ { register TimerHandler *timerHandlerPtr, *prevPtr; ThreadSpecificData *tsdPtr = InitTimer(); if (token == NULL) { return; } for (timerHandlerPtr = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; timerHandlerPtr != NULL; prevPtr = timerHandlerPtr, timerHandlerPtr = timerHandlerPtr->nextPtr) { if (timerHandlerPtr->token != token) { continue; } if (prevPtr == NULL) { |
︙ | ︙ | |||
322 323 324 325 326 327 328 | } /* *---------------------------------------------------------------------- * * TimerSetupProc -- * | | | | | 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 | } /* *---------------------------------------------------------------------- * * TimerSetupProc -- * * This function is called by Tcl_DoOneEvent to setup the timer event * source for before blocking. This routine checks both the idle and * after timer lists. * * Results: * None. * * Side effects: * May update the maximum notifier block time. * |
︙ | ︙ | |||
372 373 374 375 376 377 378 | if (blockTime.sec < 0) { blockTime.sec = 0; blockTime.usec = 0; } } else { return; } | | | | | | 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 | if (blockTime.sec < 0) { blockTime.sec = 0; blockTime.usec = 0; } } else { return; } Tcl_SetMaxBlockTime(&blockTime); } /* *---------------------------------------------------------------------- * * TimerCheckProc -- * * This function is called by Tcl_DoOneEvent to check the timer event * source for events. This routine checks both the idle and after timer * lists. * * Results: * None. * * Side effects: * May queue an event and update the maximum notifier block time. * |
︙ | ︙ | |||
440 441 442 443 444 445 446 | } /* *---------------------------------------------------------------------- * * TimerHandlerEventProc -- * | | | | < | | | | | | | | | | | < | | | | | | | | | | | | | | | | < | | | | | | < < | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TimerHandlerEventProc -- * * This function is called by Tcl_ServiceEvent when a timer event reaches * the front of the event queue. This function handles the event by * invoking the callbacks for all timers that are ready. * * Results: * Returns 1 if the event was handled, meaning it should be removed from * the queue. Returns 0 if the event was not handled, meaning it should * stay on the queue. The only time the event isn't handled is if the * TCL_TIMER_EVENTS flag bit isn't set. * * Side effects: * Whatever the timer handler callback functions do. * *---------------------------------------------------------------------- */ static int TimerHandlerEventProc(evPtr, flags) Tcl_Event *evPtr; /* Event to service. */ int flags; /* Flags that indicate what events to handle, * such as TCL_FILE_EVENTS. */ { TimerHandler *timerHandlerPtr, **nextPtrPtr; Tcl_Time time; int currentTimerId; ThreadSpecificData *tsdPtr = InitTimer(); /* * Do nothing if timers aren't enabled. This leaves the event on the * queue, so we will get to it as soon as ServiceEvents() is called with * timers enabled. */ if (!(flags & TCL_TIMER_EVENTS)) { return 0; } /* * The code below is trickier than it may look, for the following reasons: * * 1. New handlers can get added to the list while the current one is * being processed. If new ones get added, we don't want to process * them during this pass through the list to avoid starving other event * sources. This is implemented using the token number in the handler: * new handlers will have a newer token than any of the ones currently * on the list. * 2. The handler can call Tcl_DoOneEvent, so we have to remove the * handler from the list before calling it. Otherwise an infinite loop * could result. * 3. Tcl_DeleteTimerHandler can be called to remove an element from the * list while a handler is executing, so the list could change * structure during the call. * 4. Because we only fetch the current time before entering the loop, the * only way a new timer will even be considered runnable is if its * expiration time is within the same millisecond as the current time. * This is fairly likely on Windows, since it has a course granularity * clock. Since timers are placed on the queue in time order with the * most recently created handler appearing after earlier ones with the * same expiration time, we don't have to worry about newer generation * timers appearing before later ones. */ tsdPtr->timerPending = 0; currentTimerId = tsdPtr->lastTimerId; Tcl_GetTime(&time); while (1) { nextPtrPtr = &tsdPtr->firstTimerHandlerPtr; timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; if (timerHandlerPtr == NULL) { break; } if (TCL_TIME_BEFORE(time, timerHandlerPtr->time)) { break; } /* * Bail out if the next timer is of a newer generation. */ if ((currentTimerId - (int)timerHandlerPtr->token) < 0) { break; } /* * Remove the handler from the queue before invoking it, to avoid * potential reentrancy problems. */ (*nextPtrPtr) = timerHandlerPtr->nextPtr; (*timerHandlerPtr->proc)(timerHandlerPtr->clientData); ckfree((char *) timerHandlerPtr); } TimerSetupProc(NULL, TCL_TIMER_EVENTS); return 1; } /* *-------------------------------------------------------------- * * Tcl_DoWhenIdle -- * * Arrange for proc to be invoked the next time the system is idle (i.e., * just before the next time that Tcl_DoOneEvent would have to wait for * something to happen). * * Results: * None. * * Side effects: * Proc will eventually be called, with clientData as argument. See the * manual entry for details. * *-------------------------------------------------------------- */ void Tcl_DoWhenIdle(proc, clientData) Tcl_IdleProc *proc; /* Function to invoke. */ ClientData clientData; /* Arbitrary value to pass to proc. */ { register IdleHandler *idlePtr; Tcl_Time blockTime; ThreadSpecificData *tsdPtr = InitTimer(); idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler)); |
︙ | ︙ | |||
592 593 594 595 596 597 598 | } /* *---------------------------------------------------------------------- * * Tcl_CancelIdleCall -- * | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_CancelIdleCall -- * * If there are any when-idle calls requested to a given function with * given clientData, cancel all of them. * * Results: * None. * * Side effects: * If the proc/clientData combination were on the when-idle list, they * are removed so that they will never be called. * *---------------------------------------------------------------------- */ void Tcl_CancelIdleCall(proc, clientData) Tcl_IdleProc *proc; /* Function that was previously registered. */ ClientData clientData; /* Arbitrary value to pass to proc. */ { register IdleHandler *idlePtr, *prevPtr; IdleHandler *nextPtr; ThreadSpecificData *tsdPtr = InitTimer(); for (prevPtr = NULL, idlePtr = tsdPtr->idleList; idlePtr != NULL; |
︙ | ︙ | |||
639 640 641 642 643 644 645 | } /* *---------------------------------------------------------------------- * * TclServiceIdle -- * | | | | < | | | 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 | } /* *---------------------------------------------------------------------- * * TclServiceIdle -- * * This function is invoked by the notifier when it becomes idle. It will * invoke all idle handlers that are present at the time the call is * invoked, but not those added during idle processing. * * Results: * The return value is 1 if TclServiceIdle found something to do, * otherwise return value is 0. * * Side effects: * Invokes all pending idle handlers. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
670 671 672 673 674 675 676 | return 0; } oldGeneration = tsdPtr->idleGeneration; tsdPtr->idleGeneration++; /* | | < | | | < | | | | | | | | | | 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 | return 0; } oldGeneration = tsdPtr->idleGeneration; tsdPtr->idleGeneration++; /* * The code below is trickier than it may look, for the following reasons: * * 1. New handlers can get added to the list while the current one is * being processed. If new ones get added, we don't want to process * them during this pass through the list (want to check for other work * to do first). This is implemented using the generation number in the * handler: new handlers will have a different generation than any of * the ones currently on the list. * 2. The handler can call Tcl_DoOneEvent, so we have to remove the * handler from the list before calling it. Otherwise an infinite loop * could result. * 3. Tcl_CancelIdleCall can be called to remove an element from the list * while a handler is executing, so the list could change structure * during the call. */ for (idlePtr = tsdPtr->idleList; ((idlePtr != NULL) && ((oldGeneration - idlePtr->generation) >= 0)); idlePtr = tsdPtr->idleList) { tsdPtr->idleList = idlePtr->nextPtr; |
︙ | ︙ | |||
712 713 714 715 716 717 718 | } /* *---------------------------------------------------------------------- * * Tcl_AfterObjCmd -- * | | | | 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 | } /* *---------------------------------------------------------------------- * * Tcl_AfterObjCmd -- * * This function is invoked to process the "after" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 | int length; char *argString; int index; char buf[16 + TCL_INTEGER_SPACE]; static CONST char *afterSubCmds[] = { "cancel", "idle", "info", (char *) NULL }; enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; ThreadSpecificData *tsdPtr = InitTimer(); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } /* | > | | < < | | 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 | int length; char *argString; int index; char buf[16 + TCL_INTEGER_SPACE]; static CONST char *afterSubCmds[] = { "cancel", "idle", "info", (char *) NULL }; Tcl_Obj *objPtr; enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; ThreadSpecificData *tsdPtr = InitTimer(); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } /* * Create the "after" information associated for this interpreter, if it * doesn't already exist. */ assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL); if (assocPtr == NULL) { assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData)); assocPtr->interp = interp; assocPtr->firstAfterPtr = NULL; Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, (ClientData) assocPtr); } |
︙ | ︙ | |||
779 780 781 782 783 784 785 | goto processInteger; } argString = Tcl_GetStringFromObj(objv[1], &length); if (isdigit(UCHAR(argString[0]))) { /* INTL: digit */ if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) { return TCL_ERROR; } | | < | > | | | | | | | > > | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | 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 | goto processInteger; } argString = Tcl_GetStringFromObj(objv[1], &length); if (isdigit(UCHAR(argString[0]))) { /* INTL: digit */ if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) { return TCL_ERROR; } processInteger: if (ms < 0) { ms = 0; } if (objc == 2) { return AfterDelay(interp, ms); } afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; } else { afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); } Tcl_IncrRefCount(afterPtr->commandPtr); /* * The variable below is used to generate unique identifiers for after * commands. This id can wrap around, which can potentially cause * problems. However, there are not likely to be problems in practice, * because after commands can only be requested to about a month in * the future, and wrap-around is unlikely to occur in less than about * 1-10 years. Thus it's unlikely that any old ids will still be * around when wrap-around occurs. */ afterPtr->id = tsdPtr->afterId; tsdPtr->afterId += 1; afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc, (ClientData) afterPtr); afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; objPtr = Tcl_NewObj(); TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id); Tcl_SetObjResult(interp, objPtr); return TCL_OK; } /* * If it's not a number it must be a subcommand. Note that we're using a * custom error message here, so we do not pass an interpreter to T_GIFO. */ if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "argument", 0, &index) != TCL_OK) { Tcl_AppendResult(interp, "bad argument \"", argString, "\": must be cancel, idle, info, or a number", (char *) NULL); return TCL_ERROR; } switch ((enum afterSubCmds) index) { case AFTER_CANCEL: { Tcl_Obj *commandPtr; char *command, *tempCommand; int tempLength; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "id|command"); return TCL_ERROR; } if (objc == 3) { commandPtr = objv[2]; } else { commandPtr = Tcl_ConcatObj(objc-2, objv+2);; } command = Tcl_GetStringFromObj(commandPtr, &length); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, &tempLength); if ((length == tempLength) && (memcmp((void*) command, (void*) tempCommand, (unsigned) length) == 0)) { break; } } if (afterPtr == NULL) { afterPtr = GetAfterEvent(assocPtr, commandPtr); } if (objc != 3) { Tcl_DecrRefCount(commandPtr); } if (afterPtr != NULL) { if (afterPtr->token != NULL) { Tcl_DeleteTimerHandler(afterPtr->token); } else { Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); } FreeAfterPtr(afterPtr); } break; } case AFTER_IDLE: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "script script ..."); return TCL_ERROR; } afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; } else { afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); } Tcl_IncrRefCount(afterPtr->commandPtr); afterPtr->id = tsdPtr->afterId; tsdPtr->afterId += 1; afterPtr->token = NULL; afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); objPtr = Tcl_NewObj(); TclObjPrintf(NULL, objPtr, "after#%d", afterPtr->id); Tcl_SetObjResult(interp, objPtr); break; case AFTER_INFO: { Tcl_Obj *resultListPtr; if (objc == 2) { for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { if (assocPtr->interp == interp) { sprintf(buf, "after#%d", afterPtr->id); Tcl_AppendElement(interp, buf); } } return TCL_OK; } if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?id?"); return TCL_ERROR; } afterPtr = GetAfterEvent(assocPtr, objv[2]); if (afterPtr == NULL) { Tcl_AppendResult(interp, "event \"", Tcl_GetString(objv[2]), "\" doesn't exist", (char *) NULL); return TCL_ERROR; } resultListPtr = Tcl_NewObj(); Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr); Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( (afterPtr->token == NULL) ? "idle" : "timer", -1)); Tcl_SetObjResult(interp, resultListPtr); break; } default: Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); } return TCL_OK; } /* *---------------------------------------------------------------------- * * AfterDelay -- * * Implements the blocking delay behaviour of [after $time]. Tricky * because it has to take into account any time limit that has been set. * * Results: * Standard Tcl result code (with error set if an error occurred due to a * time limit being exceeded). * * Side effects: * May adjust the time limit granularity marker. * *---------------------------------------------------------------------- */ static int AfterDelay(interp, ms) Tcl_Interp *interp; int ms; { Interp *iPtr = (Interp *) interp; if (iPtr->limit.timeEvent != NULL) { Tcl_Time endTime, now; Tcl_GetTime(&endTime); endTime.sec += ms/1000; endTime.usec += (ms%1000)*1000; if (endTime.usec >= 1000000) { endTime.sec++; endTime.usec -= 1000000; } do { Tcl_GetTime(&now); if (TCL_TIME_BEFORE(iPtr->limit.time, now)) { iPtr->limit.granularityTicker = 0; if (Tcl_LimitCheck(interp) != TCL_OK) { return TCL_ERROR; } } if (TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { Tcl_Sleep(TCL_TIME_DIFF_MS(endTime, now)); break; } else { Tcl_Sleep(TCL_TIME_DIFF_MS(iPtr->limit.time, now)); if (Tcl_LimitCheck(interp) != TCL_OK) { return TCL_ERROR; } } } while (TCL_TIME_BEFORE(now, endTime)); } else { Tcl_Sleep(ms); } return TCL_OK; } /* *---------------------------------------------------------------------- * * GetAfterEvent -- * * This function parses an "after" id such as "after#4" and returns a * pointer to the AfterInfo structure. * * Results: * The return value is either a pointer to an AfterInfo structure, if one * is found that corresponds to "cmdString" and is for interp, or NULL if * no corresponding after event can be found. * * Side effects: * None. * *---------------------------------------------------------------------- */ static AfterInfo * GetAfterEvent(assocPtr, commandPtr) AfterAssocData *assocPtr; /* Points to "after"-related information for * this interpreter. */ Tcl_Obj *commandPtr; { char *cmdString; /* Textual identifier for after event, such as * "after#6". */ AfterInfo *afterPtr; int id; char *end; cmdString = Tcl_GetString(commandPtr); if (strncmp(cmdString, "after#", 6) != 0) { return NULL; |
︙ | ︙ | |||
981 982 983 984 985 986 987 | } /* *---------------------------------------------------------------------- * * AfterProc -- * | | | | | < | | | | | 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 | } /* *---------------------------------------------------------------------- * * AfterProc -- * * Timer callback to execute commands registered with the "after" * command. * * Results: * None. * * Side effects: * Executes whatever command was specified. If the command returns an * error, then the command "bgerror" is invoked to process the error; if * bgerror fails then information about the error is output on stderr. * *---------------------------------------------------------------------- */ static void AfterProc(clientData) ClientData clientData; /* Describes command to execute. */ { AfterInfo *afterPtr = (AfterInfo *) clientData; AfterAssocData *assocPtr = afterPtr->assocPtr; AfterInfo *prevPtr; int result; Tcl_Interp *interp; char *script; int numBytes; /* * First remove the callback from our list of callbacks; otherwise someone * could delete the callback while it's being executed, which could cause * a core dump. */ if (assocPtr->firstAfterPtr == afterPtr) { assocPtr->firstAfterPtr = afterPtr->nextPtr; } else { for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr; prevPtr = prevPtr->nextPtr) { |
︙ | ︙ | |||
1037 1038 1039 1040 1041 1042 1043 | script = Tcl_GetStringFromObj(afterPtr->commandPtr, &numBytes); result = Tcl_EvalEx(interp, script, numBytes, TCL_EVAL_GLOBAL); if (result != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); Tcl_BackgroundError(interp); } Tcl_Release((ClientData) interp); | | | | < | | 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 | script = Tcl_GetStringFromObj(afterPtr->commandPtr, &numBytes); result = Tcl_EvalEx(interp, script, numBytes, TCL_EVAL_GLOBAL); if (result != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); Tcl_BackgroundError(interp); } Tcl_Release((ClientData) interp); /* * Free the memory for the callback. */ Tcl_DecrRefCount(afterPtr->commandPtr); ckfree((char *) afterPtr); } /* *---------------------------------------------------------------------- * * FreeAfterPtr -- * * This function removes an "after" command from the list of those that * are pending and frees its resources. This function does *not* cancel * the timer handler; if that's needed, the caller must do it. * * Results: * None. * * Side effects: * The memory associated with afterPtr is released. * |
︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 | } /* *---------------------------------------------------------------------- * * AfterCleanupProc -- * | | | 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 | } /* *---------------------------------------------------------------------- * * AfterCleanupProc -- * * This function is invoked whenever an interpreter is deleted * to cleanup the AssocData for "tclAfter". * * Results: * None. * * Side effects: * After commands are removed. |
︙ | ︙ | |||
1125 1126 1127 1128 1129 1130 1131 | Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); } Tcl_DecrRefCount(afterPtr->commandPtr); ckfree((char *) afterPtr); } ckfree((char *) assocPtr); } | > > > > > > > > | 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 | Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); } Tcl_DecrRefCount(afterPtr->commandPtr); ckfree((char *) afterPtr); } ckfree((char *) assocPtr); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Added generic/tclTomMath.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | /* * tclTomMath.h -- * * Interface information that comes in at the head of * <tommath.h> to adapt the API to Tcl's linkage conventions. * * Copyright (c) 2005 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: tclTomMath.h,v 1.1.2.7 2005/09/26 20:16:53 kennykb Exp $ */ #ifndef TCLTOMMATH_H #define TCLTOMMATH_H 1 #include <tcl.h> #include <stdlib.h> /* Define TOMMATH_DLLIMPORT and TOMMATH_DLLEXPORT to suit the compiler */ #ifdef STATIC_BUILD # define TOMMATH_DLLIMPORT # define TOMMATH_DLLEXPORT #else # if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) # define TOMMATH_DLLIMPORT __declspec(dllimport) # define TOMMATH_DLLEXPORT __declspec(dllexport) # else # define TOMMATH_DLLIMPORT # define TOMMATH_DLLEXPORT # endif #endif /* Define TOMMATH_STORAGE_CLASS according to the build options. */ #undef TOMMATH_STORAGE_CLASS #ifdef BUILD_tcl # define TOMMATH_STORAGE_CLASS TOMMATH_DLLEXPORT #else # ifdef USE_TCL_STUBS # define TOMMATH_STORAGE_CLASS # else # define TOMMATH_STORAGE_CLASS TOMMATH_DLLIMPORT # endif #endif /* Define custom memory allocation for libtommath */ #define XMALLOC(x) TclBNAlloc(x) #define XFREE(x) TclBNFree(x) #define XREALLOC(x,n) TclBNRealloc(x,n) #define XCALLOC(n,x) TclBNCalloc(n,x) void* TclBNAlloc( size_t ); void* TclBNRealloc( void*, size_t ); void TclBNFree( void* ); void* TclBNCalloc( size_t, size_t ); /* Rename all global symboles in libtommath to avoid linkage conflicts */ #define KARATSUBA_MUL_CUTOFF TclBNKaratsubaMulCutoff #define KARATSUBA_SQR_CUTOFF TclBNKaratsubaSqrCutoff #define TOOM_MUL_CUTOFF TclBNToomMulCutoff #define TOOM_SQR_CUTOFF TclBNToomSqrCutoff #define mp_s_rmap TclBNMpSRmap #define bn_reverse TclBN_reverse #define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs #define fast_s_mp_sqr TclBN_fast_s_mp_sqr #define mp_add TclBN_mp_add #define mp_add_d TclBN_mp_add_d #define mp_and TclBN_mp_and #define mp_clamp TclBN_mp_clamp #define mp_clear TclBN_mp_clear #define mp_clear_multi TclBN_mp_clear_multi #define mp_cmp TclBN_mp_cmp #define mp_cmp_d TclBN_mp_cmp_d #define mp_cmp_mag TclBN_mp_cmp_mag #define mp_copy TclBN_mp_copy #define mp_count_bits TclBN_mp_count_bits #define mp_div TclBN_mp_div #define mp_div_d TclBN_mp_div_d #define mp_div_2 TclBN_mp_div_2 #define mp_div_2d TclBN_mp_div_2d #define mp_div_3 TclBN_mp_div_3 #define mp_exch TclBN_mp_exch #define mp_expt_d TclBN_mp_expt_d #define mp_grow TclBN_mp_grow #define mp_init TclBN_mp_init #define mp_init_copy TclBN_mp_init_copy #define mp_init_multi TclBN_mp_init_multi #define mp_init_set TclBN_mp_init_set #define mp_init_size TclBN_mp_init_size #define mp_karatsuba_mul TclBN_mp_karatsuba_mul #define mp_karatsuba_sqr TclBN_mp_karatsuba_sqr #define mp_lshd TclBN_mp_lshd #define mp_mod TclBN_mp_mod #define mp_mod_2d TclBN_mp_mod_2d #define mp_mul TclBN_mp_mul #define mp_mul_2 TclBN_mp_mul_2 #define mp_mul_2d TclBN_mp_mul_2d #define mp_mul_d TclBN_mp_mul_d #define mp_neg TclBN_mp_neg #define mp_or TclBN_mp_or #define mp_radix_size TclBN_mp_radix_size #define mp_read_radix TclBN_mp_read_radix #define mp_rshd TclBN_mp_rshd #define mp_shrink TclBN_mp_shrink #define mp_set TclBN_mp_set #define mp_sqr TclBN_mp_sqr #define mp_sqrt TclBN_mp_sqrt #define mp_sub TclBN_mp_sub #define mp_sub_d TclBN_mp_sub_d #define mp_to_unsigned_bin TclBN_mp_to_unsigned_bin #define mp_to_unsigned_bin_n TclBN_mp_to_unsigned_bin_n #define mp_toom_mul TclBN_mp_toom_mul #define mp_toom_sqr TclBN_mp_toom_sqr #define mp_toradix_n TclBN_mp_toradix_n #define mp_unsigned_bin_size TclBN_mp_unsigned_bin_size #define mp_xor TclBN_mp_xor #define mp_zero TclBN_mp_zero #define s_mp_add TclBN_s_mp_add #define s_mp_mul_digs TclBN_s_mp_mul_digs #define s_mp_sqr TclBN_s_mp_sqr #define s_mp_sub TclBN_s_mp_sub #endif |
Added generic/tclTomMathInterface.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 | /* *---------------------------------------------------------------------- * * tclTomMathInterface.c -- * * This file contains procedures that are used as a 'glue' * layer between Tcl and libtommath. * * Copyright (c) 2005 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: tclTomMathInterface.c,v 1.1.2.4 2005/09/16 19:29:02 dgp Exp $ */ #include "tclInt.h" #include "tommath.h" #include <limits.h> /* *---------------------------------------------------------------------- * * TclBNAlloc -- * * Allocate memory for libtommath. * * Results: * Returns a pointer to the allocated block. * * This procedure is a wrapper around Tcl_Alloc, needed because of * a mismatched type signature between Tcl_Alloc and malloc. * *---------------------------------------------------------------------- */ extern void * TclBNAlloc( size_t x ) { return (void*) Tcl_Alloc( (unsigned int) x ); } /* *---------------------------------------------------------------------- * * TclBNAlloc -- * * Change the size of an allocated block of memory in libtommath * * Results: * Returns a pointer to the allocated block. * * This procedure is a wrapper around Tcl_Realloc, needed because of * a mismatched type signature between Tcl_Realloc and realloc. * *---------------------------------------------------------------------- */ extern void * TclBNRealloc( void* p, size_t s ) { return (void*) Tcl_Realloc( (char*) p, (unsigned int) s ); } /* *---------------------------------------------------------------------- * * TclBNFree -- * * Free allocated memory in libtommath. * * Results: * None. * * Side effects: * Memory is freed. * * This function is simply a wrapper around Tcl_Free, needed in * libtommath because of a type mismatch between free and Tcl_Free. * *---------------------------------------------------------------------- */ extern void TclBNFree( void* p ) { Tcl_Free( (char*) p); } /* *---------------------------------------------------------------------- * * TclBNInitBignumFromLong -- * * Allocate and initialize a 'bignum' from a native 'long'. * * Results: * None. * * Side effects: * The 'bignum' is constructed. * *---------------------------------------------------------------------- */ extern void TclBNInitBignumFromLong( mp_int* a, long initVal ) { int status; unsigned long v; mp_digit* p; /* * Allocate enough memory to hold the largest possible long */ status = mp_init_size( a, ( ( CHAR_BIT * sizeof( long ) + DIGIT_BIT - 1 ) / DIGIT_BIT ) ); if ( status != MP_OKAY ) { Tcl_Panic( "initialization failure in TclBNInitBignumFromLong" ); } /* Convert arg to sign and magnitude */ if ( initVal < 0 ) { a->sign = MP_NEG; v = -initVal; } else { a->sign = MP_ZPOS; v = initVal; } /* Store the magnitude in the bignum. */ p = a->dp; while ( v ) { *p++ = (mp_digit) ( v & MP_MASK ); v >>= MP_DIGIT_BIT; } a->used = p - a->dp; } /* *---------------------------------------------------------------------- * * TclBNInitBignumFromWideInt -- * * Allocate and initialize a 'bignum' from a Tcl_WideInt * * Results: * None. * * Side effects: * The 'bignum' is constructed. * *---------------------------------------------------------------------- */ extern void TclBNInitBignumFromWideInt(mp_int* a, /* Bignum to initialize */ Tcl_WideInt v) /* Initial value */ { if (v < (Tcl_WideInt)0) { TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)(-v)); mp_neg(a, a); } else { TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v); } } /* *---------------------------------------------------------------------- * * TclBNInitBignumFromWideUInt -- * * Allocate and initialize a 'bignum' from a Tcl_WideUInt * * Results: * None. * * Side effects: * The 'bignum' is constructed. * *---------------------------------------------------------------------- */ extern void TclBNInitBignumFromWideUInt(mp_int* a, /* Bignum to initialize */ Tcl_WideUInt v) /* Initial value */ { int status; mp_digit* p; /* * Allocate enough memory to hold the largest possible Tcl_WideUInt */ status = mp_init_size(a, ((CHAR_BIT * sizeof( Tcl_WideUInt ) + DIGIT_BIT - 1) / DIGIT_BIT)); if (status != MP_OKAY) { Tcl_Panic( "initialization failure in TclBNInitBignumFromWideUInt" ); } a->sign = MP_ZPOS; /* Store the magnitude in the bignum. */ p = a->dp; while ( v ) { *p++ = (mp_digit) ( v & MP_MASK ); v >>= MP_DIGIT_BIT; } a->used = p - a->dp; } |
Changes to generic/tclTrace.c.
|
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | < | | > | > | | | | | | | | | < | < < | | > | | | | | < | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | /* * tclTrace.c -- * * This file contains code to handle most trace management. * * Copyright (c) 1987-1993 The Regents of the University of California. * 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: tclTrace.c,v 1.21.2.3 2005/08/02 18:16:10 dgp Exp $ */ #include "tclInt.h" /* * Structure used to hold information about variable traces: */ typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ size_t length; /* Number of non-NULL chars. in command. */ char command[4]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the * structure, so that it can be larger than 4 * bytes. */ } TraceVarInfo; /* * 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 step execution * traces, store the level at which the step * trace was invoked */ char *startCmd; /* Used for bookkeeping with step execution * traces, store the command name which * invoked step trace */ int curFlags; /* Trace flags for the current command */ int curCode; /* Return code for the current command */ int refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ 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 * TCL_TRACE_ENTER_DURING_EXEC == 4 * TCL_TRACE_ENTER_EXEC and that * TCL_TRACE_LEAVE_DURING_EXEC == 4 * TCL_TRACE_LEAVE_EXEC. * * 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 function 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 functions 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 functions to this file: */ static int CallTraceFunction _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; static int StringTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp* interp, int level, CONST char* command, Tcl_Command commandInfo, int objc, Tcl_Obj *CONST objv[])); static void StringTraceDeleteProc _ANSI_ARGS_(( ClientData clientData)); static void DisposeTraceResult _ANSI_ARGS_((int flags, char *result)); /* * The following structure holds the client data for string-based * trace procs */ typedef struct StringTraceData { ClientData clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc* proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; /* *---------------------------------------------------------------------- * * Tcl_TraceObjCmd -- * * This function 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. *---------------------------------------------------------------------- |
︙ | ︙ | |||
176 177 178 179 180 181 182 | int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int optionIndex; char *name, *flagOps, *p; /* Main sub commands to 'trace' */ static CONST char *traceOptions[] = { | | | | | | | | | | | > | > | | | | | | | | | | | | | | | | > | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | > | > | | > > | | > | | | | | | > | | | | > | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | > | | | < | | | | | | < | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | < | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | > | | | | > | | | | | < | | | | | | | | > | | | | | | | | | | | | | | > | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | > | | | | | | | | | < | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | < | | | | < | | | | | | | > | | > | | | | | | > | | | | > | | | | | < | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | < | | < | | | | | | | | | | | < | | | | | | | | | | | | < | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | > > > | > | | | | > | | | > | | | | | | | | | | | | | | | | > > > | | > | > > > | | | < > | > | > > > > > > | | | | | < | | | | | | | | > | | | | | | | | | | | | | | | | > | > > > | | | | | | > | | | | | | > | > | | | | | | | | | | > | | | | | | | | | < | | | | | | | | | | | | | | | | | > > | | | | | | > | > > | | | | | | > | > | > | > | | > > | | | > | < | < | > | > | | | | > | | > | > | | | | | | | | | | | | | | | < | | | > | | < | | | | | | | | | | | > | | | | | | | < > | | | | < | | > | | > | | | > | | | | | | | | | | < > > > | > > < < < | > | > > > | > > | > | > > > > | > > | | | > | | | | > | | | < | | | > | | | | | | | | | | | | | | | | | | | < | | | | | 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 | int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int optionIndex; char *name, *flagOps, *p; /* Main sub commands to 'trace' */ static CONST char *traceOptions[] = { "add", "info", "remove", #ifndef TCL_REMOVE_OBSOLETE_TRACES "variable", "vdelete", "vinfo", #endif (char *) NULL }; /* '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: { /* * 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) { Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option", 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); } case TRACE_INFO: { /* * All sub commands of trace info must take exactly two more arguments * which name the type of thing being traced and the name of the thing * being traced. */ int typeIndex; if (objc < 3) { /* * Delegate other complaints to the type-specific code which can * give a better error message. */ Tcl_WrongNumArgs(interp, 2, objv, "type name"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option", 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); break; } #ifndef TCL_REMOVE_OBSOLETE_TRACES case TRACE_OLD_VARIABLE: case TRACE_OLD_VDELETE: { Tcl_Obj *copyObjv[6]; Tcl_Obj *opsList; int code, numFlags; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); return TCL_ERROR; } opsList = Tcl_NewObj(); Tcl_IncrRefCount(opsList); flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); if (numFlags == 0) { Tcl_DecrRefCount(opsList); goto badVarOps; } for (p = flagOps; *p != 0; p++) { if (*p == 'r') { Tcl_ListObjAppendElement(NULL, opsList, Tcl_NewStringObj("read", -1)); } else if (*p == 'w') { Tcl_ListObjAppendElement(NULL, opsList, Tcl_NewStringObj("write", -1)); } else if (*p == 'u') { Tcl_ListObjAppendElement(NULL, opsList, Tcl_NewStringObj("unset", -1)); } else if (*p == 'a') { Tcl_ListObjAppendElement(NULL, opsList, Tcl_NewStringObj("array", -1)); } else { Tcl_DecrRefCount(opsList); goto badVarOps; } } copyObjv[0] = NULL; memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *)); copyObjv[4] = opsList; if (optionIndex == TRACE_OLD_VARIABLE) { code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv); } else { code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv); } Tcl_DecrRefCount(opsList); return code; } case TRACE_OLD_VINFO: { ClientData clientData; char ops[5]; Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } resultListPtr = Tcl_NewObj(); clientData = 0; name = Tcl_GetString(objv[2]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); p = ops; if (tvarPtr->flags & TCL_TRACE_READS) { *p = 'r'; p++; } if (tvarPtr->flags & TCL_TRACE_WRITES) { *p = 'w'; p++; } if (tvarPtr->flags & TCL_TRACE_UNSETS) { *p = 'u'; p++; } if (tvarPtr->flags & TCL_TRACE_ARRAY) { *p = 'a'; p++; } *p = '\0'; /* * Build a pair (2-item list) with the ops string as the first obj * element and the tvarPtr->command string as the second obj * element. Append the pair (as an element) to the end of the * result object list. */ elemObjPtr = Tcl_NewStringObj(ops, -1); Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); } Tcl_SetObjResult(interp, resultListPtr); break; } #endif /* TCL_REMOVE_OBSOLETE_TRACES */ } return TCL_OK; badVarOps: Tcl_AppendResult(interp, "bad operations \"", flagOps, "\": should be one or more of rwua", (char *) NULL); 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 command"); 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->startCmd = NULL; tcmdPtr->length = length; tcmdPtr->refCount = 1; flags |= TCL_TRACE_DELETE; if (flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC)) { flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } strcpy(tcmdPtr->command, command); name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, (ClientData) tcmdPtr) != TCL_OK) { ckfree((char *) tcmdPtr); return TCL_ERROR; } } 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 = NULL; name = Tcl_GetString(objv[3]); /* First ensure the name given is valid */ if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != NULL) { 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 & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC)) { flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } Tcl_UntraceCommand(interp, name, flags, TraceCommandProc, clientData); if (tcmdPtr->stepTrace != NULL) { /* * We need to remove the interpreter-wide trace which * we created to allow 'step' traces. */ Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { ckfree((char *)tcmdPtr->startCmd); } } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* Postpone deletion */ tcmdPtr->flags = 0; } if ((--tcmdPtr->refCount) <= 0) { 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; } clientData = NULL; name = Tcl_GetString(objv[3]); /* First ensure the name given is valid */ if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != NULL) { int numOps = 0; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; /* * Build a list with the ops list as the first obj element and the * tcmdPtr->command string as the second obj element. Append this * list (as an element) to the end of the result object list. */ elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_IncrRefCount(elemObjPtr); if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("enter",5)); } if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("leave",5)); } if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("enterstep",9)); } if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("leavestep",9)); } Tcl_ListObjLength(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; } eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); Tcl_DecrRefCount(elemObjPtr); elemObjPtr = NULL; Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, Tcl_NewStringObj(tcmdPtr->command, -1)); Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); } 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; int i, listLen, result; Tcl_Obj **elemPtrs; if (objc != 6) { Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); 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 delete or rename", 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_CMD_RENAME: flags |= TCL_TRACE_RENAME; break; case TRACE_CMD_DELETE: flags |= TCL_TRACE_DELETE; 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->startCmd = NULL; tcmdPtr->length = length; tcmdPtr->refCount = 1; 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); 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 = NULL; name = Tcl_GetString(objv[3]); /* First ensure the name given is valid */ if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != NULL) { tcmdPtr = (TraceCommandInfo *) clientData; if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags) && (strncmp(command, tcmdPtr->command, (size_t) length) == 0)) { Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; if ((--tcmdPtr->refCount) <= 0) { 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; } clientData = NULL; name = Tcl_GetString(objv[3]); /* First ensure the name given is valid */ if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != NULL) { int numOps = 0; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; /* * Build a list with the ops list as the first obj element and the * tcmdPtr->command string as the second obj element. Append this * list (as an element) to the end of the result object list. */ elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_IncrRefCount(elemObjPtr); if (tcmdPtr->flags & TCL_TRACE_RENAME) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("rename",6)); } if (tcmdPtr->flags & TCL_TRACE_DELETE) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("delete",6)); } Tcl_ListObjLength(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; } eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); Tcl_DecrRefCount(elemObjPtr); elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); } Tcl_SetObjResult(interp, resultListPtr); break; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * 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: case TRACE_REMOVE: { int flags = 0; int i, listLen, result; Tcl_Obj **elemPtrs; if (objc != 6) { Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); 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 array, read, unset, or write", 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_VAR_ARRAY: flags |= TCL_TRACE_ARRAY; break; case TRACE_VAR_READ: flags |= TCL_TRACE_READS; break; case TRACE_VAR_UNSET: flags |= TCL_TRACE_UNSETS; break; case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; } } command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceVarInfo *tvarPtr; tvarPtr = (TraceVarInfo *) ckalloc((unsigned) (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); tvarPtr->flags = flags; if (objv[0] == NULL) { tvarPtr->flags |= TCL_TRACE_OLD_STYLE; } tvarPtr->length = length; flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; strcpy(tvarPtr->command, command); name = Tcl_GetString(objv[3]); if (Tcl_TraceVar(interp, name, flags, TraceVarProc, (ClientData) tvarPtr) != TCL_OK) { ckfree((char *) tvarPtr); return TCL_ERROR; } } else { /* * Search through all of our traces on this variable to see if * there's one with the given command. If so, then delete the * first one that matches. */ TraceVarInfo *tvarPtr; ClientData clientData = 0; name = Tcl_GetString(objv[3]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { tvarPtr = (TraceVarInfo *) clientData; if ((tvarPtr->length == length) && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags) && (strncmp(command, tvarPtr->command, (size_t) length) == 0)) { Tcl_UntraceVar2(interp, name, NULL, flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); 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; } resultListPtr = Tcl_NewObj(); clientData = 0; name = Tcl_GetString(objv[3]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; /* * Build a list with the ops list as the first obj element and the * tcmdPtr->command string as the second obj element. Append this * list (as an element) to the end of the result object list. */ elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if (tvarPtr->flags & TCL_TRACE_ARRAY) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("array", 5)); } if (tvarPtr->flags & TCL_TRACE_READS) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("read", 4)); } if (tvarPtr->flags & TCL_TRACE_WRITES) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("write", 5)); } if (tvarPtr->flags & TCL_TRACE_UNSETS) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("unset", 5)); } eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); } Tcl_SetObjResult(interp, resultListPtr); break; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_CommandTraceInfo -- * * Return the clientData value associated with a trace on a command. * This function can also be used to step through all of the traces on a * particular command that have the same trace function. * * Results: * The return value is the clientData value associated with a trace on * the given command. Information will only be returned for a trace with * proc as trace function. If the clientData argument is NULL then the * first such trace is returned; otherwise, the next relevant one after * the one given by clientData will be returned. If the command doesn't * exist then an error message is left in the interpreter and NULL is * returned. Also, if there are no (more) traces for the given command, * NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ ClientData Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) Tcl_Interp *interp; /* Interpreter containing command. */ CONST char *cmdName; /* Name of command. */ int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY (can be 0). */ Tcl_CommandTraceProc *proc; /* Function assocated with trace. */ ClientData prevClientData; /* If non-NULL, gives last value returned by * this function, so this call will return the * next trace after that one. If NULL, this * call will return the first trace. */ { Command *cmdPtr; register CommandTrace *tracePtr; cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return NULL; } /* * Find the relevant trace, if any, and return its clientData. */ tracePtr = cmdPtr->tracePtr; if (prevClientData != NULL) { for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) { if ((tracePtr->clientData == prevClientData) && (tracePtr->traceProc == proc)) { tracePtr = tracePtr->nextPtr; break; } } } for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) { if (tracePtr->traceProc == proc) { return tracePtr->clientData; } } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_TraceCommand -- * * Arrange for rename/deletes to a command to cause a function to be * invoked, which can monitor the operations. * * Also optionally arrange for execution of that command to cause a * function 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; /* Function to call when specified ops are * invoked upon cmdName. */ 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; tracePtr->refCount = 1; cmdPtr->tracePtr = tracePtr; if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { cmdPtr->flags |= CMD_HAS_EXEC_TRACES; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_UntraceCommand -- * * Remove a previously-created trace for a command. * * Results: * None. * * Side effects: * If there exists a trace for the command given by cmdName with the * given flags, proc, and clientData, then that trace is removed. * *---------------------------------------------------------------------- */ 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; /* Function 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) { if (activePtr->reverseScan) { activePtr->nextTracePtr = prevPtr; } else { activePtr->nextTracePtr = tracePtr->nextPtr; } } } if (prevPtr == NULL) { cmdPtr->tracePtr = tracePtr->nextPtr; } else { prevPtr->nextPtr = tracePtr->nextPtr; } tracePtr->flags = 0; if ((--tracePtr->refCount) <= 0) { ckfree((char*)tracePtr); } 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 function 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. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void TraceCommandProc(clientData, interp, oldName, newName, flags) ClientData clientData; /* Information about the command trace. */ Tcl_Interp *interp; /* Interpreter containing command. */ CONST char *oldName; /* Name of command being changed. */ CONST char *newName; /* New name of command. Empty string or NULL * means command is being deleted (renamed to * ""). */ int flags; /* OR-ed bits giving operation and other * information. */ { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; int code; Tcl_DString cmd; tcmdPtr->refCount++; if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED) && !Tcl_LimitExceeded(interp)) { /* * Generate a command to execute by appending list elements for the * old and new command name and the operation. */ Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); Tcl_DStringAppendElement(&cmd, oldName); Tcl_DStringAppendElement(&cmd, (newName ? newName : "")); if (flags & TCL_TRACE_RENAME) { Tcl_DStringAppend(&cmd, " rename", 7); } else if (flags & TCL_TRACE_DELETE) { Tcl_DStringAppend(&cmd, " delete", 7); } /* * Execute the command. We discard any object result the command * returns. * * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to other * areas that this will be destroyed by us, otherwise a double-free * might occur depending on what the eval does. */ if (flags & TCL_TRACE_DESTROYED) { tcmdPtr->flags |= TCL_TRACE_DESTROYED; } code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), 0); if (code != TCL_OK) { /* We ignore errors in these traced commands */ /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/ } Tcl_DStringFree(&cmd); } /* * We delete when the trace was destroyed or if this is a delete trace, * because command deletes are unconditional, so the trace must go away. */ if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) { int untraceFlags = tcmdPtr->flags; Tcl_InterpState state; if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { ckfree((char *)tcmdPtr->startCmd); } } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* * Postpone deletion, until exec trace returns. */ tcmdPtr->flags = 0; } /* * We need to construct the same flags for Tcl_UntraceCommand as were * passed to Tcl_TraceCommand. Reproduce the processing of [trace add * execution/command]. Be careful to keep this code in sync with that. */ if (untraceFlags & TCL_TRACE_ANY_EXEC) { untraceFlags |= TCL_TRACE_DELETE; if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC)) { untraceFlags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } } else if (untraceFlags & TCL_TRACE_RENAME) { untraceFlags |= TCL_TRACE_DELETE; } /* * Remove the trace since TCL_TRACE_DESTROYED tells us to, or the * command we're tracing has just gone away. Then decrement the * clientData refCount that was set up by trace creation. * * Note that we save the (return) state of the interpreter to prevent * bizarre error messages. */ state = Tcl_SaveInterpState(interp, TCL_OK); Tcl_UntraceCommand(interp, oldName, untraceFlags, TraceCommandProc, clientData); (void) Tcl_RestoreInterpState(interp, state); tcmdPtr->refCount--; } if ((--tcmdPtr->refCount) <= 0) { ckfree((char*)tcmdPtr); } return; } /* *---------------------------------------------------------------------- * * TclCheckExecutionTraces -- * * Checks on all current command execution traces, and invokes functions * which have been registered. This function 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 function 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 functions 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; Tcl_InterpState state = NULL; 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.reverseScan = 1; active.nextTracePtr = NULL; tracePtr = cmdPtr->tracePtr; while (tracePtr->nextPtr != lastTracePtr) { active.nextTracePtr = tracePtr; tracePtr = tracePtr->nextPtr; } } else { active.reverseScan = 0; active.nextTracePtr = tracePtr->nextPtr; } tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; if (tcmdPtr->flags != 0) { tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; tcmdPtr->curCode = code; tcmdPtr->refCount++; if (state == NULL) { state = Tcl_SaveInterpState(interp, code); } traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, curLevel, command, (Tcl_Command)cmdPtr, objc, objv); if ((--tcmdPtr->refCount) <= 0) { ckfree((char*)tcmdPtr); } } if (active.nextTracePtr) { lastTracePtr = active.nextTracePtr->nextPtr; } } iPtr->activeCmdTracePtr = active.nextPtr; if (state) { (void) Tcl_RestoreInterpState(interp, state); } return(traceCode); } /* *---------------------------------------------------------------------- * * TclCheckInterpTraces -- * * Checks on all current traces, and invokes functions which have been * registered. This function 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 function 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 functions 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; Tcl_InterpState state = NULL; if (command == NULL || iPtr->tracePtr == NULL || (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { return(traceCode); } curLevel = iPtr->numLevels; active.nextPtr = iPtr->activeInterpTracePtr; iPtr->activeInterpTracePtr = &active; lastTracePtr = NULL; for (tracePtr = iPtr->tracePtr; (traceCode == TCL_OK) && (tracePtr != NULL); tracePtr = active.nextTracePtr) { if (traceFlags & TCL_TRACE_ENTER_EXEC) { /* * Execute the trace command in reverse order of creation for * "enterstep" operation. The order is changed for "enterstep" * instead of for "leavestep" as was done in * TclCheckExecutionTraces because for step traces, * Tcl_CreateObjTrace creates one more linked list of traces which * results in one more reversal of trace invocation. */ active.reverseScan = 1; active.nextTracePtr = NULL; tracePtr = iPtr->tracePtr; while (tracePtr->nextPtr != lastTracePtr) { active.nextTracePtr = tracePtr; tracePtr = tracePtr->nextPtr; } } else { active.reverseScan = 0; active.nextTracePtr = tracePtr->nextPtr; } if (tracePtr->level > 0 && curLevel > tracePtr->level) { continue; } if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) { /* * The proc invoked might delete the traced command which which * might try to free tracePtr. We want to use tracePtr until the * end of this if section, so we use Tcl_Preserve() and * Tcl_Release() to be sure it is not freed while we still need * it. */ Tcl_Preserve((ClientData) tracePtr); tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; if (state == NULL) { state = Tcl_SaveInterpState(interp, code); } if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) { /* * New style trace. */ if (tracePtr->flags & traceFlags) { if (tracePtr->proc == TraceExecutionProc) { TraceCommandInfo* tcmdPtr = (TraceCommandInfo *) tracePtr->clientData; tcmdPtr->curFlags = traceFlags; tcmdPtr->curCode = code; } traceCode = (tracePtr->proc)(tracePtr->clientData, interp, curLevel, command, (Tcl_Command) cmdPtr, objc, objv); } } else { /* * Old-style trace. */ if (traceFlags & TCL_TRACE_ENTER_EXEC) { /* * Old-style interpreter-wide traces only trigger before * the command is executed. */ traceCode = CallTraceFunction(interp, tracePtr, cmdPtr, command, numChars, objc, objv); } } tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; Tcl_Release((ClientData) tracePtr); } if (active.nextTracePtr) { lastTracePtr = active.nextTracePtr->nextPtr; } } iPtr->activeInterpTracePtr = active.nextPtr; if (state) { if (traceCode == TCL_OK) { (void) Tcl_RestoreInterpState(interp, state); } else { Tcl_DiscardInterpState(state); } } return(traceCode); } /* *---------------------------------------------------------------------- * * CallTraceFunction -- * * Invokes a trace function registered with an interpreter. These * functions trace command execution. Currently this trace function 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 function. * *---------------------------------------------------------------------- */ static int CallTraceFunction(interp, tracePtr, cmdPtr, command, numChars, objc, objv) Tcl_Interp *interp; /* The current interpreter. */ register Trace *tracePtr; /* Describes the trace function 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 function 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); } /* *---------------------------------------------------------------------- * * CommandObjTraceDeleted -- * * Ensure the trace is correctly deleted by decrementing its refCount and * only deleting if no other references exist. * * Results: * None. * * Side effects: * May release memory. * *---------------------------------------------------------------------- */ static void CommandObjTraceDeleted(ClientData clientData) { TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; if ((--tcmdPtr->refCount) <= 0) { ckfree((char*)tcmdPtr); } } /* *---------------------------------------------------------------------- * * TraceExecutionProc -- * * This function 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 function 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. * *---------------------------------------------------------------------- */ static 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) && !Tcl_LimitExceeded(interp)) { /* * Check whether the current call is going to eval arbitrary Tcl code * with a generated trace, or whether we are only going to setup * interpreter-wide traces to implement the 'step' traces. This latter * situation can happen if we create a command trace without either * before or after operations, but with either of the step operations. */ if (flags & TCL_TRACE_EXEC_DIRECT) { call = flags & tcmdPtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } else { call = 1; } /* * First, if we have returned back to the level at which we created an * interpreter trace for enterstep and/or leavestep execution traces, * we remove it here. */ if ((flags & TCL_TRACE_LEAVE_EXEC) && (tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel) && (strcmp(command, tcmdPtr->startCmd) == 0)) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { ckfree((char *)tcmdPtr->startCmd); } } /* * Second, create the tcl callback, if required. */ if (call) { 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++) { Tcl_DStringAppendElement(&sub, Tcl_GetString(objv[i])); } 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 { Tcl_Panic("TraceExecutionProc: bad flag combination"); } /* * Execute the command. We discard any object result the command * returns. */ tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; iPtr->flags |= INTERP_TRACE_IN_PROGRESS; tcmdPtr->refCount++; /* * This line can have quite arbitrary side-effects, including * deleting the trace, the command being traced, or even the * interpreter. */ traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS; if (tcmdPtr->flags == 0) { flags |= TCL_TRACE_DESTROYED; } Tcl_DStringFree(&cmd); } /* * Third, if there are any step execution traces for this proc, we * register an interpreter trace to invoke enterstep and/or leavestep * traces. We also need to save the current stack level and the proc * string in startLevel and startCmd so that we can delete this * interpreter trace when it reaches the end of this proc. */ 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->startCmd = (char *) ckalloc((unsigned) (strlen(command) + 1)); strcpy(tcmdPtr->startCmd, command); tcmdPtr->refCount++; tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, TraceExecutionProc, (ClientData)tcmdPtr, CommandObjTraceDeleted); } } if (flags & TCL_TRACE_DESTROYED) { if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { ckfree((char *)tcmdPtr->startCmd); } } } if (call) { if ((--tcmdPtr->refCount) <= 0) { ckfree((char*)tcmdPtr); } } return traceCode; } /* *---------------------------------------------------------------------- * * TraceVarProc -- * * This function is called to handle variable accesses that have been * traced using the "trace" command. * * Results: * Normally returns NULL. If the trace command returns an error, then * this function returns an error string. * * Side effects: * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ /* 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. */ { 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) && !Tcl_LimitExceeded(interp)) { if (tvarPtr->length != (size_t) 0) { /* * Generate a command to execute by appending list elements for * the two variable names and the operation. */ Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); Tcl_DStringAppendElement(&cmd, (name2 ? name2 : "")); #ifndef TCL_REMOVE_OBSOLETE_TRACES |
︙ | ︙ | |||
1899 1900 1901 1902 1903 1904 1905 | Tcl_DStringAppend(&cmd, " write", 6); } else if (flags & TCL_TRACE_UNSETS) { Tcl_DStringAppend(&cmd, " unset", 6); } #ifndef TCL_REMOVE_OBSOLETE_TRACES } #endif | | | | | | 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 | Tcl_DStringAppend(&cmd, " write", 6); } else if (flags & TCL_TRACE_UNSETS) { Tcl_DStringAppend(&cmd, " unset", 6); } #ifndef TCL_REMOVE_OBSOLETE_TRACES } #endif /* * Execute the command. We discard any object result the command * returns. * * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to * other areas that this will be destroyed by us, otherwise a * double-free might occur depending on what the eval does. */ if (flags & TCL_TRACE_DESTROYED) { tvarPtr->flags |= TCL_TRACE_DESTROYED; } code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), 0); if (code != TCL_OK) { /* copy error msg to result */ Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errMsgObj); result = (char *) errMsgObj; } Tcl_DStringFree(&cmd); } } |
︙ | ︙ | |||
1940 1941 1942 1943 1944 1945 1946 | } /* *---------------------------------------------------------------------- * * Tcl_CreateObjTrace -- * | | | | | | | | | | | | | | | | | | | < | | | | | | < | | | | | | | | | | | | | | | | | | > | > < | | < | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | < | | < < | | | | | | | | | | | < | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_CreateObjTrace -- * * Arrange for a function to be called to trace command execution. * * Results: * The return value is a token for the trace, which may be passed to * Tcl_DeleteTrace to eliminate the trace. * * Side effects: * From now on, proc will be called just before a command function is * called to execute a Tcl command. Calls to proc will have the following * form: * * void proc(ClientData clientData, * Tcl_Interp* interp, * int level, * CONST char* command, * Tcl_Command commandInfo, * int objc, * Tcl_Obj *CONST objv[]); * * The 'clientData' and 'interp' arguments to 'proc' will be the same as * the arguments to Tcl_CreateObjTrace. The 'level' argument gives the * nesting depth of command interpretation within the interpreter. The * 'command' argument is the ASCII text of the command being evaluated - * before any substitutions are performed. The 'commandInfo' argument * gives a handle to the command procedure that will be evaluated. The * 'objc' and 'objv' parameters give the parameter vector that will be * passed to the command procedure. Proc does not return a value. * * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo to change * the command procedure or client data for the command being evaluated, * and these changes will take effect with the current evaluation. * * The 'level' argument specifies the maximum nesting level of calls to * be traced. If the execution depth of the interpreter exceeds 'level', * the trace callback is not executed. * * The 'flags' argument is either zero or the value, * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION flag * is not present, the bytecode compiler will not generate inline code * for Tcl's built-in commands. This behavior will have a significant * impact on performance, but will ensure that all command evaluations * are traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the * bytecode compiler will have its normal behavior of compiling in-line * code for some of Tcl's built-in commands. In this case, the tracing * will be imprecise - in-line code will not be traced - but run-time * performance will be improved. The latter behavior is desired for many * applications such as profiling of run time. * * When the trace is deleted, the 'delProc' function will be invoked, * passing it the original client data. * *---------------------------------------------------------------------- */ Tcl_Trace Tcl_CreateObjTrace(interp, level, flags, proc, clientData, delProc) Tcl_Interp* interp; /* Tcl interpreter */ int level; /* Maximum nesting level */ int flags; /* Flags, see above */ Tcl_CmdObjTraceProc* proc; /* Trace callback */ ClientData clientData; /* Client data for the callback */ Tcl_CmdObjTraceDeleteProc* delProc; /* Function to call when trace is deleted */ { register Trace *tracePtr; register Interp *iPtr = (Interp *) interp; /* * Test if this trace allows inline compilation of commands. */ if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) { if (iPtr->tracesForbiddingInline == 0) { /* * When the first trace forbidding inline compilation is created, * invalidate existing compiled code for this interpreter and * arrange (by setting the DONT_COMPILE_CMDS_INLINE flag) that * when compiling new code, no commands will be compiled inline * (i.e., into an inline sequence of instructions). We do this * because commands that were compiled inline will never result in * a command trace being called. */ iPtr->compileEpoch++; iPtr->flags |= DONT_COMPILE_CMDS_INLINE; } iPtr->tracesForbiddingInline++; } tracePtr = (Trace *) ckalloc(sizeof(Trace)); tracePtr->level = level; tracePtr->proc = proc; tracePtr->clientData = clientData; tracePtr->delProc = delProc; tracePtr->nextPtr = iPtr->tracePtr; tracePtr->flags = flags; iPtr->tracePtr = tracePtr; return (Tcl_Trace) tracePtr; } /* *---------------------------------------------------------------------- * * Tcl_CreateTrace -- * * Arrange for a function to be called to trace command execution. * * Results: * The return value is a token for the trace, which may be passed to * Tcl_DeleteTrace to eliminate the trace. * * Side effects: * From now on, proc will be called just before a command procedure is * called to execute a Tcl command. Calls to proc will have the following * form: * * void * proc(clientData, interp, level, command, cmdProc, cmdClientData, * argc, argv) * ClientData clientData; * Tcl_Interp *interp; * int level; * char *command; * int (*cmdProc)(); * ClientData cmdClientData; * int argc; * char **argv; * { * } * * The clientData and interp arguments to proc will be the same as the * corresponding arguments to this function. Level gives the nesting * level of command interpretation for this interpreter (0 corresponds to * top level). Command gives the ASCII text of the raw command, cmdProc * and cmdClientData give the function that will be called to process the * command and the ClientData value it will receive, and argc and argv * give the arguments to the command, after any argument parsing and * substitution. Proc does not return a value. * *---------------------------------------------------------------------- */ Tcl_Trace Tcl_CreateTrace(interp, level, proc, clientData) 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; /* Function 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); } /* *---------------------------------------------------------------------- * * StringTraceProc -- * * Invoke a string-based trace function from an object-based callback. * * Results: * None. * * Side effects: * Whatever the string-based trace function does. * *---------------------------------------------------------------------- */ static int StringTraceProc(clientData, interp, level, command, commandInfo, objc, objv) ClientData clientData; Tcl_Interp* interp; int level; CONST char* command; Tcl_Command commandInfo; int objc; Tcl_Obj *CONST *objv; { StringTraceData* data = (StringTraceData*) clientData; Command* cmdPtr = (Command*) commandInfo; CONST char** argv; /* Args to pass to string trace proc */ int i; /* * This is a bit messy because we have to emulate the old trace interface, * which uses strings for everything. */ argv = (CONST char **) ckalloc((unsigned) ((objc + 1) * sizeof(CONST char *))); for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; /* * Invoke the command function. 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; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
2180 2181 2182 2183 2184 2185 2186 | * Side effects: * Allocated memory is returned to the system. * *---------------------------------------------------------------------- */ static void | | | | | | > | | > > > > > > > > > > > > > > > > > > > | | | > | > | | | | | | < | | | | | | | | | | | | | | | < | | | | | | < | | | | | | | | | | | < | | > | 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 | * Side effects: * Allocated memory is returned to the system. * *---------------------------------------------------------------------- */ static void StringTraceDeleteProc(clientData) ClientData clientData; { ckfree((char *) clientData); } /* *---------------------------------------------------------------------- * * Tcl_DeleteTrace -- * * Remove a trace. * * Results: * None. * * Side effects: * From now on there will be no more calls to the function given in * trace. * *---------------------------------------------------------------------- */ void Tcl_DeleteTrace(interp, trace) Tcl_Interp *interp; /* Interpreter that contains trace. */ Tcl_Trace trace; /* Token for trace (returned previously by * Tcl_CreateTrace). */ { Interp *iPtr = (Interp *) interp; Trace *prevPtr, *tracePtr = (Trace *) trace; register Trace **tracePtr2 = &(iPtr->tracePtr); ActiveInterpTrace *activePtr; /* * Locate the trace entry in the interpreter's trace list, and remove it * from the list. */ prevPtr = NULL; while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { prevPtr = *tracePtr2; tracePtr2 = &((*tracePtr2)->nextPtr); } if (*tracePtr2 == NULL) { return; } (*tracePtr2) = (*tracePtr2)->nextPtr; /* * The code below makes it possible to delete traces while traces are * active: it makes sure that the deleted trace won't be processed by * TclCheckInterpTraces. */ for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { if (activePtr->reverseScan) { activePtr->nextTracePtr = prevPtr; } else { activePtr->nextTracePtr = tracePtr->nextPtr; } } } /* * If the trace forbids bytecode compilation, change the interpreter's * state. If bytecode compilation is now permitted, flag the fact and * advance the compilation epoch so that procs will be recompiled to take * advantage of it. */ if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) { iPtr->tracesForbiddingInline--; if (iPtr->tracesForbiddingInline == 0) { iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; iPtr->compileEpoch++; } } /* * Execute any delete callback. */ if (tracePtr->delProc != NULL) { (tracePtr->delProc)(tracePtr->clientData); } /* * Delete the trace object. */ Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC); } /* *---------------------------------------------------------------------- * * TclTraceVarExists -- * * This is called from info exists. We need to trigger read and/or array * traces because they may end up creating a variable that doesn't * currently exist. * * Results: * A pointer to the Var structure, or NULL. * * Side effects: * May fill in error messages in the interp. * *---------------------------------------------------------------------- */ 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, however, because if * you do "info exists x" you get a varPtr and therefore trigger traces. * However, if you do "info exists x(i)", then you only get a varPtr if x * is already known to be an array. Otherwise you get NULL, and no trace * is triggered. This matches Tcl 7.6 semantics. */ varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, "access", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return NULL; } if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { TclCallVarTraces((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)) { TclCleanupVar(varPtr, arrayPtr); return NULL; } return varPtr; } /* *---------------------------------------------------------------------- * * TclCallVarTraces -- * * This function is invoked to find and invoke relevant trace functions * associated with a particular operation on a variable. This function * invokes traces both on the variable and on its containing array (where * relevant). * * Results: * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if * invocation of a trace function indicated an error. When TCL_ERROR is * returned and leaveErrMsg is true, then the errorInfo field of iPtr has * information about the error placed in it. * * Side effects: * Almost anything can happen, depending on trace; this function itself * doesn't have any side effects. * *---------------------------------------------------------------------- */ int TclCallVarTraces(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 functions: indicates * what's happening to variable, plus other * stuff like TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, and * TCL_INTERP_DESTROYED. */ 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; Tcl_InterpState state = NULL; /* * If there are already similar trace functions active for the variable, * don't call them again. */ if (TclIsVarTraceActive(varPtr)) { return code; } TclSetVarTraceActive(varPtr); varPtr->refCount++; if (arrayPtr != NULL) { arrayPtr->refCount++; } /* * If the variable name hasn't been parsed into array name and element, do * it here. If there really is an array element, make a copy of the * original name so that NULLs can be inserted into it to separate the * names (can't modify the name string in place, because the string might * get used by the callbacks we invoke). */ copiedName = 0; if (part2 == NULL) { for (p = part1; *p ; p++) { if (*p == '(') { 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; |
︙ | ︙ | |||
2428 2429 2430 2431 2432 2433 2434 | result = NULL; active.nextPtr = iPtr->activeVarTracePtr; iPtr->activeVarTracePtr = &active; Tcl_Preserve((ClientData) iPtr); if (arrayPtr != NULL && !TclIsVarTraceActive(arrayPtr)) { active.varPtr = arrayPtr; for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; | | > | > > | | > | > > | | | | | | | | | | | | | | | | 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 | result = NULL; active.nextPtr = iPtr->activeVarTracePtr; iPtr->activeVarTracePtr = &active; Tcl_Preserve((ClientData) iPtr); if (arrayPtr != NULL && !TclIsVarTraceActive(arrayPtr)) { active.varPtr = arrayPtr; for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; } Tcl_Preserve((ClientData) tracePtr); if (state == NULL) { state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code); } result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { if (flags & TCL_TRACE_UNSETS) { /* * Ignore errors in unset traces. */ DisposeTraceResult(tracePtr->flags, result); } else { disposeFlags = tracePtr->flags; code = TCL_ERROR; } } Tcl_Release((ClientData) tracePtr); if (code == TCL_ERROR) { goto done; } } } /* * Invoke traces on the variable itself. */ if (flags & TCL_TRACE_UNSETS) { flags |= TCL_TRACE_DESTROYED; } active.varPtr = varPtr; for (tracePtr = varPtr->tracePtr; tracePtr != NULL; tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; } Tcl_Preserve((ClientData) tracePtr); if (state == NULL) { state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code); } result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { if (flags & TCL_TRACE_UNSETS) { /* * Ignore errors in unset traces. */ DisposeTraceResult(tracePtr->flags, result); } else { disposeFlags = tracePtr->flags; code = TCL_ERROR; } } Tcl_Release((ClientData) tracePtr); if (code == TCL_ERROR) { goto done; } } /* * 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 = ""; Tcl_Obj *options = Tcl_GetReturnOptions((Tcl_Interp *)iPtr, code); Tcl_Obj *errorInfoKey = Tcl_NewStringObj("-errorinfo", -1); Tcl_Obj *errorInfo; Tcl_IncrRefCount(errorInfoKey); Tcl_DictObjGet(NULL, options, errorInfoKey, &errorInfo); Tcl_IncrRefCount(errorInfo); Tcl_DictObjRemove(NULL, options, errorInfoKey); if (Tcl_IsShared(errorInfo)) { Tcl_DecrRefCount(errorInfo); errorInfo = Tcl_DuplicateObj(errorInfo); Tcl_IncrRefCount(errorInfo); } Tcl_AppendToObj(errorInfo, "\n (", -1); switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) { case TCL_TRACE_READS: type = "read"; Tcl_AppendToObj(errorInfo, type, -1); break; case TCL_TRACE_WRITES: type = "set"; Tcl_AppendToObj(errorInfo, "write", -1); break; case TCL_TRACE_ARRAY: type = "trace array"; Tcl_AppendToObj(errorInfo, "array", -1); break; } if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, Tcl_GetString((Tcl_Obj *) result)); } else { TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result); } |
︙ | ︙ | |||
2577 2578 2579 2580 2581 2582 2583 | } /* *---------------------------------------------------------------------- * * DisposeTraceResult-- * | | | | | | | | | < | | | | | < | | | | < | | | | < | | | > > | | | | | | | | | | | | < | | < | | | | < | | | | | | | < | | | | | | | | < | 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 | } /* *---------------------------------------------------------------------- * * DisposeTraceResult-- * * This function is called to dispose of the result returned from a trace * function. The disposal method appropriate to the type of result is * determined by flags. * * Results: * None. * * Side effects: * The memory allocated for the trace result may be freed. * *---------------------------------------------------------------------- */ static void DisposeTraceResult(flags, result) int flags; /* Indicates type of result to determine * proper disposal method. */ char *result; /* The result returned from a trace function * to be disposed. */ { if (flags & TCL_TRACE_RESULT_DYNAMIC) { ckfree(result); } else if (flags & TCL_TRACE_RESULT_OBJECT) { Tcl_DecrRefCount((Tcl_Obj *) result); } } /* *---------------------------------------------------------------------- * * Tcl_UntraceVar -- * * Remove a previously-created trace for a variable. * * Results: * None. * * Side effects: * If there exists a trace for the variable given by varName with the * given flags, proc, and clientData, then that trace is removed. * *---------------------------------------------------------------------- */ 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; /* Function assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData); } /* *---------------------------------------------------------------------- * * Tcl_UntraceVar2 -- * * Remove a previously-created trace for a variable. * * Results: * None. * * Side effects: * If there exists a trace for the variable given by part1 and part2 with * the given flags, proc, and clientData, then that trace is removed. * *---------------------------------------------------------------------- */ 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, and TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc; /* Function assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { register VarTrace *tracePtr; VarTrace *prevPtr; Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; ActiveVarTrace *activePtr; int flagMask; /* * Set up a mask to mask out the parts of the flags that we are not * interested in now. */ flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; varPtr = TclLookupVar(interp, part1, part2, flags & flagMask, /*msg*/ (char *) NULL, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return; } /* * Set up a mask to mask out the parts of the flags that we are not * interested in now. */ flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; #ifndef TCL_REMOVE_OBSOLETE_TRACES flagMask |= TCL_TRACE_OLD_STYLE; #endif flags &= flagMask; for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { return; } if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) && (tracePtr->clientData == clientData)) { 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 * TclCallVarTraces. */ for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { activePtr->nextTracePtr = tracePtr->nextPtr; } } if (prevPtr == NULL) { varPtr->tracePtr = tracePtr->nextPtr; } else { prevPtr->nextPtr = tracePtr->nextPtr; } Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); /* * If this is the last trace on the variable, and the variable is unset * and unused, then free up the variable. */ if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, (Var *) NULL); } } /* *---------------------------------------------------------------------- * * Tcl_VarTraceInfo -- * * Return the clientData value associated with a trace on a variable. * This function can also be used to step through all of the traces on a * particular variable that have the same trace function. * * Results: * The return value is the clientData value associated with a trace on * the given variable. Information will only be returned for a trace with * proc as trace function. If the clientData argument is NULL then the * first such trace is returned; otherwise, the next relevant one after * the one given by clientData will be returned. If the variable doesn't * exist, or if there are no (more) traces for it, then NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ 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; /* Function assocated with trace. */ ClientData prevClientData; /* If non-NULL, gives last value returned by * this function, so this call will return the * next trace after that one. If NULL, this * call will return the first trace. */ { return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, flags, proc, prevClientData); } /* *---------------------------------------------------------------------- * * Tcl_VarTraceInfo2 -- * * Same as Tcl_VarTraceInfo, except takes name in two pieces instead of * one. * * Results: * Same as Tcl_VarTraceInfo. * * Side effects: * None. * *---------------------------------------------------------------------- */ 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; /* Function assocated with trace. */ ClientData prevClientData; /* If non-NULL, gives last value returned by * this function, so this call will return the * next trace after that one. If NULL, this * call will return the first trace. */ { register VarTrace *tracePtr; Var *varPtr, *arrayPtr; varPtr = TclLookupVar(interp, part1, part2, flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), /*msg*/ (char *) NULL, |
︙ | ︙ | |||
2842 2843 2844 2845 2846 2847 2848 | if ((tracePtr->clientData == prevClientData) && (tracePtr->traceProc == proc)) { tracePtr = tracePtr->nextPtr; break; } } } | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | < > | | | | | | > | > > > > > > > > | 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 | if ((tracePtr->clientData == prevClientData) && (tracePtr->traceProc == proc)) { tracePtr = tracePtr->nextPtr; break; } } } for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) { if (tracePtr->traceProc == proc) { return tracePtr->clientData; } } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_TraceVar -- * * Arrange for reads and/or writes to a variable to cause a function to * be invoked, which can monitor the operations and/or change their * actions. * * Results: * A standard Tcl return value. * * Side effects: * A trace is set up on the variable given by varName, such that future * references to the variable will be intermediated by proc. See the * manual entry for complete details on the calling sequence for proc. * *---------------------------------------------------------------------- */ 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; /* Function to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { return Tcl_TraceVar2(interp, varName, (char *) NULL, flags, proc, clientData); } /* *---------------------------------------------------------------------- * * Tcl_TraceVar2 -- * * Arrange for reads and/or writes to a variable to cause a function to * be invoked, which can monitor the operations and/or change their * actions. * * Results: * A standard Tcl return value. * * Side effects: * A trace is set up on the variable given by part1 and part2, such that * future references to the variable will be intermediated by proc. See * the manual entry for complete details on the calling sequence for * proc. * *---------------------------------------------------------------------- */ 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. */ Tcl_VarTraceProc *proc; /* Function to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { Var *varPtr, *arrayPtr; register VarTrace *tracePtr; int flagMask; /* * We strip 'flags' down to just the parts which are relevant to * TclLookupVar, to avoid conflicts between trace flags and internal * namespace flags such as 'TCL_FIND_ONLY_NS'. This can now occur since we * have trace flags with values 0x1000 and higher. */ flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; varPtr = TclLookupVar(interp, part1, part2, (flags & flagMask) | TCL_LEAVE_ERR_MSG, "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } /* * Check for a nonsense flag combination. Note that this is a Tcl_Panic() * because there should be no code path that ever sets both flags. */ if ((flags&TCL_TRACE_RESULT_DYNAMIC) && (flags&TCL_TRACE_RESULT_OBJECT)) { Tcl_Panic("bad result flag combination"); } /* * Set up trace information. */ flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; #ifndef TCL_REMOVE_OBSOLETE_TRACES flagMask |= TCL_TRACE_OLD_STYLE; #endif tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags & flagMask; tracePtr->nextPtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr; return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclUtf.c.
1 2 3 4 5 6 7 | /* * tclUtf.c -- * * Routines for manipulating UTF-8 strings. * * Copyright (c) 1997-1998 Sun Microsystems, Inc. * | | | | | | | | | | | | | | | | | | | | | 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 | /* * 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.32.2.3 2005/09/09 18:48:40 dgp Exp $ */ #include "tclInt.h" /* * Include the static character classification tables and macros. */ #include "tclUniData.c" /* * The following macros are used for fast character category tests. The x_BITS * values are shifted right by the category value to determine whether the * given category is included in the set. */ #define ALPHA_BITS ((1 << UPPERCASE_LETTER) | (1 << LOWERCASE_LETTER) \ | (1 << TITLECASE_LETTER) | (1 << MODIFIER_LETTER) | (1<<OTHER_LETTER)) #define DIGIT_BITS (1 << DECIMAL_DIGIT_NUMBER) #define SPACE_BITS ((1 << SPACE_SEPARATOR) | (1 << LINE_SEPARATOR) \ | (1 << PARAGRAPH_SEPARATOR)) #define CONNECTOR_BITS (1 << CONNECTOR_PUNCTUATION) #define PRINT_BITS (ALPHA_BITS | DIGIT_BITS | SPACE_BITS | \ (1 << NON_SPACING_MARK) | (1 << ENCLOSING_MARK) | \ (1 << COMBINING_SPACING_MARK) | (1 << LETTER_NUMBER) | \ (1 << OTHER_NUMBER) | (1 << CONNECTOR_PUNCTUATION) | \ (1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) | \ (1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) | \ (1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION) | \ (1 << MATH_SYMBOL) | (1 << CURRENCY_SYMBOL) | \ (1 << MODIFIER_SYMBOL) | (1 << OTHER_SYMBOL)) #define PUNCT_BITS ((1 << CONNECTOR_PUNCTUATION) | \ (1 << DASH_PUNCTUATION) | (1 << OPEN_PUNCTUATION) | \ (1 << CLOSE_PUNCTUATION) | (1 << INITIAL_QUOTE_PUNCTUATION) | \ (1 << FINAL_QUOTE_PUNCTUATION) | (1 << OTHER_PUNCTUATION)) /* * Unicode characters less than this value are represented by themselves * in UTF-8 strings. */ #define UNICODE_SELF 0x80 |
︙ | ︙ | |||
89 90 91 92 93 94 95 | }; /* * Procedures used only in this module. */ static int UtfCount _ANSI_ARGS_((int ch)); | < | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | }; /* * Procedures used only in this module. */ static int UtfCount _ANSI_ARGS_((int ch)); /* *--------------------------------------------------------------------------- * * UtfCount -- * * Find the number of bytes in the Utf character "ch". |
︙ | ︙ | |||
140 141 142 143 144 145 146 | /* *--------------------------------------------------------------------------- * * Tcl_UniCharToUtf -- * * Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | < | | | | | | | | | | | | | | | | | | | > | | > | | | | 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 | /* *--------------------------------------------------------------------------- * * Tcl_UniCharToUtf -- * * Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the * provided buffer. Equivalent to Plan 9 runetochar(). * * Results: * The return values is the number of bytes in the buffer that were * consumed. * * Side effects: * None. * *--------------------------------------------------------------------------- */ INLINE int Tcl_UniCharToUtf(ch, buf) int ch; /* The Tcl_UniChar to be stored in the * buffer. */ char *buf; /* Buffer in which the UTF-8 representation of * the Tcl_UniChar is stored. Buffer must be * large enough to hold the UTF-8 character * (at most TCL_UTF_MAX bytes). */ { if ((ch > 0) && (ch < UNICODE_SELF)) { buf[0] = (char) ch; return 1; } if (ch >= 0) { if (ch <= 0x7FF) { buf[1] = (char) ((ch | 0x80) & 0xBF); buf[0] = (char) ((ch >> 6) | 0xC0); return 2; } if (ch <= 0xFFFF) { three: buf[2] = (char) ((ch | 0x80) & 0xBF); buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF); buf[0] = (char) ((ch >> 12) | 0xE0); return 3; } #if TCL_UTF_MAX > 3 if (ch <= 0x1FFFFF) { buf[3] = (char) ((ch | 0x80) & 0xBF); buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF); buf[1] = (char) (((ch >> 12) | 0x80) & 0xBF); buf[0] = (char) ((ch >> 18) | 0xF0); return 4; } if (ch <= 0x3FFFFFF) { buf[4] = (char) ((ch | 0x80) & 0xBF); buf[3] = (char) (((ch >> 6) | 0x80) & 0xBF); buf[2] = (char) (((ch >> 12) | 0x80) & 0xBF); buf[1] = (char) (((ch >> 18) | 0x80) & 0xBF); buf[0] = (char) ((ch >> 24) | 0xF8); return 5; } if (ch <= 0x7FFFFFFF) { buf[5] = (char) ((ch | 0x80) & 0xBF); buf[4] = (char) (((ch >> 6) | 0x80) & 0xBF); buf[3] = (char) (((ch >> 12) | 0x80) & 0xBF); buf[2] = (char) (((ch >> 18) | 0x80) & 0xBF); buf[1] = (char) (((ch >> 24) | 0x80) & 0xBF); buf[0] = (char) ((ch >> 30) | 0xFC); return 6; } #endif } ch = 0xFFFD; goto three; } /* *--------------------------------------------------------------------------- * * Tcl_UniCharToUtfDString -- * * Convert the given Unicode string to UTF-8. * * Results: * 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 * dsPtr. * * Side effects: * None. * *--------------------------------------------------------------------------- */ char * Tcl_UniCharToUtfDString(uniStr, uniLength, dsPtr) CONST Tcl_UniChar *uniStr; /* Unicode string to convert to UTF-8. */ int uniLength; /* Length of Unicode string in Tcl_UniChars * (must be >= 0). */ Tcl_DString *dsPtr; /* UTF-8 representation of string is appended * to this previously initialized DString. */ { CONST Tcl_UniChar *w, *wEnd; char *p, *string; int oldLength; /* * UTF-8 string length in bytes will be <= Unicode string length * * TCL_UTF_MAX. */ oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, (oldLength + uniLength + 1) * TCL_UTF_MAX); string = Tcl_DStringValue(dsPtr) + oldLength; p = string; wEnd = uniStr + uniLength; for (w = uniStr; w < wEnd; ) { p += Tcl_UniCharToUtf(*w, p); w++; } Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); return string; } /* *--------------------------------------------------------------------------- * * Tcl_UtfToUniChar -- * * Extract the Tcl_UniChar represented by the UTF-8 string. Bad UTF-8 * sequences are converted to valid Tcl_UniChars and processing * continues. Equivalent to Plan 9 chartorune(). * * The caller must ensure that the source buffer is long enough that this * routine does not run off the end and dereference non-existent memory * looking for trail bytes. If the source buffer is known to be '\0' * terminated, this cannot happen. Otherwise, the caller should call * Tcl_UtfCharComplete() before calling this routine to ensure that * enough bytes remain in the string. * * Results: * *chPtr is filled with the Tcl_UniChar, and the return value is the * number of bytes from the UTF-8 string that were consumed. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int Tcl_UtfToUniChar(src, chPtr) register CONST char *src; /* The UTF-8 string. */ register Tcl_UniChar *chPtr; /* Filled with the Tcl_UniChar represented by * the UTF-8 string. */ { register int byte; /* * Unroll 1 to 3 byte UTF-8 sequences, use loop to handle longer ones. */ byte = *((unsigned char *) src); if (byte < 0xC0) { /* * Handles properly formed UTF-8 characters between 0x01 and 0x7F. * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid * characters representing themselves. */ *chPtr = (Tcl_UniChar) byte; return 1; } else if (byte < 0xE0) { if ((src[1] & 0xC0) == 0x80) { /* * Two-byte-character lead-byte followed by a trail-byte. */ *chPtr = (Tcl_UniChar) (((byte & 0x1F) << 6) | (src[1] & 0x3F)); return 2; } /* * A two-byte-character lead-byte not followed by trail-byte * represents itself. */ *chPtr = (Tcl_UniChar) byte; return 1; } else if (byte < 0xF0) { if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) { /* * Three-byte-character lead byte followed by two trail bytes. */ *chPtr = (Tcl_UniChar) (((byte & 0x0F) << 12) | ((src[1] & 0x3F) << 6) | (src[2] & 0x3F)); return 3; } /* * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. */ *chPtr = (Tcl_UniChar) byte; return 1; } #if TCL_UTF_MAX > 3 else { int ch, total, trail; total = totalBytes[byte]; trail = total - 1; if (trail > 0) { ch = byte & (0x3F >> trail); do { src++; if ((*src & 0xC0) != 0x80) { *chPtr = byte; return 1; } ch <<= 6; ch |= (*src & 0x3F); trail--; } while (trail > 0); *chPtr = ch; return total; } } #endif |
︙ | ︙ | |||
379 380 381 382 383 384 385 | * * Tcl_UtfToUniCharDString -- * * Convert the UTF-8 string to Unicode. * * Results: * The return value is a pointer to the Unicode representation of the | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | < | | | | | | | | | | | < | | | | | | | | | | | | | | | | < | | | | | | | | 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 | * * Tcl_UtfToUniCharDString -- * * Convert the UTF-8 string to Unicode. * * Results: * 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 * dsPtr. The Unicode string is terminated with a Unicode NULL character. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_UniChar * Tcl_UtfToUniCharDString(src, length, dsPtr) CONST char *src; /* UTF-8 string to convert to Unicode. */ int length; /* Length of UTF-8 string in bytes, or -1 for * strlen(). */ Tcl_DString *dsPtr; /* Unicode representation of string is * appended to this previously initialized * DString. */ { Tcl_UniChar *w, *wString; CONST char *p, *end; int oldLength; if (length < 0) { length = strlen(src); } /* * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in * bytes. */ oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, (int) ((oldLength + length + 1) * sizeof(Tcl_UniChar))); wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength); w = wString; end = src + length; for (p = src; p < end; ) { p += TclUtfToUniChar(p, w); w++; } *w = '\0'; Tcl_DStringSetLength(dsPtr, (oldLength + ((char *) w - (char *) wString))); return wString; } /* *--------------------------------------------------------------------------- * * Tcl_UtfCharComplete -- * * Determine if the UTF-8 string of the given length is long enough to be * decoded by Tcl_UtfToUniChar(). This does not ensure that the UTF-8 * string is properly formed. Equivalent to Plan 9 fullrune(). * * Results: * The return value is 0 if the string is not long enough, non-zero * otherwise. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int Tcl_UtfCharComplete(src, length) CONST char *src; /* String to check if first few bytes contain * a complete UTF-8 character. */ int length; /* Length of above string in bytes. */ { int ch; ch = *((unsigned char *) src); return length >= totalBytes[ch]; } /* *--------------------------------------------------------------------------- * * Tcl_NumUtfChars -- * * Returns the number of characters (not bytes) in the UTF-8 string, not * including the terminating NULL byte. This is equivalent to Plan 9 * utflen() and utfnlen(). * * Results: * As above. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int Tcl_NumUtfChars(src, length) register CONST char *src; /* The UTF-8 string to measure. */ int length; /* The length of the string in bytes, or -1 * for strlen(string). */ { Tcl_UniChar ch; register Tcl_UniChar *chPtr = &ch; register int i; /* * The separate implementations are faster. * * Since this is a time-sensitive function, we also do the check for the * single-byte char case specially. */ i = 0; if (length < 0) { while (*src != '\0') { src += TclUtfToUniChar(src, chPtr); i++; } } else { register int n; while (length > 0) { if (UCHAR(*src) < 0xC0) { length--; src++; } else { n = Tcl_UtfToUniChar(src, chPtr); length -= n; src += n; } i++; } } return i; } /* *--------------------------------------------------------------------------- * * Tcl_UtfFindFirst -- * * Returns a pointer to the first occurance of the given Tcl_UniChar in * the NULL-terminated UTF-8 string. The NULL terminator is considered * part of the UTF-8 string. Equivalent to Plan 9 utfrune(). * * Results: * As above. If the Tcl_UniChar does not exist in the given string, the * return value is NULL. * * Side effects: * None. * *--------------------------------------------------------------------------- */ CONST char * Tcl_UtfFindFirst(src, ch) CONST char *src; /* The UTF-8 string to be searched. */ int ch; /* The Tcl_UniChar to search for. */ { int len; Tcl_UniChar find; while (1) { len = TclUtfToUniChar(src, &find); if (find == ch) { return src; } if (*src == '\0') { return NULL; } src += len; } } /* *--------------------------------------------------------------------------- * * Tcl_UtfFindLast -- * * Returns a pointer to the last occurance of the given Tcl_UniChar in * the NULL-terminated UTF-8 string. The NULL terminator is considered * part of the UTF-8 string. Equivalent to Plan 9 utfrrune(). * * Results: * As above. If the Tcl_UniChar does not exist in the given string, the * return value is NULL. * * Side effects: * None. * *--------------------------------------------------------------------------- */ CONST char * Tcl_UtfFindLast(src, ch) CONST char *src; /* The UTF-8 string to be searched. */ int ch; /* The Tcl_UniChar to search for. */ { int len; Tcl_UniChar find; CONST char *last; last = NULL; while (1) { len = TclUtfToUniChar(src, &find); if (find == ch) { last = src; } if (*src == '\0') { break; } src += len; } return last; } /* *--------------------------------------------------------------------------- * * Tcl_UtfNext -- * * Given a pointer to some current location in a UTF-8 string, move * forward one character. The caller must ensure that they are not asking * for the next character after the last character in the string. * * Results: * The return value is the pointer to the next character in the UTF-8 * string. * * Side effects: * None. * *--------------------------------------------------------------------------- */ CONST char * Tcl_UtfNext(src) CONST char *src; /* The current location in the string. */ { Tcl_UniChar ch; return src + TclUtfToUniChar(src, &ch); } /* *--------------------------------------------------------------------------- * * Tcl_UtfPrev -- * * Given a pointer to some current location in a UTF-8 string, move * backwards one character. This works correctly when the pointer is in * the middle of a UTF-8 character. * * Results: * The return value is a pointer to the previous character in the UTF-8 * string. If the current location was already at the beginning of the * string, the return value will also be a pointer to the beginning of * the string. * * Side effects: * None. * *--------------------------------------------------------------------------- */ CONST char * Tcl_UtfPrev(src, start) CONST char *src; /* The current location in the string. */ CONST char *start; /* Pointer to the beginning of the string, to * avoid going backwards too far. */ { CONST char *look; int i, byte; src--; look = src; for (i = 0; i < TCL_UTF_MAX; i++) { if (look < start) { if (src < start) { src = start; } break; } byte = *((unsigned char *) look); if (byte < 0x80) { break; } if (byte >= 0xC0) { return look; } look--; } return src; } /* *--------------------------------------------------------------------------- * * Tcl_UniCharAtIndex -- * * Returns the Unicode character represented at the specified character * (not byte) position in the UTF-8 string. * * Results: * As above. * * Side effects: * None. * |
︙ | ︙ | |||
718 719 720 721 722 723 724 | } /* *--------------------------------------------------------------------------- * * Tcl_UtfAtIndex -- * | | | | 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 | } /* *--------------------------------------------------------------------------- * * Tcl_UtfAtIndex -- * * Returns a pointer to the specified character (not byte) position in * the UTF-8 string. * * Results: * As above. * * Side effects: * None. * |
︙ | ︙ | |||
753 754 755 756 757 758 759 | * * Tcl_UtfBackslash -- * * Figure out how to handle a backslash sequence. * * Results: * Stores the bytes represented by the backslash sequence in dst and | | | | | | | | | | < | | | | | | | 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 | * * Tcl_UtfBackslash -- * * Figure out how to handle a backslash sequence. * * Results: * Stores the bytes represented by the backslash sequence in dst and * returns the number of bytes written to dst. At most TCL_UTF_MAX bytes * are written to dst; dst must have been large enough to accept those * bytes. If readPtr isn't NULL then it is filled in with a count of the * number of bytes in the backslash sequence. * * Side effects: * The maximum number of bytes it takes to represent a Unicode character * in UTF-8 is guaranteed to be less than the number of bytes used to * express the backslash sequence that represents that Unicode character. * If the target buffer into which the caller is going to store the bytes * that represent the Unicode character is at least as large as the * source buffer from which the backslashed sequence was extracted, no * buffer overruns should occur. * *--------------------------------------------------------------------------- */ int Tcl_UtfBackslash(src, readPtr, dst) 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; |
︙ | ︙ | |||
800 801 802 803 804 805 806 | } /* *---------------------------------------------------------------------- * * Tcl_UtfToUpper -- * | | | | | | 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 | } /* *---------------------------------------------------------------------- * * Tcl_UtfToUpper -- * * Convert lowercase characters to uppercase characters in a UTF string * in place. The conversion may shrink the UTF string. * * Results: * Returns the number of bytes in the resulting string excluding the * trailing null. * * Side effects: * Writes a terminating null after the last converted character. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
827 828 829 830 831 832 833 | /* * Iterate over the string until we hit the terminating null. */ src = dst = str; while (*src) { | | | | | | | | | | 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 | /* * Iterate over the string until we hit the terminating null. */ src = dst = str; while (*src) { bytes = TclUtfToUniChar(src, &ch); upChar = Tcl_UniCharToUpper(ch); /* * To keep badly formed Utf strings from getting inflated by the * conversion (thereby causing a segfault), only copy the upper case * char to dst if its size is <= the original char. */ if (bytes < UtfCount(upChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { dst += Tcl_UniCharToUtf(upChar, dst); } src += bytes; } *dst = '\0'; return (dst - str); } /* *---------------------------------------------------------------------- * * Tcl_UtfToLower -- * * Convert uppercase characters to lowercase characters in a UTF string * in place. The conversion may shrink the UTF string. * * Results: * Returns the number of bytes in the resulting string excluding the * trailing null. * * Side effects: * Writes a terminating null after the last converted character. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
884 885 886 887 888 889 890 | src = dst = str; while (*src) { bytes = TclUtfToUniChar(src, &ch); lowChar = Tcl_UniCharToLower(ch); /* | | | | | | | | | | 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 | src = dst = str; while (*src) { bytes = TclUtfToUniChar(src, &ch); lowChar = Tcl_UniCharToLower(ch); /* * To keep badly formed Utf strings from getting inflated by the * conversion (thereby causing a segfault), only copy the lower case * char to dst if its size is <= the original char. */ if (bytes < UtfCount(lowChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { dst += Tcl_UniCharToUtf(lowChar, dst); } src += bytes; } *dst = '\0'; return (dst - str); } /* *---------------------------------------------------------------------- * * Tcl_UtfToTitle -- * * Changes the first character of a UTF string to title case or uppercase * and the rest of the string to lowercase. The conversion happens in * place and may shrink the UTF string. * * Results: * Returns the number of bytes in the resulting string excluding the * trailing null. * * Side effects: * Writes a terminating null after the last converted character. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
968 969 970 971 972 973 974 | } /* *---------------------------------------------------------------------- * * TclpUtfNcmp2 -- * | | | | | | > > | | | | > | | | > | | | | > | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TclpUtfNcmp2 -- * * Compare at most n bytes of utf-8 strings cs and ct. Both cs and ct are * assumed to be at least n bytes long. * * Results: * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclpUtfNcmp2(cs, ct, n) CONST char *cs; /* UTF string to compare to ct. */ CONST char *ct; /* UTF string cs is compared to. */ unsigned long n; /* Number of *bytes* to compare. */ { /* * We can't simply call 'memcmp(cs, ct, n);' because we need to check for * Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes fine in * the strcmp manner. */ register int result = 0; for ( ; n != 0; n--, cs++, ct++) { if (*cs != *ct) { result = UCHAR(*cs) - UCHAR(*ct); break; } } if (n && ((UCHAR(*cs) == 0xC0) || (UCHAR(*ct) == 0xC0))) { unsigned char c1, c2; c1 = ((UCHAR(*cs) == 0xC0) && (UCHAR(cs[1]) == 0x80)) ? 0 : UCHAR(*cs); c2 = ((UCHAR(*ct) == 0xC0) && (UCHAR(ct[1]) == 0x80)) ? 0 : UCHAR(*ct); result = (c1 - c2); } return result; } /* *---------------------------------------------------------------------- * * Tcl_UtfNcmp -- * * Compare at most numChars UTF chars of string cs to string ct. Both cs * and ct are assumed to be at least numChars UTF chars long. * * Results: * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_UtfNcmp(cs, ct, numChars) CONST char *cs; /* UTF string to compare to ct. */ CONST char *ct; /* UTF string cs is compared to. */ unsigned long numChars; /* Number of UTF chars to compare. */ { Tcl_UniChar ch1, ch2; /* * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the * pair of bytes 0xc0,0x80) is larger than byte representation of \u0001 * (the byte 0x01.) */ while (numChars-- > 0) { /* * n must be interpreted as chars, not bytes. This should be called * only when both strings are of at least n chars long (no need for \0 * check) */ cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { return (ch1 - ch2); } } return 0; } /* *---------------------------------------------------------------------- * * Tcl_UtfNcasecmp -- * * Compare at most numChars UTF chars of string cs to string ct case * insensitive. Both cs and ct are assumed to be at least numChars * UTF chars long. * * Results: * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_UtfNcasecmp(cs, ct, numChars) CONST char *cs; /* UTF string to compare to ct. */ CONST char *ct; /* UTF string cs is compared to. */ unsigned long numChars; /* Number of UTF chars to compare. */ { Tcl_UniChar ch1, ch2; while (numChars-- > 0) { /* * n must be interpreted as chars, not bytes. * This should be called only when both strings are of * at least n chars long (no need for \0 check) */ cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); |
︙ | ︙ | |||
1208 1209 1210 1211 1212 1213 1214 | * Side effects: * None. * *---------------------------------------------------------------------- */ int | | | | | | | | | | | | > | | > | | | | | | | | | | | | | | 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 | * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_UniCharLen(uniStr) CONST Tcl_UniChar *uniStr; /* Unicode string to find length of. */ { int len = 0; while (*uniStr != '\0') { len++; uniStr++; } return len; } /* *---------------------------------------------------------------------- * * Tcl_UniCharNcmp -- * * Compare at most numChars unichars of string ucs to string uct. * Both ucs and uct are assumed to be at least numChars unichars long. * * Results: * Return <0 if ucs < uct, 0 if ucs == uct, or >0 if ucs > uct. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_UniCharNcmp(ucs, uct, numChars) CONST Tcl_UniChar *ucs; /* Unicode string to compare to uct. */ CONST Tcl_UniChar *uct; /* Unicode string ucs is compared to. */ unsigned long numChars; /* Number of unichars to compare. */ { #ifdef WORDS_BIGENDIAN /* * We are definitely on a big-endian machine; memcmp() is safe */ return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); #else /* !WORDS_BIGENDIAN */ /* * We can't simply call memcmp() because that is not lexically correct. */ for ( ; numChars != 0; ucs++, uct++, numChars--) { if (*ucs != *uct) { return (*ucs - *uct); } } return 0; #endif /* WORDS_BIGENDIAN */ } /* *---------------------------------------------------------------------- * * Tcl_UniCharNcasecmp -- * * Compare at most numChars unichars of string ucs to string uct case * insensitive. Both ucs and uct are assumed to be at least numChars * unichars long. * * Results: * Return <0 if ucs < uct, 0 if ucs == uct, or >0 if ucs > uct. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_UniCharNcasecmp(ucs, uct, numChars) CONST Tcl_UniChar *ucs; /* Unicode string to compare to uct. */ CONST Tcl_UniChar *uct; /* Unicode string ucs is compared to. */ unsigned long numChars; /* Number of unichars to compare. */ { for ( ; numChars != 0; numChars--, ucs++, uct++) { if (*ucs != *uct) { Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); Tcl_UniChar lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { return (lcs - lct); } } } return 0; } |
︙ | ︙ | |||
1552 1553 1554 1555 1556 1557 1558 | } /* *---------------------------------------------------------------------- * * Tcl_UniCharIsWordChar -- * | | < | 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 | } /* *---------------------------------------------------------------------- * * Tcl_UniCharIsWordChar -- * * Test if a character is alphanumeric or a connector punctuation mark. * * Results: * Returns 1 if character is a word character. * * Side effects: * None. * |
︙ | ︙ | |||
1579 1580 1581 1582 1583 1584 1585 | /* *---------------------------------------------------------------------- * * Tcl_UniCharCaseMatch -- * * See if a particular Unicode string matches a particular pattern. | | | | | | | | < | | > | | | | | | | | | | > | > > | > | | | | > | | > | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | > | | | | | | | | < | | | | | | | | > | > > | > | 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 | /* *---------------------------------------------------------------------- * * Tcl_UniCharCaseMatch -- * * See if a particular Unicode string matches a particular pattern. * Allows case insensitivity. This is the Unicode equivalent of the char* * Tcl_StringCaseMatch. The UniChar strings must be NULL-terminated. * This has no provision for counted UniChar strings, thus should not be * used where NULLs are expected in the UniChar string. Use * TclUniCharMatch where possible. * * Results: * The return value is 1 if string matches pattern, and 0 otherwise. The * matching operation permits the following special characters in the * pattern: *?\[] (see the manual entry for details on what these mean). * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase) CONST Tcl_UniChar *uniStr; /* Unicode String. */ CONST Tcl_UniChar *uniPattern; /* Pattern, which may contain special * characters. */ int nocase; /* 0 for case sensitive, 1 for insensitive */ { Tcl_UniChar ch1, p; while (1) { p = *uniPattern; /* * See if we're at the end of both the pattern and the string. If so, * we succeeded. If we're at the end of the pattern but not at the end * of the string, we failed. */ if (p == 0) { return (*uniStr == 0); } if ((*uniStr == 0) && (p != '*')) { return 0; } /* * Check for a "*" as the next pattern character. It matches any * substring. We handle this by skipping all the characters up to the * next matching one in the pattern, and then calling ourselves * recursively for each postfix of string, until either we match or we * reach the end of the string. */ if (p == '*') { /* * Skip all successive *'s in the pattern */ while (*(++uniPattern) == '*') { /* empty body */ } p = *uniPattern; if (p == 0) { return 1; } if (nocase) { p = Tcl_UniCharToLower(p); } while (1) { /* * Optimization for matching - cruise through the string * quickly if the next char in the pattern isn't a special * character */ if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while (*uniStr && (p != *uniStr) && (p != Tcl_UniCharToLower(*uniStr))) { uniStr++; } } else { while (*uniStr && (p != *uniStr)) { uniStr++; } } } if (Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase)) { return 1; } if (*uniStr == 0) { return 0; } uniStr++; } } /* * Check for a "?" as the next pattern character. It matches any * single character. */ if (p == '?') { uniPattern++; uniStr++; continue; } /* * Check for a "[" as the next pattern character. It is followed by a * list of characters that are acceptable, or by a range (two * characters separated by "-"). */ if (p == '[') { Tcl_UniChar startChar, endChar; uniPattern++; ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); uniStr++; while (1) { if ((*uniPattern == ']') || (*uniPattern == 0)) { return 0; } startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) : *uniPattern); uniPattern++; if (*uniPattern == '-') { uniPattern++; if (*uniPattern == 0) { return 0; } endChar = (nocase ? Tcl_UniCharToLower(*uniPattern) : *uniPattern); uniPattern++; if (((startChar <= ch1) && (ch1 <= endChar)) || ((endChar <= ch1) && (ch1 <= startChar))) { /* * Matches ranges of form [a-z] or [z-a]. */ break; } } else if (startChar == ch1) { break; } } while (*uniPattern != ']') { if (*uniPattern == 0) { uniPattern--; break; } uniPattern++; } uniPattern++; continue; } /* * If the next pattern character is '\', just strip off the '\' so we * do exact matching on the character that follows. */ if (p == '\\') { if (*(++uniPattern) == '\0') { return 0; } } /* * There's no special character. Just make sure that the next bytes * of each string match. */ if (nocase) { if (Tcl_UniCharToLower(*uniStr) != Tcl_UniCharToLower(*uniPattern)) { return 0; } } else if (*uniStr != *uniPattern) { return 0; } uniStr++; uniPattern++; } } /* *---------------------------------------------------------------------- * * TclUniCharMatch -- * * See if a particular Unicode string matches a particular pattern. * Allows case insensitivity. This is the Unicode equivalent of the char* * Tcl_StringCaseMatch. This variant of Tcl_UniCharCaseMatch uses counted * Strings, so embedded NULLs are allowed. * * Results: * The return value is 1 if string matches pattern, and 0 otherwise. The * matching operation permits the following special characters in the * pattern: *?\[] (see the manual entry for details on what these mean). * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclUniCharMatch(string, strLen, pattern, ptnLen, nocase) CONST Tcl_UniChar *string; /* Unicode String. */ int strLen; /* length of String */ CONST Tcl_UniChar *pattern; /* Pattern, which may contain special * characters. */ int ptnLen; /* length of Pattern */ int nocase; /* 0 for case sensitive, 1 for insensitive */ { CONST Tcl_UniChar *stringEnd, *patternEnd; Tcl_UniChar p; stringEnd = string + strLen; patternEnd = pattern + ptnLen; while (1) { /* * See if we're at the end of both the pattern and the string. If so, * we succeeded. If we're at the end of the pattern but not at the end * of the string, we failed. */ if (pattern == patternEnd) { return (string == stringEnd); } p = *pattern; if ((string == stringEnd) && (p != '*')) { return 0; } /* * Check for a "*" as the next pattern character. It matches any * substring. We handle this by skipping all the characters up to the * next matching one in the pattern, and then calling ourselves * recursively for each postfix of string, until either we match or we * reach the end of the string. */ if (p == '*') { /* * Skip all successive *'s in the pattern. */ while (*(++pattern) == '*') { /* empty body */ } if (pattern == patternEnd) { return 1; } p = *pattern; if (nocase) { p = Tcl_UniCharToLower(p); } while (1) { /* * Optimization for matching - cruise through the string * quickly if the next char in the pattern isn't a special * character. */ if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while ((string < stringEnd) && (p != *string) && (p != Tcl_UniCharToLower(*string))) { string++; } } else { |
︙ | ︙ | |||
1857 1858 1859 1860 1861 1862 1863 | return 0; } string++; } } /* | | | | | | | 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 | return 0; } string++; } } /* * Check for a "?" as the next pattern character. It matches any * single character. */ if (p == '?') { pattern++; string++; continue; } /* * Check for a "[" as the next pattern character. It is followed by a * list of characters that are acceptable, or by a range (two * characters separated by "-"). */ if (p == '[') { Tcl_UniChar ch1, startChar, endChar; pattern++; ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string); |
︙ | ︙ | |||
1916 1917 1918 1919 1920 1921 1922 | pattern++; } pattern++; continue; } /* | | | | | > > > > > > > > | 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 | pattern++; } pattern++; continue; } /* * If the next pattern character is '\', just strip off the '\' so we * do exact matching on the character that follows. */ if (p == '\\') { if (++pattern == patternEnd) { return 0; } } /* * There's no special character. Just make sure that the next bytes of * each string match. */ if (nocase) { if (Tcl_UniCharToLower(*string) != Tcl_UniCharToLower(*pattern)) { return 0; } } else if (*string != *pattern) { return 0; } string++; pattern++; } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclUtil.c.
|
| | | | | | > > | | | | | | | | | | | | | | | | | < | < < < < < < < | | | | > > | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | /* * tclUtil.c -- * * This file contains utility functions 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.51.2.20 2005/09/15 20:58:40 dgp Exp $ */ #include "tclInt.h" #include <float.h> #include <math.h> /* * The absolute pathname of the executable in which this Tcl library * is running. */ static ProcessGlobalValue executableName = {0, 0, NULL, NULL, NULL, NULL, NULL}; /* * The following values are used in the flags returned by Tcl_ScanElement and * used by Tcl_ConvertElement. The values TCL_DONT_USE_BRACES and * TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value overlaps * with any of the values below. * * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in * braces (e.g. it contains unmatched braces, or * ends in a backslash character, or user just * doesn't want braces); handle all special * characters by adding backslashes. * USE_BRACES - 1 means the string contains a special * character that can be handled simply by * enclosing the entire argument in braces. * BRACES_UNMATCHED - 1 means that braces aren't properly matched in * the argument. * TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading hash * character ('#') should *not* be quoted. This * is appropriate when the caller can guarantee * the element is not the first element of a * list, so [eval] cannot mis-parse the element * as a comment. */ #define USE_BRACES 2 #define BRACES_UNMATCHED 4 /* * The following key is used by Tcl_PrintDouble and TclPrecTraceProc to * access the precision to be used for double formatting. */ static Tcl_ThreadDataKey precisionKey; /* * Prototypes for functions defined later in this file. */ static void ClearHash _ANSI_ARGS_((Tcl_HashTable *tablePtr)); static void FreeProcessGlobalValue _ANSI_ARGS_(( ClientData clientData)); static void FreeThreadHash _ANSI_ARGS_((ClientData clientData)); static Tcl_HashTable * GetThreadHash _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr)); static int ParseInteger _ANSI_ARGS_((CONST char *bytes, int numBytes)); static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* objPtr)); static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a * performance optimization in TclGetIntForIndex. The internal rep is an * integer, so no memory management is required for it. */ Tcl_ObjType tclEndOffsetType = { "end-offset", /* name */ (Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */ (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */ UpdateStringOfEndOffset, /* updateStringProc */ SetEndOffsetFromAny }; /* *---------------------------------------------------------------------- * * TclFindElement -- * * Given a pointer into a Tcl list, locate the first (or next) element in * the list. * * Results: * The return value is normally TCL_OK, which means that the element was * successfully located. If TCL_ERROR is returned it means that list * didn't have proper list structure; the interp's result contains a more * detailed error message. * * If TCL_OK is returned, then *elementPtr will be set to point to the * first element of list, and *nextPtr will be set to point to the * character just after any white space following the last character * that's part of the element. If this is the last argument in the list, * then *nextPtr will point just after the last character in the list * (i.e., at the character at list+listLength). If sizePtr is non-NULL, * *sizePtr is filled in with the number of characters in the element. If * the element is in braces, then *elementPtr will point to the character * after the opening brace and *sizePtr will not include either of the * braces. If there isn't an element in the list, *sizePtr will be zero, * and both *elementPtr and *termPtr will point just after the last * character in the list. Note: this function does NOT collapse backslash * sequences. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, bracePtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. If * NULL, then no error message is left after * errors. */ CONST char *list; /* Points to the first byte of a string * containing a Tcl list with zero or more * elements (possibly in braces). */ int listLength; /* Number of bytes in the list's string. */ CONST char **elementPtr; /* Where to put address of first significant * character in first element of list. */ CONST char **nextPtr; /* Fill in with location of character just * after all white space following end of * argument (next arg or end of list). */ int *sizePtr; /* If non-zero, fill in with size of * element. */ int *bracePtr; /* If non-zero, fill in with non-zero/zero to * indicate that arg was/wasn't in braces. */ { CONST char *p = list; CONST char *elemStart; /* Points to first byte of first element. */ CONST char *limit; /* Points just after list's last byte. */ int openBraces = 0; /* Brace nesting level during parse. */ int inQuotes = 0; int size = 0; /* lint. */ int numChars; CONST char *p2; /* * Skim off leading white space and check for an opening brace or quote. * We treat embedded NULLs in the list as bytes belonging to a list * element. */ limit = (list + listLength); while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ p++; } if (p == limit) { /* no element found */ |
︙ | ︙ | |||
187 188 189 190 191 192 193 | /* * Find element's end (a space, close brace, or the end of the string). */ while (p < limit) { switch (*p) { | < | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | < | 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 | /* * Find element's end (a space, close brace, or the end of the string). */ while (p < limit) { switch (*p) { /* * Open brace: don't treat specially unless the element is in * braces. In this case, keep a nesting count. */ case '{': if (openBraces != 0) { openBraces++; } break; /* * Close brace: if element is in braces, keep nesting count and * quit when the last close brace is seen. */ case '}': if (openBraces > 1) { openBraces--; } else if (openBraces == 1) { size = (p - elemStart); p++; if ((p >= limit) || isspace(UCHAR(*p))) { /* INTL: ISO space. */ goto done; } /* * Garbage after the closing brace; return an error. */ if (interp != NULL) { Tcl_Obj *objPtr = Tcl_NewObj(); p2 = p; while ((p2 < limit) && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ && (p2 < p+20)) { p2++; } TclObjPrintf(NULL, objPtr, "list element in braces followed by \"%.*s\" " "instead of space", (int) (p2-p), p); Tcl_SetObjResult(interp, objPtr); } return TCL_ERROR; } break; /* * Backslash: skip over everything up to the end of the backslash * sequence. */ case '\\': Tcl_UtfBackslash(p, &numChars, NULL); p += (numChars - 1); break; /* * Space: ignore if element is in braces or quotes; otherwise * terminate element. */ case ' ': case '\f': case '\n': case '\r': case '\t': case '\v': if ((openBraces == 0) && !inQuotes) { size = (p - elemStart); goto done; } break; /* * Double-quote: if element is in quotes then terminate it. */ case '"': if (inQuotes) { size = (p - elemStart); p++; if ((p >= limit) || isspace(UCHAR(*p))) { /* INTL: ISO space */ goto done; } /* * Garbage after the closing quote; return an error. */ if (interp != NULL) { Tcl_Obj *objPtr = Tcl_NewObj(); p2 = p; while ((p2 < limit) && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ && (p2 < p+20)) { p2++; } TclObjPrintf(NULL, objPtr, "list element in quotes followed by \"%.*s\" " "instead of space", (int) (p2-p), p); Tcl_SetObjResult(interp, objPtr); } return TCL_ERROR; } break; } p++; } /* * End of list: terminate element. */ if (p == limit) { if (openBraces != 0) { |
︙ | ︙ | |||
325 326 327 328 329 330 331 | TCL_STATIC); } return TCL_ERROR; } size = (p - elemStart); } | | | | | | | 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 | TCL_STATIC); } return TCL_ERROR; } size = (p - elemStart); } done: while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ p++; } *elementPtr = elemStart; *nextPtr = p; if (sizePtr != 0) { *sizePtr = size; } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCopyAndCollapse -- * * Copy a string and eliminate any backslashes that aren't in braces. * * Results: * Count characters get copied from src to dst. Along the way, if * backslash sequences are found outside braces, the backslashes are * eliminated in the copy. After scanning count chars from source, a null * character is placed at the end of dst. Returns the number of * characters that got copied. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
393 394 395 396 397 398 399 | *---------------------------------------------------------------------- * * Tcl_SplitList -- * * Splits a list up into its constituent fields. * * Results | | | | < | | | | < | | | | | | | | | | | | | | | | | 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 | *---------------------------------------------------------------------- * * Tcl_SplitList -- * * Splits a list up into its constituent fields. * * Results * The return value is normally TCL_OK, which means that the list was * successfully split up. If TCL_ERROR is returned, it means that "list" * didn't have proper list structure; the interp's result will contain a * more detailed error message. * * *argvPtr will be filled in with the address of an array whose elements * point to the elements of list, in order. *argcPtr will get filled in * with the number of valid elements in the array. A single block of * memory is dynamically allocated to hold both the argv array and a copy * of the list (with backslashes and braces removed in the standard way). * The caller must eventually free this memory by calling free() on * *argvPtr. Note: *argvPtr and *argcPtr are only modified if the * function returns normally. * * Side effects: * Memory is allocated. * *---------------------------------------------------------------------- */ int Tcl_SplitList(interp, list, argcPtr, argvPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. If * NULL, no error message is left. */ CONST char *list; /* Pointer to string with list structure. */ int *argcPtr; /* Pointer to location to fill in with the * number of elements in the list. */ CONST char ***argvPtr; /* Pointer to place to store pointer to array * of pointers to list elements. */ { CONST char **argv; CONST char *l; char *p; int length, size, i, result, elSize, brace; CONST char *element; /* * Figure out how much space to allocate. There must be enough space for * both the array of pointers and also for a copy of the list. To estimate * the number of pointers needed, count the number of space characters in * the list. */ for (size = 1, l = list; *l != 0; l++) { if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ size++; } } size++; /* Leave space for final NULL pointer. */ argv = (CONST char **) ckalloc((unsigned) ((size * sizeof(char *)) + (l - list) + 1)); length = strlen(list); for (i = 0, p = ((char *) argv) + size*sizeof(char *); *list != 0; i++) { CONST char *prevList = list; result = TclFindElement(interp, list, length, &element, &list, &elSize, &brace); length -= (list - prevList); if (result != TCL_OK) { ckfree((char *) argv); return result; } |
︙ | ︙ | |||
492 493 494 495 496 497 498 | } /* *---------------------------------------------------------------------- * * Tcl_ScanElement -- * | | | | < | | | | < | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 | } /* *---------------------------------------------------------------------- * * Tcl_ScanElement -- * * This function is a companion function to Tcl_ConvertElement. It scans * a string to see what needs to be done to it (e.g. add backslashes or * enclosing braces) to make the string into a valid Tcl list element. * * Results: * The return value is an overestimate of the number of characters that * will be needed by Tcl_ConvertElement to produce a valid list element * from string. The word at *flagPtr is filled in with a value needed by * Tcl_ConvertElement when doing the actual conversion. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
524 525 526 527 528 529 530 | } /* *---------------------------------------------------------------------- * * Tcl_ScanCountedElement -- * | < | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | } /* *---------------------------------------------------------------------- * * Tcl_ScanCountedElement -- * * This function is a companion function to Tcl_ConvertCountedElement. It * scans a string to see what needs to be done to it (e.g. add * backslashes or enclosing braces) to make the string into a valid Tcl * list element. If length is -1, then the string is scanned up to the * first null byte. * * Results: * The return value is an overestimate of the number of characters that * will be needed by Tcl_ConvertCountedElement to produce a valid list * element from string. The word at *flagPtr is filled in with a value * needed by Tcl_ConvertCountedElement when doing the actual conversion. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_ScanCountedElement(string, length, flagPtr) CONST char *string; /* String to convert to Tcl list element. */ int length; /* Number of bytes in string, or -1. */ int *flagPtr; /* Where to store information to guide * Tcl_ConvertElement. */ { int flags, nestingLevel; register CONST char *p, *lastChar; /* * This function and Tcl_ConvertElement together do two things: * * 1. They produce a proper list, one that will yield back the argument * strings when evaluated or when disassembled with Tcl_SplitList. This * is the most important thing. * * 2. They try to produce legible output, which means minimizing the use * of backslashes (using braces instead). However, there are some * situations where backslashes must be used (e.g. an element like * "{abc": the leading brace will have to be backslashed. For each * element, one of three things must be done: * * (a) Use the element as-is (it doesn't contain any special * characters). This is the most desirable option. * * (b) Enclose the element in braces, but leave the contents alone. * This happens if the element contains embedded space, or if it * contains characters with special interpretation ($, [, ;, or \), * or if it starts with a brace or double-quote, or if there are no * characters in the element. * * (c) Don't enclose the element in braces, but add backslashes to * prevent special interpretation of special characters. This is a * last resort used when the argument would normally fall under * case (b) but contains unmatched braces. It also occurs if the * last character of the argument is a backslash or if the element * contains a backslash followed by newline. * * The function figures out how many bytes will be needed to store the * result (actually, it overestimates). It also collects information about * the element in the form of a flags word. * * Note: list elements produced by this function and * Tcl_ConvertCountedElement must have the property that they can be * enclosing in curly braces to make sub-lists. This means, for example, * that we must not leave unmatched curly braces in the resulting list * element. This property is necessary in order for functions like * Tcl_DStringStartSublist to work. */ nestingLevel = 0; flags = 0; if (string == NULL) { string = ""; } if (length == -1) { length = strlen(string); } lastChar = string + length; p = string; if ((p == lastChar) || (*p == '{') || (*p == '"')) { flags |= USE_BRACES; } for (; p < lastChar; p++) { switch (*p) { case '{': nestingLevel++; break; case '}': nestingLevel--; if (nestingLevel < 0) { flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; } break; case '[': case '$': case ';': case ' ': case '\f': case '\n': case '\r': case '\t': case '\v': flags |= USE_BRACES; break; case '\\': if ((p+1 == lastChar) || (p[1] == '\n')) { flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; } else { int size; Tcl_UtfBackslash(p, &size, NULL); p += size-1; flags |= USE_BRACES; } break; } } if (nestingLevel != 0) { flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; } *flagPtr = flags; /* * Allow enough space to backslash every character plus leave two spaces * for braces. */ return 2*(p-string) + 2; } /* *---------------------------------------------------------------------- * * Tcl_ConvertElement -- * * This is a companion function to Tcl_ScanElement. Given the information * produced by Tcl_ScanElement, this function converts a string to a list * element equal to that string. * * Results: * Information is copied to *dst in the form of a list element identical * to src (i.e. if Tcl_SplitList is applied to dst it will produce a * string identical to src). The return value is a count of the number of * characters copied (not including the terminating NULL character). * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
692 693 694 695 696 697 698 | } /* *---------------------------------------------------------------------- * * Tcl_ConvertCountedElement -- * | | | | < | | | | < | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_ConvertCountedElement -- * * This is a companion function to Tcl_ScanCountedElement. Given the * information produced by Tcl_ScanCountedElement, this function converts * a string to a list element equal to that string. * * Results: * Information is copied to *dst in the form of a list element identical * to src (i.e. if Tcl_SplitList is applied to dst it will produce a * string identical to src). The return value is a count of the number of * characters copied (not including the terminating NULL character). * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_ConvertCountedElement(src, length, dst, flags) register CONST char *src; /* Source information for list element. */ int length; /* Number of bytes in src, or -1. */ char *dst; /* Place to put list-ified element. */ int flags; /* Flags produced by Tcl_ScanElement. */ { register char *p = dst; register CONST char *lastChar; /* * See the comment block at the beginning of the Tcl_ScanElement code for * details of how this works. */ if (src && length == -1) { length = strlen(src); } if ((src == NULL) || (length == 0)) { p[0] = '{'; p[1] = '}'; p[2] = 0; return 2; } lastChar = src + length; if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { flags |= USE_BRACES; } if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { *p = '{'; p++; for (; src != lastChar; src++, p++) { *p = *src; } *p = '}'; p++; } else { if (*src == '{') { /* * Can't have a leading brace unless the whole element is enclosed * in braces. Add a backslash before the brace. Furthermore, this * may destroy the balance between open and close braces, so set * BRACES_UNMATCHED. */ p[0] = '\\'; p[1] = '{'; p += 2; src++; flags |= BRACES_UNMATCHED; } else if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { /* * Leading '#' could be seen by [eval] as the start of a comment, * if on the first element of a list, so quote it. */ p[0] = '\\'; p[1] = '#'; p += 2; src++; } for (; src != lastChar; src++) { switch (*src) { case ']': case '[': case '$': case ';': case ' ': case '\\': case '"': *p = '\\'; p++; break; case '{': case '}': /* * It may not seem necessary to backslash braces, but it is. * The reason for this is that the resulting list element may * actually be an element of a sub-list enclosed in braces * (e.g. if Tcl_DStringStartSublist has been invoked), so * there may be a brace mismatch if the braces aren't * backslashed. */ if (flags & BRACES_UNMATCHED) { *p = '\\'; p++; } break; case '\f': *p = '\\'; p++; *p = 'f'; p++; continue; case '\n': *p = '\\'; p++; *p = 'n'; p++; continue; case '\r': *p = '\\'; p++; *p = 'r'; p++; continue; case '\t': *p = '\\'; p++; *p = 't'; p++; continue; case '\v': *p = '\\'; p++; *p = 'v'; p++; continue; } *p = *src; p++; } } *p = '\0'; return p-dst; } /* *---------------------------------------------------------------------- * * Tcl_Merge -- * * Given a collection of strings, merge them together into a single * string that has proper Tcl list structured (i.e. Tcl_SplitList may be * used to retrieve strings equal to the original elements, and Tcl_Eval * will parse the string back into its original elements). * * Results: * The return value is the address of a dynamically-allocated string * containing the merged list. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
893 894 895 896 897 898 899 | /* * Pass two: copy into the result area. */ result = (char *) ckalloc((unsigned) numChars); dst = result; for (i = 0; i < argc; i++) { | | | 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 | /* * Pass two: copy into the result area. */ result = (char *) ckalloc((unsigned) numChars); dst = result; for (i = 0; i < argc; i++) { numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH) ); dst += numChars; *dst = ' '; dst++; } if (dst == result) { *dst = 0; |
︙ | ︙ | |||
919 920 921 922 923 924 925 | *---------------------------------------------------------------------- * * Tcl_Backslash -- * * Figure out how to handle a backslash sequence. * * Results: | | | | | | | | | | | | | | | 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 | *---------------------------------------------------------------------- * * Tcl_Backslash -- * * Figure out how to handle a backslash sequence. * * Results: * The return value is the character that should be substituted in place * of the backslash sequence that starts at src. If readPtr isn't NULL * then it is filled in with a count of the number of characters in the * backslash sequence. * * Side effects: * None. * *---------------------------------------------------------------------- */ char Tcl_Backslash(src, readPtr) 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 buf[TCL_UTF_MAX]; Tcl_UniChar ch; Tcl_UtfBackslash(src, readPtr, buf); TclUtfToUniChar(buf, &ch); return (char) ch; } /* *---------------------------------------------------------------------- * * Tcl_Concat -- * * Concatenate a set of strings into a single large string. * * Results: * The return value is dynamically-allocated string containing a * concatenation of all the strings in argv, with spaces between the * original argv elements. * * Side effects: * Memory is allocated for the result; the caller is responsible for * freeing the memory. * *---------------------------------------------------------------------- */ char * Tcl_Concat(argc, argv) int argc; /* Number of strings to concatenate. */ |
︙ | ︙ | |||
986 987 988 989 990 991 992 | return result; } for (p = result, i = 0; i < argc; i++) { CONST char *element; int length; /* | | | < | | 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 | return result; } for (p = result, i = 0; i < argc; i++) { CONST char *element; int length; /* * Clip white space off the front and back of the string to generate a * neater result, and ignore any empty elements. */ element = argv[i]; while (isspace(UCHAR(*element))) { /* INTL: ISO space. */ element++; } for (length = strlen(element); (length > 0) && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */ && ((length < 2) || (element[length-2] != '\\')); length--) { /* Null loop body. */ } if (length == 0) { continue; } memcpy((VOID *) p, (VOID *) element, (size_t) length); p += length; |
︙ | ︙ | |||
1027 1028 1029 1030 1031 1032 1033 | * * Tcl_ConcatObj -- * * Concatenate the strings from a set of objects into a single string * object with spaces between the original strings. * * Results: | | | | | | | < | > > > | > > > > | | | | > > > > > > | | | | | | | | | | | | | | | | | | | | < | | | | | | | | < | | | | | | | | | | | | | | | | > > > > > | | | | | > | | | | | | | | | | | | | | | | | 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 | * * Tcl_ConcatObj -- * * Concatenate the strings from a set of objects into a single string * object with spaces between the original strings. * * Results: * The return value is a new string object containing a concatenation of * the strings in objv. Its ref count is zero. * * Side effects: * A new object is created. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_ConcatObj(objc, objv) int objc; /* Number of objects to concatenate. */ Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */ { int allocSize, finalSize, length, elemLength, i; char *p; char *element; char *concatStr; Tcl_Obj *objPtr; /* * Check first to see if all the items are of list type. If so, we will * concat them together as lists, and return a list object. This is only * valid when the lists have no current string representation, since we * don't know what the original type was. An original string rep may have * lost some whitespace info when converted which could be important. */ for (i = 0; i < objc; i++) { List *listRepPtr; objPtr = objv[i]; if (objPtr->typePtr != &tclListType) { break; } listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1; if (objPtr->bytes != NULL && !listRepPtr->canonicalFlag) { break; } } if (i == objc) { Tcl_Obj **listv; int listc; objPtr = Tcl_NewListObj(0, NULL); for (i = 0; i < objc; i++) { /* * Tcl_ListObjAppendList could be used here, but this saves us a * bit of type checking (since we've already done it). Use of * INT_MAX tells us to always put the new stuff on the end. It * will be set right in Tcl_ListObjReplace. */ Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv); Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv); } return objPtr; } /* * Something cannot be determined to be safe, so build the concatenation * the slow way, using the string representations. */ allocSize = 0; for (i = 0; i < objc; i++) { objPtr = objv[i]; element = Tcl_GetStringFromObj(objPtr, &length); if ((element != NULL) && (length > 0)) { allocSize += (length + 1); } } if (allocSize == 0) { allocSize = 1; /* enough for the NULL byte at end */ } /* * Allocate storage for the concatenated result. Note that allocSize is * one more than the total number of characters, and so includes room for * the terminating NULL byte. */ concatStr = (char *) ckalloc((unsigned) allocSize); /* * Now concatenate the elements. Clip white space off the front and back * to generate a neater result, and ignore any empty elements. Also put a * null byte at the end. */ finalSize = 0; if (objc == 0) { *concatStr = '\0'; } else { p = concatStr; for (i = 0; i < objc; i++) { objPtr = objv[i]; element = Tcl_GetStringFromObj(objPtr, &elemLength); while ((elemLength > 0) && (UCHAR(*element) < 127) && isspace(UCHAR(*element))) { /* INTL: ISO C space. */ element++; elemLength--; } /* * Trim trailing white space. But, be careful not to trim a space * character if it is preceded by a backslash: in this case it * could be significant. */ while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127) && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO C space. */ && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { elemLength--; } if (elemLength == 0) { continue; /* nothing left of this element */ } memcpy((VOID *) p, (VOID *) element, (size_t) elemLength); p += elemLength; *p = ' '; p++; finalSize += (elemLength + 1); } if (p != concatStr) { p[-1] = 0; finalSize -= 1; /* we overwrote the final ' ' */ } else { *p = 0; } } TclNewObj(objPtr); objPtr->bytes = concatStr; objPtr->length = finalSize; return objPtr; } /* *---------------------------------------------------------------------- * * Tcl_StringMatch -- * * See if a particular string matches a particular pattern. * * Results: * The return value is 1 if string matches pattern, and 0 otherwise. The * matching operation permits the following special characters in the * pattern: *?\[] (see the manual entry for details on what these mean). * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_StringMatch(str, pattern) CONST char *str; /* String. */ CONST char *pattern; /* Pattern, which may contain special * characters. */ { return Tcl_StringCaseMatch(str, pattern, 0); } /* *---------------------------------------------------------------------- * * Tcl_StringCaseMatch -- * * See if a particular string matches a particular pattern. Allows case * insensitivity. * * Results: * The return value is 1 if string matches pattern, and 0 otherwise. The * matching operation permits the following special characters in the * pattern: *?\[] (see the manual entry for details on what these mean). * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_StringCaseMatch(str, pattern, nocase) CONST char *str; /* String. */ CONST char *pattern; /* Pattern, which may contain special * characters. */ int nocase; /* 0 for case sensitive, 1 for insensitive */ { int p, charLen; CONST char *pstart = pattern; Tcl_UniChar ch1, ch2; while (1) { p = *pattern; /* * See if we're at the end of both the pattern and the string. If so, * we succeeded. If we're at the end of the pattern but not at the end * of the string, we failed. */ if (p == '\0') { return (*str == '\0'); } if ((*str == '\0') && (p != '*')) { return 0; } /* * Check for a "*" as the next pattern character. It matches any * substring. We handle this by calling ourselves recursively for each * postfix of string, until either we match or we reach the end of the * string. */ if (p == '*') { /* * Skip all successive *'s in the pattern */ while (*(++pattern) == '*') {} p = *pattern; if (p == '\0') { return 1; } /* * This is a special case optimization for single-byte utf. */ if (UCHAR(*pattern) < 0x80) { ch2 = (Tcl_UniChar) (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); } else { Tcl_UtfToUniChar(pattern, &ch2); if (nocase) { ch2 = Tcl_UniCharToLower(ch2); } } while (1) { /* * Optimization for matching - cruise through the string * quickly if the next char in the pattern isn't a special * character */ if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while (*str) { charLen = TclUtfToUniChar(str, &ch1); if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) { break; } str += charLen; } } else { /* * There's no point in trying to make this code * shorter, as the number of bytes you want to compare * each time is non-constant. */ while (*str) { charLen = TclUtfToUniChar(str, &ch1); if (ch2 == ch1) { break; } str += charLen; } } } if (Tcl_StringCaseMatch(str, pattern, nocase)) { return 1; } if (*str == '\0') { return 0; } str += TclUtfToUniChar(str, &ch1); } } /* * Check for a "?" as the next pattern character. It matches any * single character. */ if (p == '?') { pattern++; str += TclUtfToUniChar(str, &ch1); continue; } /* * Check for a "[" as the next pattern character. It is followed by a * list of characters that are acceptable, or by a range (two * characters separated by "-"). */ if (p == '[') { Tcl_UniChar startChar, endChar; pattern++; if (UCHAR(*str) < 0x80) { ch1 = (Tcl_UniChar) (nocase ? tolower(UCHAR(*str)) : UCHAR(*str)); str++; } else { str += Tcl_UtfToUniChar(str, &ch1); if (nocase) { ch1 = Tcl_UniCharToLower(ch1); } } while (1) { if ((*pattern == ']') || (*pattern == '\0')) { return 0; |
︙ | ︙ | |||
1381 1382 1383 1384 1385 1386 1387 | pattern++; } pattern++; continue; } /* | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | 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 | pattern++; } pattern++; continue; } /* * If the next pattern character is '\', just strip off the '\' so we * do exact matching on the character that follows. */ if (p == '\\') { pattern++; if (*pattern == '\0') { return 0; } } /* * There's no special character. Just make sure that the next bytes of * each string match. */ str += TclUtfToUniChar(str, &ch1); pattern += TclUtfToUniChar(pattern, &ch2); if (nocase) { if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) { return 0; } } else if (ch1 != ch2) { return 0; } } } /* *---------------------------------------------------------------------- * * Tcl_DStringInit -- * * Initializes a dynamic string, discarding any previous contents of the * string (Tcl_DStringFree should have been called already if the dynamic * string was previously in use). * * Results: * None. * * Side effects: * The dynamic string is initialized to be empty. * |
︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 | } /* *---------------------------------------------------------------------- * * Tcl_DStringAppend -- * | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | < | | > | | | > | | | < | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_DStringAppend -- * * Append more bytes to the current value of a dynamic string. * * Results: * The return value is a pointer to the dynamic string's new value. * * Side effects: * Length bytes from "bytes" (or all of "bytes" if length is less than * zero) are added to the current value of the string. Memory gets * reallocated if needed to accomodate the string's new size. * *---------------------------------------------------------------------- */ char * Tcl_DStringAppend(dsPtr, bytes, length) Tcl_DString *dsPtr; /* Structure describing dynamic string. */ CONST char *bytes; /* String to append. If length is -1 then this * must be null-terminated. */ int length; /* Number of bytes from "bytes" to append. If * < 0, then append all of bytes, up to null * at end. */ { int newSize; char *dst; CONST char *end; if (length < 0) { length = strlen(bytes); } newSize = length + dsPtr->length; /* * Allocate a larger buffer for the string if the current one isn't large * enough. Allocate extra space in the new buffer so that there will be * room to grow before we have to allocate again. */ if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { char *newString; newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); memcpy((VOID *) newString, (VOID *) dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, (size_t) dsPtr->spaceAvl); } } /* * Copy the new string into the buffer at the end of the old one. */ for (dst = dsPtr->string + dsPtr->length, end = bytes+length; bytes < end; bytes++, dst++) { *dst = *bytes; } *dst = '\0'; dsPtr->length += length; return dsPtr->string; } /* *---------------------------------------------------------------------- * * Tcl_DStringAppendElement -- * * Append a list element to the current value of a dynamic string. * * Results: * The return value is a pointer to the dynamic string's new value. * * Side effects: * String is reformatted as a list element and added to the current value * of the string. Memory gets reallocated if needed to accomodate the * string's new size. * *---------------------------------------------------------------------- */ char * Tcl_DStringAppendElement(dsPtr, element) Tcl_DString *dsPtr; /* Structure describing dynamic string. */ CONST char *element; /* String to append. Must be * null-terminated. */ { int newSize, flags, strSize; char *dst; strSize = ((element== NULL) ? 0 : strlen(element)); newSize = Tcl_ScanCountedElement(element, strSize, &flags) + dsPtr->length + 1; /* * Allocate a larger buffer for the string if the current one isn't large * enough. Allocate extra space in the new buffer so that there will be * room to grow before we have to allocate again. SPECIAL NOTE: must use * memcpy, not strcpy, to copy the string to a larger buffer, since there * may be embedded NULLs in the string in some cases. */ if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { char *newString; newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); memcpy((VOID *) newString, (VOID *) dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, (size_t) dsPtr->spaceAvl); } } /* * Convert the new string to a list element and copy it into the buffer at * the end, with a space, if needed. */ dst = dsPtr->string + dsPtr->length; if (TclNeedSpace(dsPtr->string, dst)) { *dst = ' '; dst++; dsPtr->length++; /* * If we need a space to separate this element from preceding stuff, * then this element will not lead a list, and need not have it's * leading '#' quoted. */ flags |= TCL_DONT_QUOTE_HASH; } dsPtr->length += Tcl_ConvertCountedElement(element, strSize, dst, flags); return dsPtr->string; } /* *---------------------------------------------------------------------- * * Tcl_DStringSetLength -- * * Change the length of a dynamic string. This can cause the string to * either grow or shrink, depending on the value of length. * * Results: * None. * * Side effects: * The length of dsPtr is changed to length and a null byte is stored at * that position in the string. If length is larger than the space * allocated for dsPtr, then a panic occurs. * *---------------------------------------------------------------------- */ void Tcl_DStringSetLength(dsPtr, length) Tcl_DString *dsPtr; /* Structure describing dynamic string. */ int length; /* New length for dynamic string. */ { int newsize; if (length < 0) { length = 0; } if (length >= dsPtr->spaceAvl) { /* * There are two interesting cases here. In the first case, the user * may be trying to allocate a large buffer of a specific size. It * would be wasteful to overallocate that buffer, so we just allocate * enough for the requested size plus the trailing null byte. In the * second case, we are growing the buffer incrementally, so we need * behavior similar to Tcl_DStringAppend. The requested length will * usually be a small delta above the current spaceAvl, so we'll end * up doubling the old size. This won't grow the buffer quite as * quickly, but it should be close enough. */ newsize = dsPtr->spaceAvl * 2; if (length < newsize) { dsPtr->spaceAvl = newsize; } else { dsPtr->spaceAvl = length + 1; |
︙ | ︙ | |||
1691 1692 1693 1694 1695 1696 1697 | } /* *---------------------------------------------------------------------- * * Tcl_DStringFree -- * | | | | | | > | | | | | < | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_DStringFree -- * * Frees up any memory allocated for the dynamic string and reinitializes * the string to an empty state. * * Results: * None. * * Side effects: * The previous contents of the dynamic string are lost, and the new * value is an empty string. * *---------------------------------------------------------------------- */ void Tcl_DStringFree(dsPtr) Tcl_DString *dsPtr; /* Structure describing dynamic string. */ { if (dsPtr->string != dsPtr->staticSpace) { ckfree(dsPtr->string); } dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; dsPtr->staticSpace[0] = '\0'; } /* *---------------------------------------------------------------------- * * Tcl_DStringResult -- * * This function moves the value of a dynamic string into an interpreter * as its string result. Afterwards, the dynamic string is reset to an * empty string. * * Results: * None. * * Side effects: * The string is "moved" to interp's result, and any existing string * result for interp is freed. dsPtr is reinitialized to an empty string. * *---------------------------------------------------------------------- */ void Tcl_DStringResult(interp, dsPtr) Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ Tcl_DString *dsPtr; /* Dynamic string that is to become the * result of interp. */ { Tcl_ResetResult(interp); if (dsPtr->string != dsPtr->staticSpace) { interp->result = dsPtr->string; interp->freeProc = TCL_DYNAMIC; } else if (dsPtr->length < TCL_RESULT_SIZE) { interp->result = ((Interp *) interp)->resultSpace; strcpy(interp->result, dsPtr->string); } else { Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); } dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; dsPtr->staticSpace[0] = '\0'; } /* *---------------------------------------------------------------------- * * Tcl_DStringGetResult -- * * This function moves an interpreter's result into a dynamic string. * * Results: * None. * * Side effects: * The interpreter's string result is cleared, and the previous contents * of dsPtr are freed. * * If the string result is empty, the object result is moved to the * string result, then the object result is reset. * *---------------------------------------------------------------------- */ void Tcl_DStringGetResult(interp, dsPtr) Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ Tcl_DString *dsPtr; /* Dynamic string that is to become the result * of interp. */ { Interp *iPtr = (Interp *) interp; if (dsPtr->string != dsPtr->staticSpace) { ckfree(dsPtr->string); } /* * If the string result is empty, move the object result to the string * result, then reset the object result. */ (void) Tcl_GetStringResult(interp); dsPtr->length = strlen(iPtr->result); if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { |
︙ | ︙ | |||
1821 1822 1823 1824 1825 1826 1827 | dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; } else { dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); dsPtr->spaceAvl = dsPtr->length + 1; } strcpy(dsPtr->string, iPtr->result); } | | | | | | | | | < | | | | | | | | | | | | | < > > > | < < | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | > > > > > < < < | | | | | | | | < > | | | < < | < | | | < < < < | | < < | | < < < < < < | | | < | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < | | | | | | | | | | < | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | < | | < | | | | | | | < < < | < < < < < < < < < < < < < < < < < < < | | | > > | | > | < | < | < > > > > > | < | < > > > > > > > > | | > > > | > | | > > | > > > > > > | > | | | > > | | | | < | 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 | dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; } else { dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); dsPtr->spaceAvl = dsPtr->length + 1; } strcpy(dsPtr->string, iPtr->result); } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; } /* *---------------------------------------------------------------------- * * Tcl_DStringStartSublist -- * * This function adds the necessary information to a dynamic string * (e.g. " {") to start a sublist. Future element appends will be in the * sublist rather than the main list. * * Results: * None. * * Side effects: * Characters get added to the dynamic string. * *---------------------------------------------------------------------- */ void Tcl_DStringStartSublist(dsPtr) Tcl_DString *dsPtr; /* Dynamic string. */ { if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { Tcl_DStringAppend(dsPtr, " {", -1); } else { Tcl_DStringAppend(dsPtr, "{", -1); } } /* *---------------------------------------------------------------------- * * Tcl_DStringEndSublist -- * * This function adds the necessary characters to a dynamic string to end * a sublist (e.g. "}"). Future element appends will be in the enclosing * (sub)list rather than the current sublist. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_DStringEndSublist(dsPtr) Tcl_DString *dsPtr; /* Dynamic string. */ { Tcl_DStringAppend(dsPtr, "}", -1); } /* *---------------------------------------------------------------------- * * Tcl_PrintDouble -- * * Given a floating-point value, this function converts it to an ASCII * string using. * * Results: * The ASCII equivalent of "value" is written at "dst". It is written * using the current precision, and it is guaranteed to contain a decimal * point or exponent, so that it looks like a floating-point value and * not an integer. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_PrintDouble(interp, value, dst) Tcl_Interp *interp; /* Interpreter whose tcl_precision variable * used to be used to control printing. It's * ignored now. */ double value; /* Value to print as string. */ char *dst; /* Where to store converted value; must have * at least TCL_DOUBLE_SPACE characters. */ { char *p, c; int exp; int signum; char buffer[TCL_DOUBLE_SPACE]; Tcl_UniChar ch; int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int)); /* * If *precisionPtr == 0, then use TclDoubleDigits to develop a decimal * significand and exponent, then format it in E or F format as * appropriate. If *precisionPtr != 0, use the native sprintf and then * add a trailing ".0" if there is no decimal point in the rep. */ if ( *precisionPtr == 0 ) { /* * Handle NaN. */ if (TclIsNaN(value)) { TclFormatNaN(value, dst); return; } /* * Handle infinities. */ if (TclIsInfinite(value)) { if (value < 0) { strcpy(dst, "-Inf"); } else { strcpy(dst, "Inf"); } return; } /* * Ordinary (normal and denormal) values. */ exp = TclDoubleDigits(buffer, value, &signum); if (signum) { *dst++ = '-'; } p = buffer; if (exp < -3 || exp > 17) { /* * E format for numbers < 1e-3 or >= 1e17. */ *dst++ = *p++; c = *p; if (c != '\0') { *dst++ = '.'; while (c != '\0') { *dst++ = c; c = *++p; } } sprintf(dst, "e%+d", exp-1); } else { /* * F format for others. */ if (exp <= 0) { *dst++ = '0'; } c = *p; while (exp-- > 0) { if (c != '\0') { *dst++ = c; c = *++p; } else { *dst++ = '0'; } } *dst++ = '.'; if (c == '\0') { *dst++ = '0'; } else { while (++exp < 0) { *dst++ = '0'; } while (c != '\0') { *dst++ = c; c = *++p; } } *dst++ = '\0'; } } else { /* * tcl_precision is supplied, pass it to the native sprintf. */ sprintf(dst, "%.*g", *precisionPtr, value); /* * If the ASCII result looks like an integer, add ".0" so that it * doesn't look like an integer anymore. This prevents floating-point * values from being converted to integers unintentionally. Check for * ASCII specifically to speed up the function. */ for (p = dst; *p != 0; ) { if (UCHAR(*p) < 0x80) { c = *p++; } else { p += Tcl_UtfToUniChar(p, &ch); c = UCHAR(ch); } if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ return; } } p[0] = '.'; p[1] = '0'; p[2] = 0; } } /* *---------------------------------------------------------------------- * * TclPrecTraceProc -- * * This function is invoked whenever the variable "tcl_precision" is * written. * * Results: * Returns NULL if all went well, or an error message if the new value * for the variable doesn't make sense. * * Side effects: * If the new value doesn't make sense then this function undoes the * effect of the variable modification. Otherwise it modifies the format * string that's used by Tcl_PrintDouble. * *---------------------------------------------------------------------- */ /* 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. */ { Tcl_Obj* value; int prec; int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int)); /* * If the variable is unset, then recreate the trace. */ if (flags & TCL_TRACE_UNSETS) { if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { Tcl_TraceVar2(interp, name1, name2, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); } return (char *) NULL; } /* * When the variable is read, reset its value from our shared value. This * is needed in case the variable was modified in some other interpreter * so that this interpreter's value is out of date. */ if (flags & TCL_TRACE_READS) { Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(*precisionPtr), flags & TCL_GLOBAL_ONLY); return (char *) NULL; } /* * The variable is being written. Check the new value and disallow it if * it isn't reasonable or if this is a safe interpreter (we don't want * safe interpreters messing up the precision of other interpreters). */ if (Tcl_IsSafe(interp)) { return "can't modify precision from a safe interpreter"; } value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); if (value == NULL || Tcl_GetIntFromObj((Tcl_Interp*) NULL, value, &prec) != TCL_OK || prec < 0 || prec > TCL_MAX_PREC) { return "improper value for precision"; } *precisionPtr = prec; return (char *) NULL; } /* *---------------------------------------------------------------------- * * TclNeedSpace -- * * This function checks to see whether it is appropriate to add a space * before appending a new list element to an existing string. * * Results: * The return value is 1 if a space is appropriate, 0 otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclNeedSpace(start, end) CONST char *start; /* First character in string. */ CONST char *end; /* End of string (place where space will be * added, if appropriate). */ { /* * A space is needed unless either: * (a) we're at the start of the string, or */ if (end == start) { return 0; } /* * (b) we're at the start of a nested list-element, quoted with an open * curly brace; we can be nested arbitrarily deep, so long as the * first curly brace starts an element, so backtrack over open curly * braces that are trailing characters of the string; and */ end = Tcl_UtfPrev(end, start); while (*end == '{') { if (end == start) { return 0; } end = Tcl_UtfPrev(end, start); } /* * (c) the trailing character of the string is already a list-element * separator (according to TclFindElement); that is, one of these * characters: * \u0009 \t TAB * \u000A \n NEWLINE * \u000B \v VERTICAL TAB * \u000C \f FORM FEED * \u000D \r CARRIAGE RETURN * \u0020 SPACE * with the condition that the penultimate character is not a * backslash. */ if (*end > 0x20) { /* * Performance tweak. All ASCII spaces are <= 0x20. So get a quick * answer for most characters before comparing against all spaces in * the switch below. * * NOTE: Remove this if other Unicode spaces ever get accepted as * list-element separators. */ return 1; } switch (*end) { case ' ': case '\t': case '\n': case '\r': case '\v': case '\f': if ((end == start) || (end[-1] != '\\')) { return 0; } } return 1; } #if 0 /* *---------------------------------------------------------------------- * * TclLooksLikeInt -- * * This function decides whether the leading characters of a string look * like an integer or something else (such as a floating-point number or * string). * * Results: * The return value is 1 if the leading characters of p look like a valid * Tcl integer. If they look like a floating-point number (e.g. "e01" or * "2.4"), or if they don't look like a number at all, then 0 is * returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ int 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)); } #endif /* *---------------------------------------------------------------------- * * ParseInteger -- * * Scans up to numBytes bytes starting at bytes, 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. * *---------------------------------------------------------------------- */ static int ParseInteger(bytes, numBytes) CONST char *bytes; /* The string to examine. */ int numBytes; /* Max number of bytes to scan. */ { register CONST char *p = bytes; /* 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; } /* Recognize the 0 as valid integer, but x is left behind. */ return 1; } while (numBytes && isdigit(UCHAR(*p))) { /* INTL: digit */ numBytes--; p++; } if (numBytes == 0) { return (p - bytes); } if ((*p != '.') && (*p != 'e') && (*p != 'E')) { return (p - bytes); } return 0; } /* *---------------------------------------------------------------------- * * TclGetIntForIndex -- * * This function returns an integer corresponding to the list index held * in a Tcl object. The Tcl object's value is expected to be in the * format integer([+-]integer)? or the format end([+-]integer)?. * * Results: * The return value is normally TCL_OK, which means that the index was * successfully stored into the location referenced by "indexPtr". If the * Tcl object referenced by "objPtr" has the value "end", the value * stored is "endValue". If "objPtr"s values is not of one of the * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, * an error message is left in the interpreter's result object. * * Side effects: * The object referenced by "objPtr" might be converted to an integer, * wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ int TclGetIntForIndex(interp, objPtr, endValue, indexPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. If * NULL, then no error message is left after * errors. */ Tcl_Obj *objPtr; /* Points to an object containing either "end" * or an integer. */ int endValue; /* The value to be stored at "indexPtr" if * "objPtr" holds "end". */ int *indexPtr; /* Location filled in with an integer * representing an index. */ { if (Tcl_GetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { return TCL_OK; } if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { /* * If the object is already an offset from the end of the list, or can * be converted to one, use it. */ *indexPtr = endValue + objPtr->internalRep.longValue; } else { int opIdx, length; char *bytes = Tcl_GetStringFromObj(objPtr, &length); char *p = bytes; while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */ length--; p++; } if (length == 0) { goto parseError; } if ((*p == '+') || (*p == '-')) { p++; length--; } opIdx = ParseInteger(p, length) + (int) (p-bytes); if (opIdx) { int code, first, second; char savedOp = bytes[opIdx]; if ((savedOp != '+') && (savedOp != '-')) { goto parseError; } if (isspace(UCHAR(bytes[opIdx+1]))) { goto parseError; } bytes[opIdx] = '\0'; code = Tcl_GetInt(interp, bytes, &first); bytes[opIdx] = savedOp; if (code == TCL_ERROR) { goto parseError; } if (TCL_ERROR == Tcl_GetInt(interp, bytes+opIdx+1, &second)) { goto parseError; } if (savedOp == '+') { *indexPtr = first + second; } else { *indexPtr = first - second; } return TCL_OK; } /* * Report a parse error. */ parseError: if (interp != NULL) { char *bytes = Tcl_GetString(objPtr); /* * The result might not be empty; this resets it which should be * both a cheap operation, and of little problem because this is * an error-generation path anyway. */ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, "\": must be integer?[+-]integer? or end?[+-]integer?", (char *) NULL); if (!strncmp(bytes, "end-", 3)) { bytes += 3; } TclCheckBadOctal(interp, bytes); } return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * UpdateStringOfEndOffset -- * * Update the string rep of a Tcl object holding an "end-offset" * expression. * * Results: * None. * * Side effects: * Stores a valid string in the object's string rep. * * This function does NOT free any earlier string rep. If it is called on an * object that already has a valid string rep, it will leak memory. * *---------------------------------------------------------------------- */ static void UpdateStringOfEndOffset(objPtr) register Tcl_Obj* objPtr; |
︙ | ︙ | |||
2419 2420 2421 2422 2423 2424 2425 | } /* *---------------------------------------------------------------------- * * SetEndOffsetFromAny -- * | | | | | | | > | > > | > | > | > | | > > > > > | > | > | | | | | | | | | | | > | > > | | > | 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 | } /* *---------------------------------------------------------------------- * * SetEndOffsetFromAny -- * * Look for a string of the form "end[+-]offset" and convert it to an * internal representation holding the offset. * * Results: * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. * * Side effects: * If interp is not NULL, stores an error message in the interpreter * result. * *---------------------------------------------------------------------- */ static int SetEndOffsetFromAny(interp, objPtr) Tcl_Interp *interp; /* Tcl interpreter or NULL */ Tcl_Obj* objPtr; /* Pointer to the object to parse */ { int offset; /* Offset in the "end-offset" expression */ register char* bytes; /* String rep of the object */ int length; /* Length of the object's string rep */ /* * If it's already the right type, we're fine. */ if (objPtr->typePtr == &tclEndOffsetType) { return TCL_OK; } /* * 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_AppendResult(interp, "bad index \"", bytes, "\": must be end?[+-]integer?", (char*) NULL); } return TCL_ERROR; } /* * Convert the string rep. */ if (length <= 3) { offset = 0; } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { /* * This is our limited string expression evaluator. Pass everything * after "end-" to Tcl_GetInt, then reverse for offset. */ if (isspace(UCHAR(bytes[4]))) { return TCL_ERROR; } if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { return TCL_ERROR; } if (bytes[3] == '-') { offset = -offset; } } else { /* * Conversion failed. Report the error. */ if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, "\": must be end?[+-]integer?", (char *) NULL); } return TCL_ERROR; } /* * The conversion succeeded. Free the old internal rep and set the new * one. */ TclFreeIntRep(objPtr); objPtr->internalRep.longValue = offset; objPtr->typePtr = &tclEndOffsetType; return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCheckBadOctal -- * * This function checks for a bad octal value and appends a meaningful * error to the interp's result. * * Results: * 1 if the argument was a bad octal, else 0. * * Side effects: * The interpreter's result is modified. * *---------------------------------------------------------------------- */ int TclCheckBadOctal(interp, value) Tcl_Interp *interp; /* Interpreter to use for error reporting. If * NULL, then no error message is left after * errors. */ CONST char *value; /* String to check. */ { register CONST char *p = value; /* * A frequent mistake is invalid octal values due to an unwanted leading * zero. Try to generate a meaningful error message. */ while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ p++; } if (*p == '+' || *p == '-') { p++; } if (*p == '0') { while (isdigit(UCHAR(*p))) { /* INTL: digit. */ p++; } while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ p++; } if (*p == '\0') { /* * Reached end of string. */ if (interp != NULL) { /* * Don't reset the result here because we want this result to * be added to an existing error message as extra info. */ Tcl_AppendResult(interp, " (looks like invalid octal number)", (char *) NULL); } return 1; } } return 0; } /* *---------------------------------------------------------------------- * * ClearHash -- * * Remove all the entries in the hash table *tablePtr. * *---------------------------------------------------------------------- */ static void ClearHash(tablePtr) |
︙ | ︙ | |||
2586 2587 2588 2589 2590 2591 2592 | } /* *---------------------------------------------------------------------- * * GetThreadHash -- * | | | | | | < | 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 | } /* *---------------------------------------------------------------------- * * GetThreadHash -- * * Get a thread-specific (Tcl_HashTable *) associated with a thread data * key. * * Results: * The Tcl_HashTable * corresponding to *keyPtr. * * Side effects: * The first call on a keyPtr in each thread creates a new Tcl_HashTable, * and registers a thread exit handler to dispose of it. * *---------------------------------------------------------------------- */ static Tcl_HashTable * GetThreadHash(keyPtr) Tcl_ThreadDataKey *keyPtr; |
︙ | ︙ | |||
2618 2619 2620 2621 2622 2623 2624 | return *tablePtrPtr; } /* *---------------------------------------------------------------------- * * FreeThreadHash -- | > | | | > > | | | | | > > > | > > | | > > > < | 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 | return *tablePtrPtr; } /* *---------------------------------------------------------------------- * * FreeThreadHash -- * * Thread exit handler used by GetThreadHash to dispose of a thread hash * table. * * Side effects: * Frees a Tcl_HashTable. * *---------------------------------------------------------------------- */ static void FreeThreadHash(clientData) ClientData clientData; { Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); ckfree((char *) tablePtr); } /* *---------------------------------------------------------------------- * * FreeProcessGlobalValue -- * * Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup a * ProcessGlobalValue at exit. * *---------------------------------------------------------------------- */ static void FreeProcessGlobalValue(clientData) ClientData clientData; { ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData; pgvPtr->epoch++; pgvPtr->numBytes = 0; ckfree(pgvPtr->value); pgvPtr->value = NULL; if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); pgvPtr->encoding = NULL; } Tcl_MutexFinalize(&pgvPtr->mutex); } /* *---------------------------------------------------------------------- * * TclSetProcessGlobalValue -- * * Utility routine to set a global value shared by all threads in the * process while keeping a thread-local copy as well. * *---------------------------------------------------------------------- */ void TclSetProcessGlobalValue(pgvPtr, newValue, encoding) ProcessGlobalValue *pgvPtr; Tcl_Obj *newValue; Tcl_Encoding encoding; { CONST char *bytes; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; int dummy; Tcl_MutexLock(&pgvPtr->mutex); /* * Fill the global string value. */ pgvPtr->epoch++; if (NULL != pgvPtr->value) { ckfree(pgvPtr->value); } else { Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); } bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); pgvPtr->value = ckalloc((unsigned int) pgvPtr->numBytes + 1); strcpy(pgvPtr->value, bytes); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); } pgvPtr->encoding = encoding; /* * Fill the local thread copy directly with the Tcl_Obj value to avoid * loss of the intrep. Increment newValue refCount early to handle case * where we set a PGV to itself. */ Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy); Tcl_SetHashValue(hPtr, (ClientData) newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } /* *---------------------------------------------------------------------- * * TclGetProcessGlobalValue -- |
︙ | ︙ | |||
2736 2737 2738 2739 2740 2741 2742 | Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); | < > | | | | > | > | | > > > | > > | < | | | < | > > > | > > | < | | 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 | Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); if (pgvPtr->encoding != current) { /* * The system encoding has changed since the master string value * was saved. Convert the master value to be based on the new * system encoding. */ Tcl_DString native, newValue; Tcl_MutexLock(&pgvPtr->mutex); pgvPtr->epoch++; epoch = pgvPtr->epoch; Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, pgvPtr->numBytes, &native); Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), Tcl_DStringLength(&native), &newValue); Tcl_DStringFree(&native); ckfree(pgvPtr->value); pgvPtr->value = ckalloc((unsigned int) Tcl_DStringLength(&newValue) + 1); memcpy((VOID*) pgvPtr->value, (VOID*) Tcl_DStringValue(&newValue), (size_t) Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); Tcl_FreeEncoding(pgvPtr->encoding); pgvPtr->encoding = current; Tcl_MutexUnlock(&pgvPtr->mutex); } else { Tcl_FreeEncoding(current); } } cacheMap = GetThreadHash(&pgvPtr->key); hPtr = Tcl_FindHashEntry(cacheMap, (char *)epoch); if (NULL == hPtr) { int dummy; /* * No cache for the current epoch - must be a new one. * * First, clear the cacheMap, as anything in it must refer to some * expired epoch. */ ClearHash(cacheMap); /* * If no thread has set the shared value, call the initializer. */ Tcl_MutexLock(&pgvPtr->mutex); if ((NULL == pgvPtr->value) && (pgvPtr->proc)) { pgvPtr->epoch++; (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes, &pgvPtr->encoding); if (pgvPtr->value == NULL) { Tcl_Panic("PGV Initializer did not initialize."); } Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); } /* * Store a copy of the shared value in our epoch-indexed cache. */ value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); Tcl_SetHashValue(hPtr, (ClientData) value); Tcl_IncrRefCount(value); } return (Tcl_Obj *) Tcl_GetHashValue(hPtr); } /* *---------------------------------------------------------------------- * * TclSetObjNameOfExecutable -- * * This function stores the absolute pathname of the executable file * (normally as computed by TclpFindExecutable). * * Results: * None. * * Side effects: * Stores the executable name. * |
︙ | ︙ | |||
2830 2831 2832 2833 2834 2835 2836 | } /* *---------------------------------------------------------------------- * * TclGetObjNameOfExecutable -- * | | | | < | | | | | < | | < | | | 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 | } /* *---------------------------------------------------------------------- * * TclGetObjNameOfExecutable -- * * This function retrieves the absolute pathname of the application in * which the Tcl library is running, usually as previously stored by * TclpFindExecutable(). This function call is the C API equivalent to * the "info nameofexecutable" command. * * Results: * A pointer to an "fsPath" Tcl_Obj, or to an empty Tcl_Obj if the * pathname of the application is unknown. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Obj * TclGetObjNameOfExecutable() { return TclGetProcessGlobalValue(&executableName); } /* *---------------------------------------------------------------------- * * Tcl_GetNameOfExecutable -- * * This function retrieves the absolute pathname of the application in * which the Tcl library is running, and returns it in string form. * * The returned string belongs to Tcl and should be copied if the caller * plans to keep it, to guard against it becoming invalid. * * Results: * A pointer to the internal string or NULL if the internal full path * name has not been computed or unknown. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2892 2893 2894 2895 2896 2897 2898 | } /* *---------------------------------------------------------------------- * * TclpGetTime -- * | | > > < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } /* *---------------------------------------------------------------------- * * TclpGetTime -- * * Deprecated synonym for Tcl_GetTime. This function is provided for the * benefit of extensions written before Tcl_GetTime was exported from the * library. * * Results: * None. * * Side effects: * Stores current time in the buffer designated by "timePtr" * *---------------------------------------------------------------------- */ void TclpGetTime(timePtr) Tcl_Time* timePtr; { Tcl_GetTime(timePtr); } /* *---------------------------------------------------------------------- * * TclGetPlatform -- * * This is a kludge that allows the test library to get access the * internal tclPlatform variable. * * Results: * Returns a pointer to the tclPlatform variable. * * Side effects: * None. * *---------------------------------------------------------------------- */ TclPlatformType * TclGetPlatform() { return &tclPlatform; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclVar.c.
|
| | | | | | | | | | | | | > | | | | | | < | | < | | | | < | | | | | | < | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 | /* * tclVar.c -- * * This file contains routines that implement Tcl variables (both scalars * and arrays). * * The implementation of arrays is modelled after an initial * implementation by Mark Diekhans and Karl Lehenbauer. * * Copyright (c) 1987-1994 The Regents of the University of California. * 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.99.2.8 2005/08/19 05:17:48 dgp Exp $ */ #include "tclInt.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 void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr)); static void DeleteArray _ANSI_ARGS_((Interp *iPtr, CONST char *arrayName, Var *varPtr, int flags)); static int ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp, CallFrame *framePtr, Tcl_Obj *otherP1Ptr, CONST char *otherP2, CONST int otherFlags, CONST char *myName, int myFlags, int index)); static Var * NewVar _ANSI_ARGS_((void)); static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp, CONST Var *varPtr, CONST char *varName, Tcl_Obj *handleObj)); static 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_DupInternalRepProc DupLocalVarName; static Tcl_FreeInternalRepProc FreeParsedVarName; static Tcl_DupInternalRepProc DupParsedVarName; static Tcl_UpdateStringProc UpdateParsedVarName; static Tcl_UpdateStringProc PanicOnUpdateVarName; static Tcl_SetFromAnyProc PanicOnSetVarName; /* * Types of Tcl_Objs used to cache variable lookups. * * localVarName - INTERNALREP DEFINITION: * longValue: 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 */ static Tcl_ObjType localVarNameType = { "localVarName", NULL, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName }; /* * Caching of namespace variables disabled: no simple way was found to avoid * interfering with the resolver's idea of variable existence. A cached * varName may keep a variable's name in the namespace's hash table, which is * the resolver's criterion for existence (see test namespace-17.10). */ #define ENABLE_NS_VARNAME_CACHING 0 #if ENABLE_NS_VARNAME_CACHING static Tcl_FreeInternalRepProc FreeNsVarName; static Tcl_DupInternalRepProc DupNsVarName; Tcl_ObjType tclNsVarNameType = { |
︙ | ︙ | |||
123 124 125 126 127 128 129 | FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName }; /* * Type of Tcl_Objs used to speed up array searches. * * INTERNALREP DEFINITION: | | | | | | > < | | | | < | | | | | | | > | | | | | | | | | | | | | | | | | | | < | | | < | | | | > | 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 | FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName }; /* * 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 * * Note that the value stored in ptr2 is the offset into the string of the * start of the variable name and not the address of the variable name itself, * as this can be safely copied. */ Tcl_ObjType tclArraySearchType = { "array search", NULL, NULL, NULL, SetArraySearchObj }; /* *---------------------------------------------------------------------- * * 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 * 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. * *---------------------------------------------------------------------- */ 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 { |
︙ | ︙ | |||
261 262 263 264 265 266 267 | memcpy(newVarName, part1, (unsigned int) closeParen); newVarName[openParen] = '\0'; newVarName[closeParen] = '\0'; part1 = newVarName; elName = newVarName + openParen + 1; } | | | | < | | | | | | | | | | | | | < | | | > | | | | | | | | | | | | | | | | | | | | | | | | > | | | < < | | | > | | | | | | > | | > | | | | | > | | | | | | > | > > | | | | | | | | | | | | | | | | | | > | > | | | | | | | | | | | | | | > | | | > | | | | | | | | | | | | < | | | | | | | | | | | | | | | < | | < | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | > | | | | | | | | | > | | | | | 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 | 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)) { TclVarErrMsg(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 localVarNameType, * 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); TclVarErrMsg(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 == &localVarNameType) { int localIndex = (int) part1Ptr->internalRep.longValue; if ((varFramePtr != NULL) && (varFramePtr->isProcCallFrame & FRAME_IS_PROC) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) && (localIndex < varFramePtr->numCompiledLocals)) { /* * use the cached index if the names coincide. */ varPtr = &(varFramePtr->compiledLocals[localIndex]); if ((varPtr->name != NULL) && (strcmp(part1, varPtr->name) == 0)) { goto donePart1; } } goto doneParsing; #if ENABLE_NS_VARNAME_CACHING } else if (typePtr == &tclNsVarNameType) { int useGlobal, useReference; Namespace *cachedNsPtr = (Namespace *) part1Ptr->internalRep.twoPtrValue.ptr1; varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2; useGlobal = (cachedNsPtr == iPtr->globalNsPtr) && ( (flags & TCL_GLOBAL_ONLY) || (*part1==':' && *(part1+1)==':') || (varFramePtr == NULL) || (!(varFramePtr->isProcCallFrame & FRAME_IS_PROC) && (nsPtr == iPtr->globalNsPtr))); useReference = useGlobal || ((cachedNsPtr == nsPtr) && ( (flags & TCL_NAMESPACE_ONLY) || (varFramePtr && !(varFramePtr->isProcCallFrame & FRAME_IS_PROC) && !(flags & TCL_GLOBAL_ONLY) && /* Careful: an undefined ns variable could be hiding a valid * global reference. */ !TclIsVarUndefined(varPtr)))); 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; #endif } 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) { TclVarErrMsg(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; TclFreeIntRep(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. */ TclNewStringObj(part1Ptr, 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. */ TclFreeIntRep(part1Ptr); part1Ptr->typePtr = NULL; varPtr = TclLookupSimpleVar(interp, part1, flags, createPart1, &errMsg, &index); if (varPtr == NULL) { if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { TclVarErrMsg(interp, part1, part2, msg, errMsg); } return NULL; } /* * Cache the newly found variable if possible. */ if (index >= 0) { /* * An indexed local variable. */ part1Ptr->typePtr = &localVarNameType; part1Ptr->internalRep.longValue = (long) index; #if ENABLE_NS_VARNAME_CACHING } else if (index > -3) { /* * A cacheable namespace or global variable. */ Namespace *nsPtr; nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr); varPtr->refCount++; part1Ptr->typePtr = &tclNsVarNameType; part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr; part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr; #endif } else { /* * At least mark part1Ptr as already parsed. */ part1Ptr->typePtr = &tclParsedVarNameType; part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; part1Ptr->internalRep.twoPtrValue.ptr2 = NULL; } donePart1: #if 0 if (varPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { part1 = TclGetString(part1Ptr); TclVarErrMsg(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; } /* * This flag bit should not interfere with TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * or TCL_LEAVE_ERR_MSG; it signals that the variable lookup is performed for * upvar (or similar) purposes, with slightly different rules: * - Bug #696893 - variable is either proc-local or in the current * namespace; never follow the second (global) resolution path * - Bug #631741 - do not use special namespace or interp resolvers * * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag * (Bug #835020) */ #define LOOKUP_FOR_UPVAR 0x40000 /* *---------------------------------------------------------------------- * * TclLookupSimpleVar -- * * This procedure is used by to locate a simple variable (i.e., not an * array element) given its name. * * 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 * represent a scalar or an array. */ int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * LOOKUP_FOR_UPVAR and TCL_LEAVE_ERR_MSG bits * matter. */ CONST int create; /* If 1, create hash table entry for varname, * if it doesn't already exist. If 0, return * error if it doesn't exist. */ CONST char **errMsgPtr; int *indexPtr; { Interp *iPtr = (Interp *) interp; 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 ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) { cxtNsPtr = iPtr->globalNsPtr; } else { cxtNsPtr = iPtr->varFramePtr->nsPtr; } /* * If this namespace has a variable resolver, then give it first crack at * the variable resolution. It may return a Tcl_Var value, it may signal * to continue onward, or it may signal an error. */ if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) && !(flags & LOOKUP_FOR_UPVAR)) { resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { result = (*cxtNsPtr->varResProc)(interp, varName, (Tcl_Namespace *) cxtNsPtr, flags, &var); } else { result = TCL_CONTINUE; } 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) { return (Var *) var; } 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 & FRAME_IS_PROC) || (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 | LOOKUP_FOR_UPVAR); } else { if (flags & LOOKUP_FOR_UPVAR) { flags = (flags | TCL_NAMESPACE_ONLY) & ~LOOKUP_FOR_UPVAR; } if (flags & TCL_NAMESPACE_ONLY) { *indexPtr = -2; } } /* * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, or * otherwise generate our own error! */ var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr, flags & ~TCL_LEAVE_ERR_MSG); 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) { /* * 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); |
︙ | ︙ | |||
859 860 861 862 863 864 865 | } /* *---------------------------------------------------------------------- * * TclLookupArrayElement -- * | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | 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 | } /* *---------------------------------------------------------------------- * * 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) { TclVarErrMsg(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) { TclVarErrMsg(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) { TclVarErrMsg(interp, arrayName, elName, msg, needArray); } return NULL; } |
︙ | ︙ | |||
982 983 984 985 986 987 988 | * * Tcl_GetVar -- * * Return the value of a Tcl variable as a string. * * Results: * The return value points to the current value of varName as a string. | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | > | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | * * Tcl_GetVar -- * * Return the value of a Tcl variable as a string. * * Results: * The return value points to the current value of varName as a string. * If the variable is not defined or can't be read because of a clash in * array usage then a NULL pointer is returned and an error message is * left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set. * Note: the return value is only valid up until the next change to the * variable; if you depend on the value lasting longer than that, then * make yourself a private copy. * * Side effects: * None. * *---------------------------------------------------------------------- */ 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); } /* *---------------------------------------------------------------------- * * Tcl_GetVar2 -- * * Return the value of a Tcl variable as a string, given a two-part name * consisting of array name and element within array. * * Results: * The return value points to the current value of the variable given by * part1 and part2 as a string. 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 interp's result if the TCL_LEAVE_ERR_MSG * flag is set. Note: the return value is only valid up until the next * change to the variable; if you depend on the value lasting longer than * that, then make yourself a private copy. * * Side effects: * None. * *---------------------------------------------------------------------- */ 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. * * 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_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) Tcl_Interp *interp; /* Command interpreter in which variable is to * be looked up. */ 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. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and * TCL_LEAVE_ERR_MSG bits. */ { Var *varPtr, *arrayPtr; char *part1, *part2; part1 = TclGetString(part1Ptr); part2 = ((part2Ptr == NULL) ? NULL : TclGetString(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 == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) | TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { goto errorReturn; } } /* * Return the element if it's an existing scalar variable. */ if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { return varPtr->value.objPtr; } if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL) && !TclIsVarUndefined(arrayPtr)) { msg = noSuchElement; } else if (TclIsVarArray(varPtr)) { msg = isArray; } else { msg = noSuchVar; } TclVarErrMsg(interp, part1, part2, "read", msg); } /* * An error. If the variable doesn't exist anymore and no-one's using it, * then free up the relevant structures and hash table entries. */ errorReturn: if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_SetObjCmd -- * * This procedure is invoked to process the "set" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result value. * * Side effects: * A variable's value may be changed. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SetObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ register Tcl_Interp *interp;/* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Obj *varValueObj; if (objc == 2) { varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (varValueObj == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, varValueObj); return TCL_OK; } else if (objc == 3) { varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2], TCL_LEAVE_ERR_MSG); if (varValueObj == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, varValueObj); return TCL_OK; |
︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 | * modify this string. If the write operation was disallowed then NULL * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then an * explanatory message will be left in the interp's result. Note that the * returned string may not be the same as newValue; this is because * variable traces may modify the variable's value. * * Side effects: | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | * modify this string. If the write operation was disallowed then NULL * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then an * explanatory message will be left in the interp's result. Note that the * returned string may not be the same as newValue; this is because * variable traces may modify the variable's value. * * Side effects: * If varName is defined as a local or global variable in interp, its * value is changed to newValue. If varName isn't currently defined, then * a new global variable by that name is created. * *---------------------------------------------------------------------- */ 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); } /* *---------------------------------------------------------------------- * * Tcl_SetVar2 -- * * Given a two-part variable name, which may refer either to a scalar * variable or an element of an array, change the value of the variable. * If the named scalar or array or element doesn't exist then create one. * * Results: * Returns a pointer to the malloc'ed string which is the character * representation of the variable's new value. The caller must not modify * this string. 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 interp's result. Note that the returned string may not be * the same as newValue; 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 one is created. * *---------------------------------------------------------------------- */ 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, TCL_NAMESPACE_ONLY, * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or * TCL_LEAVE_ERR_MSG */ { register Tcl_Obj *valuePtr; Tcl_Obj *varValuePtr; /* * Create an object holding the variable's new value and use Tcl_SetVar2Ex * to actually set the variable. */ valuePtr = Tcl_NewStringObj(newValue, -1); Tcl_IncrRefCount(valuePtr); varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, valuePtr, flags); TclDecrRefCount(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 * variable or an element of an array, change the value of the variable * to a new Tcl object value. If the named scalar or array or element * doesn't exist then create one. * * 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. * * The reference count is decremented for any old value of the variable * and incremented for its new value. If the new value for the variable * is not the same one referenced by newValuePtr (perhaps as a result of * a variable trace), then newValuePtr's ref count is left unchanged by * Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if we * are appending it as a string value: that is, if "flags" includes * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT. * * The reference count for the returned object is _not_ incremented: if * you want to keep a reference to the object you must increment its ref * count yourself. * *---------------------------------------------------------------------- */ 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 : TclGetString(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). */ if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarArrayElement(varPtr)) { TclVarErrMsg(interp, part1, part2, "set", danglingElement); } else { |
︙ | ︙ | |||
1588 1589 1590 1591 1592 1593 1594 | if (flags & TCL_LEAVE_ERR_MSG) { TclVarErrMsg(interp, part1, part2, "set", isArray); } return NULL; } /* | | | | | | | | < | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | 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 | if (flags & TCL_LEAVE_ERR_MSG) { TclVarErrMsg(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 == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { return NULL; } } /* * Set the variable's new value. If appending, append the new value to the * variable, either as a list element or as a string. Also, if appending, * then if the variable's old value is unshared we can modify it directly, * otherwise we must create a new copy to modify: this is "copy on write". */ if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) { TclSetVarUndefined(varPtr); } oldValuePtr = varPtr->value.objPtr; if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { TclDecrRefCount(oldValuePtr); /* discard old value */ varPtr->value.objPtr = NULL; oldValuePtr = NULL; } if (flags & TCL_LIST_ELEMENT) { /* append list element */ if (oldValuePtr == NULL) { TclNewObj(oldValuePtr); varPtr->value.objPtr = oldValuePtr; Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ } else if (Tcl_IsShared(oldValuePtr)) { varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); TclDecrRefCount(oldValuePtr); oldValuePtr = varPtr->value.objPtr; Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ } result = Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr); if (result != TCL_OK) { return NULL; } } else { /* append string */ /* * We append newValuePtr's bytes but don't change its ref count. */ if (oldValuePtr == NULL) { varPtr->value.objPtr = newValuePtr; Tcl_IncrRefCount(newValuePtr); } else { if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); TclDecrRefCount(oldValuePtr); oldValuePtr = varPtr->value.objPtr; Tcl_IncrRefCount(oldValuePtr); /* since var is ref */ } Tcl_AppendObjToObj(oldValuePtr, newValuePtr); } } } else if (newValuePtr != oldValuePtr) { /* * In this case we are replacing the value, so we don't need to do * more than swap the objects. */ varPtr->value.objPtr = newValuePtr; Tcl_IncrRefCount(newValuePtr); /* var is another ref */ if (oldValuePtr != NULL) { TclDecrRefCount(oldValuePtr); /* discard old value */ } } TclSetVarScalar(varPtr); TclClearVarUndefined(varPtr); if (arrayPtr != NULL) { TclClearVarUndefined(arrayPtr); } /* * Invoke any write traces for the variable. */ if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) { goto cleanup; } } /* * Return the variable's value unless the variable was changed in some * gross way by a trace (e.g. it was unset and then recreated as an * array). */ if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { return varPtr->value.objPtr; } /* * A trace changed the value in some gross way. Return an empty string * object. */ resultPtr = iPtr->emptyObjPtr; /* * If the variable doesn't exist anymore and no-one's using it, then free * up the relevant structures and hash table entries. */ cleanup: if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); } return resultPtr; } #if 0 /* *---------------------------------------------------------------------- * * TclIncrVar2 -- * * Given a two-part variable name, which may refer either to a scalar * variable or an element of an 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 * TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) Tcl_Interp *interp; /* Command interpreter in which variable is to * be found. */ Tcl_Obj *part1Ptr; /* Points to an object holding the name of an * array (if part2 is non-NULL) or the name of * a variable. */ Tcl_Obj *part2Ptr; /* If non-null, points to an object holding * the name of an element in the array * 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)); |
︙ | ︙ | |||
1776 1777 1778 1779 1780 1781 1782 | } /* *---------------------------------------------------------------------- * * TclPtrIncrVar -- * | | | < | | | | | | | | | | | | | | | | | | | | | > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * 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; } /* * Increment the variable's value. If the object is unshared we can modify * it directly, otherwise we must create a new copy to modify: this is * "copy on write". Then free the variable's old string representation, if * any, since it will no longer be valid. */ createdNewObj = 0; if (Tcl_IsShared(varValuePtr)) { varValuePtr = Tcl_DuplicateObj(varValuePtr); createdNewObj = 1; } if (varValuePtr->typePtr == &tclWideIntType) { Tcl_WideInt wide; TclGetWide(wide,varValuePtr); TclSetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); } else if (varValuePtr->typePtr == &tclIntType) { i = varValuePtr->internalRep.longValue; TclSetIntObj(varValuePtr, i + incrAmount); } else { /* * Not an integer or wide internal-rep... */ Tcl_WideInt wide; if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { if (createdNewObj) { TclDecrRefCount(varValuePtr); /* free unneeded copy */ } return NULL; } if (wide <= Tcl_LongAsWide(LONG_MAX) && wide >= Tcl_LongAsWide(LONG_MIN)) { TclSetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount); } else { TclSetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); } } /* * Store the variable's new value and run any write traces. */ return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, varValuePtr, flags); } #endif /* *---------------------------------------------------------------------- * * TclIncrObjVar2 -- * * Given a two-part variable name, which may refer either to a scalar * variable or an element of an array, increment the Tcl object value of * the variable by a specified Tcl_Obj increment value. * * 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 * TclIncrObjVar2(interp, part1Ptr, part2Ptr, incrPtr, flags) Tcl_Interp *interp; /* Command interpreter in which variable is to * be found. */ Tcl_Obj *part1Ptr; /* Points to an object holding the name of an * array (if part2 is non-NULL) or the name of * a variable. */ Tcl_Obj *part2Ptr; /* If non-null, points to an object holding * the name of an element in the array * part1Ptr. */ Tcl_Obj *incrPtr; /* 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 TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2, incrPtr, flags); } /* *---------------------------------------------------------------------- * * TclPtrIncrObjVar -- * * Given the pointers to a variable and possible containing array, * increment the Tcl object value of the variable by a Tcl_Obj increment. * * 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 * TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2, incrPtr, 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. */ Tcl_Obj *incrPtr; /* Increment value */ /* TODO: Which of these flag values really make sense? */ 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, *newValuePtr = NULL; int code; varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); return NULL; } if (Tcl_IsShared(varValuePtr)) { varValuePtr = Tcl_DuplicateObj(varValuePtr); } code = TclIncrObj(interp, varValuePtr, incrPtr); Tcl_IncrRefCount(varValuePtr); if (code == TCL_OK) { newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, varValuePtr, flags); } Tcl_DecrRefCount(varValuePtr); return newValuePtr; } #if 0 /* *---------------------------------------------------------------------- * * TclIncrWideVar2 -- * * Given a two-part variable name, which may refer either to a scalar * variable or an element of an 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 * TclIncrWideVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) Tcl_Interp *interp; /* Command interpreter in which variable is to * be found. */ Tcl_Obj *part1Ptr; /* Points to an object holding the name of an * array (if part2 is non-NULL) or the name of * a variable. */ Tcl_Obj *part2Ptr; /* If non-null, points to an object holding * the name of an element in the array * part1Ptr. */ Tcl_WideInt 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)); |
︙ | ︙ | |||
1939 1940 1941 1942 1943 1944 1945 | } /* *---------------------------------------------------------------------- * * TclPtrIncrWideVar -- * | | | < | | | | | | | | | | | | | | | | | | | | | | > | | | > | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TclPtrIncrWideVar -- * * 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 * TclPtrIncrWideVar(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 Tcl_WideInt 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). */ Tcl_WideInt wide; varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); return NULL; } /* * Increment the variable's value. If the object is unshared we can modify * it directly, otherwise we must create a new copy to modify: this is * "copy on write". Then free the variable's old string representation, if * any, since it will no longer be valid. */ createdNewObj = 0; if (Tcl_IsShared(varValuePtr)) { varValuePtr = Tcl_DuplicateObj(varValuePtr); createdNewObj = 1; } if (varValuePtr->typePtr == &tclWideIntType) { TclGetWide(wide, varValuePtr); TclSetWideIntObj(varValuePtr, wide + incrAmount); } else if (varValuePtr->typePtr == &tclIntType) { long i = varValuePtr->internalRep.longValue; TclSetWideIntObj(varValuePtr, Tcl_LongAsWide(i) + incrAmount); } else { /* * Not an integer or wide internal-rep... */ if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { if (createdNewObj) { TclDecrRefCount(varValuePtr); /* free unneeded copy */ } return NULL; } TclSetWideIntObj(varValuePtr, wide + incrAmount); } /* * Store the variable's new value and run any write traces. */ return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, varValuePtr, flags); } #endif /* *---------------------------------------------------------------------- * * Tcl_UnsetVar -- * * Delete a variable, so that it may not be accessed anymore. * * 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 varName is defined as a local or global variable in interp, it is * deleted. * *---------------------------------------------------------------------- */ 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); } /* *---------------------------------------------------------------------- * * Tcl_UnsetVar2 -- * * Delete a variable, given a 2-part 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 part1 and part2 indicate a local or global variable in interp, it * is deleted. If part1 is an array name and part2 is NULL, then the * whole array is deleted. * *---------------------------------------------------------------------- */ 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; |
︙ | ︙ | |||
2155 2156 2157 2158 2159 2160 2161 | part1 = TclGetString(part1Ptr); varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset", /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } | | | | | < | | | | | | | | | < | | | | | | | | | | | | | < | | | > > | | > | | | | | | 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 | 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); } /* * The code below is tricky, because of the possibility that a trace * procedure might try to access a variable being deleted. To handle this * situation gracefully, do things in three steps: * 1. Copy the contents of the variable to a dummy variable structure, and * mark the original Var structure as undefined. * 2. Invoke traces and clean up the variable, using the dummy copy. * 3. If at the end of this the original variable is still undefined and * has no outstanding references, then delete * it (but it could have * gotten recreated by a trace). */ dummyVar = *varPtr; TclSetVarUndefined(varPtr); TclSetVarScalar(varPtr); varPtr->value.objPtr = NULL; /* dummyVar points to any value object */ varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; /* * Keep the variable alive until we're done with it. We used to * increase/decrease the refCount for each operation, making it hard to * find [Bug 735335] - caused by unsetting the variable whose value was * the variable's name. */ varPtr->refCount++; /* * 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: TclCallVarTraces * will use dummyVar so it won't increment varPtr's refCount itself. * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to call * unset traces even if other traces are pending. */ if ((dummyVar.tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { dummyVar.flags &= ~VAR_TRACE_ACTIVE; TclCallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0); while (dummyVar.tracePtr != NULL) { VarTrace *tracePtr = dummyVar.tracePtr; dummyVar.tracePtr = tracePtr->nextPtr; Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } } } /* * If the variable is an array, delete all of its elements. This must be * done after calling the traces on the array, above (that's the way * traces are defined). If it is a scalar, "discard" its object (decrement * the ref count of its object, if any). */ dummyVarPtr = &dummyVar; if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) { /* * Deleting the elements of the array may cause traces to be fired on * those elements. Before deleting them, bump the reference count of * the array, so that if those trace procs make a global or upvar link * to the array, the array is not deleted when the call stack gets * popped (we will delete the array ourselves later in this function). * * 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. */ DeleteArray(iPtr, part1, dummyVarPtr, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); /* Decr ref count */ } if (TclIsVarScalar(dummyVarPtr) && (dummyVarPtr->value.objPtr != NULL)) { objPtr = dummyVarPtr->value.objPtr; TclDecrRefCount(objPtr); dummyVarPtr->value.objPtr = NULL; } /* * If the variable was a namespace variable, decrement its reference * count. */ if (TclIsVarNamespaceVar(varPtr)) { TclClearVarNamespaceVar(varPtr); varPtr->refCount--; } /* * It's an error to unset an undefined variable. */ if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { TclVarErrMsg(interp, part1, part2, "unset", ((arrayPtr == NULL) ? noSuchVar : noSuchElement)); } } #if ENABLE_NS_VARNAME_CACHING /* * Try to avoid keeping the Var struct allocated due to a tclNsVarNameType * keeping a reference. This removes some additional exteriorisations of * [Bug 736729], but may be a good thing independently of the bug. */ if (part1Ptr->typePtr == &tclNsVarNameType) { TclFreeIntRep(part1Ptr); part1Ptr->typePtr = NULL; } #endif /* * Finally, if the variable is truly not in use then free up its Var * structure and remove it from its hash table, if any. The ref count of * its value object, if any, was decremented above. */ varPtr->refCount--; |
︙ | ︙ | |||
2332 2333 2334 2335 2336 2337 2338 | if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?--? ?varName varName ...?"); return TCL_ERROR; } else if (objc == 1) { /* | | | > | | | > | 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 | if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?--? ?varName varName ...?"); return TCL_ERROR; } else if (objc == 1) { /* * Do nothing if no arguments supplied, so as to match command * documentation. */ return TCL_OK; } /* * Simple, restrictive argument parsing. The only options are -- and * -nocomplain (which must come first and be given exactly to be an * option). */ i = 1; name = TclGetString(objv[i]); if (name[0] == '-') { if (strcmp("-nocomplain", name) == 0) { i++; if (i == objc) { return TCL_OK; |
︙ | ︙ | |||
2373 2374 2375 2376 2377 2378 2379 | } /* *---------------------------------------------------------------------- * * Tcl_AppendObjCmd -- * | | | | 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 | } /* *---------------------------------------------------------------------- * * Tcl_AppendObjCmd -- * * This object-based procedure is invoked to process the "append" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * * Side effects: * A variable's value may be changed. * |
︙ | ︙ | |||
2398 2399 2400 2401 2402 2403 2404 | Tcl_Obj *CONST objv[]; /* Argument objects. */ { Var *varPtr, *arrayPtr; char *part1; register Tcl_Obj *varValuePtr = NULL; /* Initialized to avoid compiler | | | | | | | | | | | < < | > | | | | | | | | | | | | | | | | | | | | | < > | < > > | < < | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | 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 | 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; } /* *---------------------------------------------------------------------- * * Tcl_LappendObjCmd -- * * This object-based procedure is invoked to process the "lappend" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * * Side effects: * A variable's value may be changed. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_LappendObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Obj *varValuePtr, *newValuePtr; int numElems, createdNewObj, createVar; Var *varPtr, *arrayPtr; char *part1; int result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } if (objc == 2) { newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, 0); if (newValuePtr == NULL) { /* * The variable doesn't exist yet. Just create it with an empty * initial value. */ TclNewObj(varValuePtr); newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr, TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { TclDecrRefCount(varValuePtr); /* free unneeded object */ return TCL_ERROR; } } } else { /* * We have arguments to append. We used to call Tcl_SetVar2 to append * each argument one at a time to ensure that traces were run for each * append step. We now append the arguments all at once because it's * faster. Note that a read trace and a write trace for the variable * will now each only be called once. Also, if the variable's old * value is unshared we modify it directly, otherwise we create a new * copy to modify: this is "copy on write". */ 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)); TclNewObj(varValuePtr); createdNewObj = 1; } else if (Tcl_IsShared(varValuePtr)) { varValuePtr = Tcl_DuplicateObj(varValuePtr); createdNewObj = 1; } result = Tcl_ListObjLength(interp, varValuePtr, &numElems); if (result == TCL_OK) { result = Tcl_ListObjReplace(interp, varValuePtr, numElems, 0, (objc-2), (objv+2)); } if (result != TCL_OK) { if (createdNewObj) { TclDecrRefCount(varValuePtr); /* free unneeded obj. */ } return result; } /* * 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) { TclDecrRefCount(varValuePtr); /* free unneeded obj */ } return TCL_ERROR; } } /* * Set the interpreter's object result to refer to the variable's value |
︙ | ︙ | |||
2654 2655 2656 2657 2658 2659 2660 | /* * The list of constants below should match the arrayOptions string array * below. */ enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET, ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > | > > > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < < > | > > > > > > > > > > > > > | | > > > | < > > | | | | > > | > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | > | < | | | | > | > > > > > > | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | 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 | /* * The list of constants below should match the arrayOptions string array * below. */ enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET, ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET}; static CONST char *arrayOptions[] = { "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 *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 == TclCallVarTraces(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; } switch (index) { case ARRAY_ANYMORE: { ArraySearch *searchPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); return TCL_ERROR; } if (notArray) { goto error; } searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); if (searchPtr == NULL) { return TCL_ERROR; } while (1) { Var *varPtr2; if (searchPtr->nextEntry != NULL) { varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry); if (!TclIsVarUndefined(varPtr2)) { break; } } searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); if (searchPtr->nextEntry == NULL) { Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[0]); return TCL_OK; } } Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[1]); break; } case ARRAY_DONESEARCH: { ArraySearch *searchPtr, *prevPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); return TCL_ERROR; } if (notArray) { goto error; } searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); if (searchPtr == NULL) { return TCL_ERROR; } if (varPtr->searchPtr == searchPtr) { varPtr->searchPtr = searchPtr->nextPtr; } else { for (prevPtr=varPtr->searchPtr ;; prevPtr=prevPtr->nextPtr) { if (prevPtr->nextPtr == searchPtr) { prevPtr->nextPtr = searchPtr->nextPtr; break; } } } ckfree((char *) searchPtr); break; } case ARRAY_NEXTELEMENT: { ArraySearch *searchPtr; Tcl_HashEntry *hPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); return TCL_ERROR; } if (notArray) { goto error; } searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); if (searchPtr == NULL) { return TCL_ERROR; } while (1) { Var *varPtr2; hPtr = searchPtr->nextEntry; if (hPtr == NULL) { hPtr = Tcl_NextHashEntry(&searchPtr->search); if (hPtr == NULL) { return TCL_OK; } } else { searchPtr->nextEntry = NULL; } varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (!TclIsVarUndefined(varPtr2)) { break; } } Tcl_SetObjResult(interp, Tcl_NewStringObj( Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1)); break; } case ARRAY_STARTSEARCH: { ArraySearch *searchPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); return TCL_ERROR; } if (notArray) { goto error; } searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); if (varPtr->searchPtr == NULL) { searchPtr->id = 1; Tcl_AppendResult(interp, "s-1-", varName, NULL); } else { char string[TCL_INTEGER_SPACE]; searchPtr->id = varPtr->searchPtr->id + 1; TclFormatInt(string, searchPtr->id); Tcl_AppendResult(interp, "s-", string, "-", varName, NULL); } searchPtr->varPtr = varPtr; searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, &searchPtr->search); searchPtr->nextPtr = varPtr->searchPtr; varPtr->searchPtr = searchPtr; break; } case ARRAY_EXISTS: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); return TCL_ERROR; } Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]); break; case ARRAY_GET: { Tcl_HashSearch search; Var *varPtr2; char *pattern = NULL; char *name; Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr; int i, count; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); return TCL_ERROR; } if (notArray) { return TCL_OK; } if (objc == 4) { pattern = TclGetString(objv[3]); } /* * Store the array names in a new object. */ TclNewObj(nameLstPtr); Tcl_IncrRefCount(nameLstPtr); if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern); if (hPtr == NULL) { goto searchDone; } varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarUndefined(varPtr2)) { goto searchDone; } result = Tcl_ListObjAppendElement(interp, nameLstPtr, Tcl_NewStringObj(pattern, -1)); if (result != TCL_OK) { TclDecrRefCount(nameLstPtr); return result; } goto searchDone; } 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 ((objc == 4) && !Tcl_StringMatch(name, pattern)) { continue; /* element name doesn't match pattern */ } namePtr = Tcl_NewStringObj(name, -1); result = Tcl_ListObjAppendElement(interp, nameLstPtr, namePtr); if (result != TCL_OK) { TclDecrRefCount(namePtr); /* free unneeded name obj */ TclDecrRefCount(nameLstPtr); return result; } } searchDone: /* * Make sure the Var structure of the array is not removed by a trace * while we're working. */ varPtr->refCount++; /* * Get the array values corresponding to each element name */ TclNewObj(tmpResPtr); result = Tcl_ListObjGetElements(interp, nameLstPtr, &count, &namePtrPtr); if (result != TCL_OK) { goto errorInArrayGet; } for (i=0 ; i<count ; i++) { namePtr = *namePtrPtr++; valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { /* * Some trace played a trick on us; we need to diagnose to * adapt our behaviour: was the array element unset, or did * the modification modify the complete array? */ if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { /* * The array itself looks OK, the variable was undefined: * forget it. */ continue; } else { result = TCL_ERROR; goto errorInArrayGet; } } result = Tcl_DictObjPut(interp, tmpResPtr, namePtr, valuePtr); if (result != TCL_OK) { goto errorInArrayGet; } } varPtr->refCount--; Tcl_SetObjResult(interp, tmpResPtr); TclDecrRefCount(nameLstPtr); break; errorInArrayGet: varPtr->refCount--; TclDecrRefCount(nameLstPtr); TclDecrRefCount(tmpResPtr); /* free unneeded temp result */ return result; } case ARRAY_NAMES: { Tcl_HashSearch search; Var *varPtr2; char *pattern = NULL; char *name; Tcl_Obj *namePtr, *resultPtr; int mode, matched = 0; static CONST char *options[] = { "-exact", "-glob", "-regexp", (char *) NULL }; enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; mode = OPT_GLOB; if ((objc < 3) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2,objv, "arrayName ?mode? ?pattern?"); return TCL_ERROR; } if (notArray) { return TCL_OK; } if (objc == 4) { pattern = TclGetString(objv[3]); } else if (objc == 5) { pattern = TclGetString(objv[4]); if (Tcl_GetIndexFromObj(interp, objv[3], options, "option", 0, &mode) != TCL_OK) { return TCL_ERROR; } } TclNewObj(resultPtr); if (((enum options) mode)==OPT_GLOB && pattern!=NULL && TclMatchIsTrivial(pattern)) { hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern); if ((hPtr != NULL) && !TclIsVarUndefined((Var *) Tcl_GetHashValue(hPtr))) { result = Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(pattern, -1)); if (result != TCL_OK) { TclDecrRefCount(resultPtr); return result; } } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } 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 (objc > 3) { switch ((enum options) mode) { case OPT_EXACT: matched = (strcmp(name, pattern) == 0); break; case OPT_GLOB: matched = Tcl_StringMatch(name, pattern); break; case OPT_REGEXP: matched = Tcl_RegExpMatch(interp, name, pattern); if (matched < 0) { TclDecrRefCount(resultPtr); return TCL_ERROR; } break; } if (matched == 0) { continue; } } namePtr = Tcl_NewStringObj(name, -1); result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); if (result != TCL_OK) { TclDecrRefCount(resultPtr); TclDecrRefCount(namePtr); /* free unneeded name obj */ return result; } } Tcl_SetObjResult(interp, resultPtr); break; } case ARRAY_SET: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName list"); return TCL_ERROR; } return TclArraySet(interp, objv[2], objv[3]); case ARRAY_UNSET: { Tcl_HashSearch search; Var *varPtr2; char *pattern = NULL; char *name; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); return TCL_ERROR; } 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 = TclGetString(objv[3]); if (TclMatchIsTrivial(pattern)) { hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern); if (hPtr != NULL && !TclIsVarUndefined((Var *)Tcl_GetHashValue(hPtr))){ return TclObjUnsetVar2(interp, varNamePtr, pattern, 0); } return TCL_OK; } 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; } case ARRAY_SIZE: { Tcl_HashSearch search; Var *varPtr2; int size; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); return TCL_ERROR; } size = 0; /* * Must iterate in order to get chance to check for present but * "undefined" entries. */ if (!notArray) { for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarUndefined(varPtr2)) { continue; } size++; } } Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); break; } case ARRAY_STATISTICS: { CONST char *stats; if (notArray) { goto error; } stats = Tcl_HashStats(varPtr->value.tablePtr); if (stats != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); ckfree((void *)stats); } else { Tcl_SetResult(interp, "error reading array statistics",TCL_STATIC); return TCL_ERROR; } break; } } return TCL_OK; error: Tcl_AppendResult(interp, "\"", varName, "\" isn't an array", NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclArraySet -- * * Set the elements of an array. If there are no elements to set, create * an empty array. This routine is used by the Tcl_ArrayObjCmd and by * the TclSetupEnv routine. * * Results: * A standard Tcl result object. * * Side effects: * A variable will be created if one does not already exist. * *---------------------------------------------------------------------- */ int TclArraySet(interp, arrayNameObj, arrayElemObj) Tcl_Interp *interp; /* Current interpreter. */ Tcl_Obj *arrayNameObj; /* The array name. */ Tcl_Obj *arrayElemObj; /* The array elements list or dict. 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 == '(') { TclVarErrMsg(interp, varName, NULL, "set", needArray); return TCL_ERROR; |
︙ | ︙ | |||
3186 3187 3188 3189 3190 3191 3192 | int done; if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { return TCL_ERROR; } if (done == 0) { /* | | | > | | < | | > | | 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 | int done; if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { return TCL_ERROR; } if (done == 0) { /* * Empty, so we'll just force the array to be properly existing * instead. */ goto ensureArray; } /* * Don't need to look at result of Tcl_DictObjFirst as we've just * successfully used a dictionary operation on the same object. */ for (Tcl_DictObjFirst(interp, arrayElemObj, &search, &keyPtr, &valuePtr, &done) ; !done ; Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) { /* * At this point, it would be nice if the key was directly usable * by the array. This isn't the case though. */ char *part2 = TclGetString(keyPtr); Var *elemVarPtr = TclLookupArrayElement(interp, varName, part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr); if ((elemVarPtr == NULL) || (TclPtrSetVar(interp, elemVarPtr, varPtr, varName, part2, valuePtr, TCL_LEAVE_ERR_MSG) == NULL)) { Tcl_DictObjDone(&search); return TCL_ERROR; |
︙ | ︙ | |||
3238 3239 3240 3241 3242 3243 3244 | return TCL_ERROR; } if (elemLen == 0) { goto ensureArray; } /* | | | | | | > | | | | | < | | | > | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | 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 | return TCL_ERROR; } if (elemLen == 0) { goto ensureArray; } /* * 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; } /* * The list is empty make sure we have an array, or create one if * necessary. */ ensureArray: if (varPtr != NULL) { if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) { /* * Already an array, done. */ return TCL_OK; } if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { /* * Either an array element, or a scalar: lose! */ TclVarErrMsg(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. */ 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; CONST char *p; /* * 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 & FRAME_IS_PROC)) { Tcl_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 & FRAME_IS_PROC) || (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; } /* * Do not permit the new variable to look like an array reference, as * it will not be reachable in that case [Bug 600812, TIP 184]. The * "definition" of what "looks like an array reference" is consistent * (and must remain consistent) with the code in TclObjLookupVar(). */ p = strstr(myName, "("); if (p != NULL) { p += strlen(p)-1; if (*p == ')') { /* * myName looks like an array reference. */ Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", myName, "\": upvar won't create a scalar variable ", "that looks like an array element", (char *) NULL); return TCL_ERROR; } } /* * Lookup and eventually create the new variable. Set the flag bit * LOOKUP_FOR_UPVAR to indicate the special resolution rules for upvar * purposes: * - Bug #696893 - variable is either proc-local or in the current * namespace; never follow the second (global) resolution path. * - Bug #631741 - do not use special namespace or interp resolvers. */ varPtr = TclLookupSimpleVar(interp, myName, (myFlags|LOOKUP_FOR_UPVAR), /* create */ 1, &errMsg, &index); if (varPtr == NULL) { TclVarErrMsg(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; } |
︙ | ︙ | |||
3461 3462 3463 3464 3465 3466 3467 | } /* *---------------------------------------------------------------------- * * Tcl_UpVar -- * | | | | | | | < | | | | | | | | | | | < | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_UpVar -- * * This procedure links one variable to another, just like the "upvar" * command. * * Results: * A standard Tcl completion code. If an error occurs then an error * message is left in the interp's result. * * Side effects: * The variable in frameName whose name is given by varName becomes * accessible under the name localName, so that references to localName * are redirected to the other variable like a symbolic link. * *---------------------------------------------------------------------- */ 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 -- * * This procedure links one variable to another, just like the "upvar" * command. * * Results: * A standard Tcl completion code. If an error occurs then an error * message is left in the interp's result. * * Side effects: * The variable in frameName whose name is given by part1 and part2 * becomes accessible under the name localName, so that references to * localName are redirected to the other variable like a symbolic link. * *---------------------------------------------------------------------- */ 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; |
︙ | ︙ | |||
3549 3550 3551 3552 3553 3554 3555 | } /* *---------------------------------------------------------------------- * * Tcl_GetVariableFullName -- * | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_GetVariableFullName -- * * Given a Tcl_Var token returned by Tcl_FindNamespaceVar, this procedure * appends to an object the namespace variable's full name, qualified by * a sequence of parent namespace names. * * Results: * None. * * Side effects: * The variable's fully-qualified name is appended to the string * representation of objPtr. * *---------------------------------------------------------------------- */ void Tcl_GetVariableFullName(interp, variable, objPtr) Tcl_Interp *interp; /* Interpreter containing the variable. */ Tcl_Var variable; /* Token for the variable returned by a * previous call to Tcl_FindNamespaceVar. */ Tcl_Obj *objPtr; /* Points to the object onto which the * variable's full name is appended. */ { Interp *iPtr = (Interp *) interp; register Var *varPtr = (Var *) variable; char *name; /* * Add the full name of the containing namespace (if any), followed by the * "::" separator, then the variable name. */ if (varPtr != NULL) { if (!TclIsVarArrayElement(varPtr)) { if (varPtr->nsPtr != NULL) { Tcl_AppendToObj(objPtr, varPtr->nsPtr->fullName, -1); if (varPtr->nsPtr != iPtr->globalNsPtr) { |
︙ | ︙ | |||
3636 3637 3638 3639 3640 3641 3642 | Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?"); return TCL_ERROR; } /* * If we are not executing inside a Tcl procedure, just return. */ | | | | | | | | | | | | 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 | Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?"); return TCL_ERROR; } /* * If we are not executing inside a Tcl procedure, just return. */ if ((iPtr->varFramePtr == NULL) || !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) { return TCL_OK; } for (i = 1; i < objc; i++) { /* * Make a local variable linked to its counterpart in the global :: * namespace. */ objPtr = objv[i]; varName = TclGetString(objPtr); /* * The variable name might have a scope qualifier, but the name for * the local "link" variable must be the simple name at the tail. */ for (tail = varName; *tail != '\0'; tail++) { /* empty body */ } while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { tail--; } if ((*tail == ':') && (tail > varName)) { 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; } |
︙ | ︙ | |||
3695 3696 3697 3698 3699 3700 3701 | * variable ?name value...? name ?value? * * One or more variables can be created. The variables are initialized * with the specified values. The value for the last variable is * optional. * * If the variable does not exist, it is created and given the optional | | | | | | | < | | | | | 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 | * variable ?name value...? name ?value? * * One or more variables can be created. The variables are initialized * with the specified values. The value for the last variable is * optional. * * If the variable does not exist, it is created and given the optional * value. If it already exists, it is simply set to the optional value. * Normally, "name" is an unqualified name, so it is created in the * current namespace. If it includes namespace qualifiers, it can be * created in another namespace. * * If the variable command is executed inside a Tcl procedure, it creates * a local variable linked to the newly-created namespace variable. * * Results: * Returns TCL_OK if the variable is found or created. Returns TCL_ERROR * if anything goes wrong. * * Side effects: * If anything goes wrong, this procedure returns an error message as the * result in the interpreter's result object. * *---------------------------------------------------------------------- */ int Tcl_VariableObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ |
︙ | ︙ | |||
3736 3737 3738 3739 3740 3741 3742 | if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?"); return TCL_ERROR; } for (i = 1; i < objc; i = i+2) { /* | | | | | | | | | | | | > | | | | | | | < | | | | | | | | | | 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 | 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. */ TclVarErrMsg(interp, varName, NULL, "define", isArrayElement); return TCL_ERROR; } if (varPtr == NULL) { return TCL_ERROR; } /* * Mark the variable as a namespace variable and increment its * reference count so that it will persist until its namespace is * destroyed or until the variable is unset. */ if (!TclIsVarNamespaceVar(varPtr)) { TclSetVarNamespaceVar(varPtr); varPtr->refCount++; } /* * If a value was specified, set the variable to that value. * 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 variable * linked to the new namespace variable "varName". */ if ((iPtr->varFramePtr != NULL) && (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) { /* * varName might have a scope qualifier, but the name for the * local "link" variable must be the simple name at the tail. * * Locate tail in one pass: drop any prefix after two *or more* * consecutive ":" characters). */ for (tail=cp=varName ; *cp!='\0' ;) { if (*cp++ == ':') { while (*cp == ':') { tail = ++cp; } } } /* * 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; } /* *---------------------------------------------------------------------- * * Tcl_UpvarObjCmd -- * * This object-based procedure is invoked to process the "upvar" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
3856 3857 3858 3859 3860 3861 3862 | Tcl_Obj *CONST objv[]; /* Argument objects. */ { CallFrame *framePtr; char *localName; int result; if (objc < 3) { | | | | | | | | | | | | 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 | Tcl_Obj *CONST objv[]; /* Argument objects. */ { CallFrame *framePtr; char *localName; int result; if (objc < 3) { upvarSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? otherVar localVar ?otherVar localVar ...?"); return TCL_ERROR; } /* * Find the call frame containing each of the "other variables" to be * linked to. */ result = TclObjGetFrame(interp, objv[1], &framePtr); if (result == -1) { return TCL_ERROR; } objc -= result+1; if ((objc & 1) != 0) { goto upvarSyntax; } objv += result+1; /* * 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; } /* *---------------------------------------------------------------------- * * NewVar -- * * Create a new heap-allocated variable that will eventually be entered * into a hashtable. * * Results: * The return value is a pointer to the new variable structure. It is * marked as a scalar variable (and not a link or array variable). Its * value initially is NULL. The variable is not part of any hash table * yet. Since it will be in a hashtable and not in a call frame, its name * field is set NULL. It is initially marked as undefined. * * Side effects: * Storage gets allocated. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
3937 3938 3939 3940 3941 3942 3943 | } /* *---------------------------------------------------------------------- * * SetArraySearchObj -- * | | | | | < | | | | 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 | } /* *---------------------------------------------------------------------- * * SetArraySearchObj -- * * This function converts the given tcl object into one that has the * "array search" internal type. * * Results: * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed (when * an error message will be placed in the interpreter's result.) * * Side effects: * Updates the internal type and representation of the object to make * this an array-search object. See the tclArraySearchType declaration * above for details of the internal representation. * *---------------------------------------------------------------------- */ static int SetArraySearchObj(interp, objPtr) Tcl_Interp *interp; |
︙ | ︙ | |||
3972 3973 3974 3975 3976 3977 3978 3979 | */ string = TclGetString(objPtr); /* * Parse the id into the three parts separated by dashes. */ if ((string[0] != 's') || (string[1] != '-')) { | > | < < < > | | > | | > > > > > | | | | | | 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 | */ string = TclGetString(objPtr); /* * Parse the id into the three parts separated by dashes. */ if ((string[0] != 's') || (string[1] != '-')) { goto syntax; } id = strtoul(string+2, &end, 10); if ((end == (string+2)) || (*end != '-')) { goto syntax; } /* * Can't perform value check in this context, so place reference to place * in string to use for the check in the object instead. */ end++; offset = end - string; TclFreeIntRep(objPtr); objPtr->typePtr = &tclArraySearchType; objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)(((char *)NULL) + id); objPtr->internalRep.twoPtrValue.ptr2 = (VOID *)(((char *)NULL) + offset); return TCL_OK; syntax: Tcl_AppendResult(interp, "illegal search identifier \"", string, "\"", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * ParseSearchId -- * * This procedure translates from a tcl object to a pointer to an active * array search (if there is one that matches the string). * * Results: * The return value is a pointer to the array search indicated by string, * or NULL if there isn't one. If NULL is returned, the interp's result * contains an error message. * * Side effects: * The tcl object might have its internal type and representation * modified. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 | register size_t offset; int id; ArraySearch *searchPtr; /* * Parse the id. */ if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) { return NULL; } /* * Cast is safe, since always came from an int in the first place. */ id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) - | > > > | | > | | > | | | | | | | | | | | | | < | | | | 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 | register size_t offset; int id; ArraySearch *searchPtr; /* * Parse the id. */ if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) { return NULL; } /* * Cast is safe, since always came from an int in the first place. */ id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) - ((char*)NULL)); string = TclGetString(handleObj); offset = (((char*)handleObj->internalRep.twoPtrValue.ptr2) - ((char*)NULL)); /* * This test cannot be placed inside the Tcl_Obj machinery, since it is * dependent on the variable context. */ if (strcmp(string+offset, varName) != 0) { Tcl_AppendResult(interp, "search identifier \"", string, "\" isn't for variable \"", varName, "\"", (char *) NULL); return NULL; } /* * Search through the list of active searches on the interpreter to see if * the desired one exists. * * Note that we cannot store the searchPtr directly in the Tcl_Obj as that * would run into trouble when DeleteSearches() was called so we must scan * this list every time. */ for (searchPtr = varPtr->searchPtr; searchPtr != NULL; searchPtr = searchPtr->nextPtr) { if (searchPtr->id == id) { return searchPtr; } } Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", (char *) NULL); return NULL; } /* *---------------------------------------------------------------------- * * DeleteSearches -- * * This procedure is called to free up all of the searches associated * with an array variable. * * Results: * None. * * Side effects: * Memory is released to the storage allocator. * *---------------------------------------------------------------------- */ static void DeleteSearches(arrayVarPtr) register Var *arrayVarPtr; /* Variable whose searches are to be * deleted. */ { ArraySearch *searchPtr; while (arrayVarPtr->searchPtr != NULL) { searchPtr = arrayVarPtr->searchPtr; arrayVarPtr->searchPtr = searchPtr->nextPtr; ckfree((char *) searchPtr); } } /* *---------------------------------------------------------------------- * * TclDeleteVars -- * * This procedure is called to recycle all the storage space associated * with a table of variables. For this procedure to work correctly, it * must not be possible for any of the variables in the table to be * accessed from Tcl commands (e.g. from trace procedures). * * Results: * None. * * Side effects: * Variables are deleted and trace procedures are invoked, if any are * declared. * *---------------------------------------------------------------------- */ void TclDeleteVars(iPtr, tablePtr) Interp *iPtr; /* Interpreter to which variables belong. */ |
︙ | ︙ | |||
4159 4160 4161 4162 4163 4164 4165 | flags |= TCL_NAMESPACE_ONLY; } if (Tcl_InterpDeleted(interp)) { flags |= TCL_INTERP_DESTROYED; } for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; | | | | | | | | | | < | | | | | | | | | < | | | < | 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 | flags |= TCL_NAMESPACE_ONLY; } if (Tcl_InterpDeleted(interp)) { flags |= TCL_INTERP_DESTROYED; } for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(hPtr); /* * For global/upvar variables referenced in procedures, decrement the * reference count on the variable referred to, and free the * referenced variable if it's no longer needed. Don't delete the hash * entry for the other variable if it's in the same table as us: this * will happen automatically later on. */ if (TclIsVarLink(varPtr)) { linkPtr = varPtr->value.linkPtr; linkPtr->refCount--; if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) && (linkPtr->tracePtr == NULL) && (linkPtr->flags & VAR_IN_HASHTABLE)) { if (linkPtr->hPtr == NULL) { ckfree((char *) linkPtr); } else if (linkPtr->hPtr->tablePtr != tablePtr) { Tcl_DeleteHashEntry(linkPtr->hPtr); ckfree((char *) linkPtr); } } } /* * 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 TclCallVarTraces the variable's fully-qualified name so * that any called trace procedures can refer to these variables being * deleted. */ if (varPtr->tracePtr != NULL) { TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); /* until done with traces */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); TclCallVarTraces(iPtr, (Var *) NULL, varPtr, TclGetString(objPtr), NULL, flags, /* leaveErrMsg */ 0); TclDecrRefCount(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; } } } if (TclIsVarArray(varPtr)) { DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags); varPtr->value.tablePtr = NULL; } if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) { objPtr = varPtr->value.objPtr; TclDecrRefCount(objPtr); varPtr->value.objPtr = NULL; } varPtr->hPtr = NULL; varPtr->tracePtr = NULL; TclSetVarUndefined(varPtr); TclSetVarScalar(varPtr); /* * If the variable was a namespace variable, decrement its reference * count. We are in the process of destroying its namespace so that * namespace will no longer "refer" to the variable. */ if (TclIsVarNamespaceVar(varPtr)) { TclClearVarNamespaceVar(varPtr); varPtr->refCount--; } |
︙ | ︙ | |||
4262 4263 4264 4265 4266 4267 4268 | } /* *---------------------------------------------------------------------- * * TclDeleteCompiledLocalVars -- * | | | | | | | < | | | | < | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TclDeleteCompiledLocalVars -- * * This procedure is called to recycle storage space associated with the * compiler-allocated array of local variables in a procedure call frame. * This procedure resembles TclDeleteVars above except that each variable * is stored in a call frame and not a hash table. For this procedure to * work correctly, it must not be possible for any of the variable in the * table to be accessed from Tcl commands (e.g. from trace procedures). * * Results: * None. * * Side effects: * Variables are deleted and trace procedures are invoked, if any are * declared. * *---------------------------------------------------------------------- */ void TclDeleteCompiledLocalVars(iPtr, framePtr) Interp *iPtr; /* Interpreter to which variables belong. */ CallFrame *framePtr; /* Procedure call frame containing compiler- * assigned local variables to delete. */ { register Var *varPtr; int flags; /* Flags passed to trace procedures. */ Var *linkPtr; ActiveVarTrace *activePtr; int numLocals, i; flags = TCL_TRACE_UNSETS; numLocals = framePtr->numCompiledLocals; varPtr = framePtr->compiledLocals; for (i = 0; i < numLocals; i++) { /* * For global/upvar variables referenced in procedures, decrement the * reference count on the variable referred to, and free the * referenced variable if it's no longer needed. Don't delete the hash * entry for the other variable if it's in the same table as us: this * will happen automatically later on. */ if (TclIsVarLink(varPtr)) { linkPtr = varPtr->value.linkPtr; linkPtr->refCount--; if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) && (linkPtr->tracePtr == NULL) |
︙ | ︙ | |||
4334 4335 4336 4337 4338 4339 4340 | 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; | | | | | | | | | < | | | | | | | | | < | | > | | | | | < | | | | | | | | | | < | | | | | | | | | | | | | < | | | | < | | | | 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 | 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; } } } /* * Now if the variable is an array, delete its element hash table. * Otherwise, if it's a scalar variable, decrement the ref count of * its value. */ if (TclIsVarArray(varPtr) && (varPtr->value.tablePtr != NULL)) { DeleteArray(iPtr, varPtr->name, varPtr, flags); } if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) { TclDecrRefCount(varPtr->value.objPtr); varPtr->value.objPtr = NULL; } varPtr->hPtr = NULL; varPtr->tracePtr = NULL; TclSetVarUndefined(varPtr); TclSetVarScalar(varPtr); varPtr++; } } /* *---------------------------------------------------------------------- * * DeleteArray -- * * This procedure is called to free up everything in an array variable. * It's the caller's responsibility to make sure that the array is no * longer accessible before this procedure is called. * * Results: * None. * * Side effects: * All storage associated with varPtr's array elements is deleted * (including the array's hash table). Deletion trace procedures for * array elements are invoked, then deleted. Any pending traces for array * elements are also deleted. * *---------------------------------------------------------------------- */ 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 TclCallVarTraces: * TCL_TRACE_UNSETS and sometimes * TCL_INTERP_DESTROYED, TCL_NAMESPACE_ONLY, * or TCL_GLOBAL_ONLY. */ { Tcl_HashSearch search; register Tcl_HashEntry *hPtr; register Var *elPtr; ActiveVarTrace *activePtr; Tcl_Obj *objPtr; DeleteSearches(varPtr); for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { elPtr = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) { objPtr = elPtr->value.objPtr; TclDecrRefCount(objPtr); elPtr->value.objPtr = NULL; } elPtr->hPtr = NULL; if (elPtr->tracePtr != NULL) { elPtr->flags &= ~VAR_TRACE_ACTIVE; TclCallVarTraces(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); TclSetVarScalar(elPtr); /* * Even though array elements are not supposed to be namespace * variables, some combinations of [upvar] and [variable] may create * such beasts - see [Bug 604239]. This is necessary to avoid leaking * the corresponding Var struct, and is otherwise harmless. */ if (TclIsVarNamespaceVar(elPtr)) { TclClearVarNamespaceVar(elPtr); elPtr->refCount--; } if (elPtr->refCount == 0) { ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */ } } Tcl_DeleteHashTable(varPtr->value.tablePtr); ckfree((char *) varPtr->value.tablePtr); } /* *---------------------------------------------------------------------- * * TclCleanupVar -- * * This procedure is called when it looks like it may be OK to free up a * variable's storage. If the variable is in a hashtable, its Var * structure and hash table entry will be freed along with those of its * containing array, if any. This procedure is called, for example, when * a trace on a variable deletes a variable. * * Results: * None. * * Side effects: * If the variable (or its containing array) really is dead and in a * hashtable, then its Var structure, and possibly its hash table entry, * is freed up. * *---------------------------------------------------------------------- */ void TclCleanupVar(varPtr, arrayPtr) Var *varPtr; /* Pointer to variable that may be a candidate * for being expunged. */ Var *arrayPtr; /* Array that contains the variable, or NULL * if this variable isn't an array element. */ { if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0) && (varPtr->tracePtr == NULL) && (varPtr->flags & VAR_IN_HASHTABLE)) { if (varPtr->hPtr != NULL) { Tcl_DeleteHashEntry(varPtr->hPtr); } ckfree((char *) varPtr); } if (arrayPtr != NULL) { if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0) && (arrayPtr->tracePtr == NULL) && (arrayPtr->flags & VAR_IN_HASHTABLE)) { if (arrayPtr->hPtr != NULL) { Tcl_DeleteHashEntry(arrayPtr->hPtr); } ckfree((char *) arrayPtr); } } } /* *---------------------------------------------------------------------- * * TclVarErrMsg -- * * Generate a reasonable error message describing why a variable * operation failed. * * Results: * None. * * Side effects: * The interp's result is set to hold a message identifying the variable * given by part1 and part2 and describing why the variable operation * failed. * *---------------------------------------------------------------------- */ void TclVarErrMsg(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); } /* *---------------------------------------------------------------------- * * Internal functions for variable name object types -- * *---------------------------------------------------------------------- */ /* * Panic functions that should never be called in normal operation. */ static void PanicOnUpdateVarName(objPtr) Tcl_Obj *objPtr; { Tcl_Panic("ERROR: updateStringProc of type %s should not be called.", objPtr->typePtr->name); } static int PanicOnSetVarName(interp, objPtr) Tcl_Interp *interp; Tcl_Obj *objPtr; { Tcl_Panic("ERROR: setFromAnyProc of type %s should not be called.", objPtr->typePtr->name); return TCL_ERROR; } /* * localVarName - * * INTERNALREP DEFINITION: * longValue = index into locals table */ static void DupLocalVarName(srcPtr, dupPtr) Tcl_Obj *srcPtr; Tcl_Obj *dupPtr; { dupPtr->internalRep.longValue = srcPtr->internalRep.longValue; dupPtr->typePtr = &localVarNameType; } #if ENABLE_NS_VARNAME_CACHING /* * 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)) { TclCleanupVar(varPtr, NULL); } } static void |
︙ | ︙ | |||
4622 4623 4624 4625 4626 4627 4628 | dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr; dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr; varPtr->refCount++; dupPtr->typePtr = &tclNsVarNameType; } #endif | | | < | < | | | | | | | | 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 | dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr; dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr; varPtr->refCount++; dupPtr->typePtr = &tclNsVarNameType; } #endif /* * 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); |
︙ | ︙ | |||
4683 4684 4685 4686 4687 4688 4689 | 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) { /* | | < > > > > > > > > > > | 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 | 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? */ Tcl_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'; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Added generic/tommath.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ #ifndef BN_H_ #define BN_H_ #ifdef TCL_TOMMATH #include <tclTomMath.h> #endif #ifndef TOMMATH_STORAGE_CLASS #define TOMMATH_STORAGE_CLASS extern #endif #include <stdio.h> #include <string.h> #include <stdlib.h> #include <ctype.h> #include <limits.h> #include <tommath_class.h> #ifndef MIN #define MIN(x,y) ((x)<(y)?(x):(y)) #endif #ifndef MAX #define MAX(x,y) ((x)>(y)?(x):(y)) #endif #ifdef __cplusplus extern "C" { /* C++ compilers don't like assigning void * to mp_digit * */ #define OPT_CAST(x) (x *) #else /* C on the other hand doesn't care */ #define OPT_CAST(x) #endif /* detect 64-bit mode if possible */ #if defined(__x86_64__) #if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT)) #define MP_64BIT #endif #endif /* some default configurations. * * A "mp_digit" must be able to hold DIGIT_BIT + 1 bits * A "mp_word" must be able to hold 2*DIGIT_BIT + 1 bits * * At the very least a mp_digit must be able to hold 7 bits * [any size beyond that is ok provided it doesn't overflow the data type] */ #ifdef MP_8BIT #ifndef MP_DIGIT_DECLARED typedef unsigned char mp_digit; #define MP_DIGIT_DECLARED #endif typedef unsigned short mp_word; #elif defined(MP_16BIT) #ifndef MP_DIGIT_DECLARED typedef unsigned short mp_digit; #define MP_DIGIT_DECLARED #endif typedef unsigned long mp_word; #elif defined(MP_64BIT) /* for GCC only on supported platforms */ #ifndef CRYPT typedef unsigned long long ulong64; typedef signed long long long64; #endif #ifndef MP_DIGIT_DECLARED typedef unsigned long mp_digit; #define MP_DIGIT_DECLARED #endif typedef unsigned long mp_word __attribute__ ((mode(TI))); #define DIGIT_BIT 60 #else /* this is the default case, 28-bit digits */ /* this is to make porting into LibTomCrypt easier :-) */ #ifndef CRYPT #if defined(_MSC_VER) || defined(__BORLANDC__) typedef unsigned __int64 ulong64; typedef signed __int64 long64; #else typedef unsigned long long ulong64; typedef signed long long long64; #endif #endif #ifndef MP_DIGIT_DECLARED typedef unsigned long mp_digit; #define MP_DIGIT_DECLARED #endif typedef ulong64 mp_word; #ifdef MP_31BIT /* this is an extension that uses 31-bit digits */ #define DIGIT_BIT 31 #else /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ #define DIGIT_BIT 28 #define MP_28BIT #endif #endif /* define heap macros */ #ifndef CRYPT /* default to libc stuff */ #ifndef XMALLOC #define XMALLOC malloc #define XFREE free #define XREALLOC realloc #define XCALLOC calloc #else /* prototypes for our heap functions */ extern void *XMALLOC(size_t n); extern void *XREALLOC(void *p, size_t n); extern void *XCALLOC(size_t n, size_t s); extern void XFREE(void *p); #endif #endif /* otherwise the bits per digit is calculated automatically from the size of a mp_digit */ #ifndef DIGIT_BIT #define DIGIT_BIT ((int)((CHAR_BIT * sizeof(mp_digit) - 1))) /* bits per digit */ #endif #define MP_DIGIT_BIT DIGIT_BIT #define MP_MASK ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1)) #define MP_DIGIT_MAX MP_MASK /* equalities */ #define MP_LT -1 /* less than */ #define MP_EQ 0 /* equal to */ #define MP_GT 1 /* greater than */ #define MP_ZPOS 0 /* positive integer */ #define MP_NEG 1 /* negative */ #define MP_OKAY 0 /* ok result */ #define MP_MEM -2 /* out of mem */ #define MP_VAL -3 /* invalid input */ #define MP_RANGE MP_VAL #define MP_YES 1 /* yes response */ #define MP_NO 0 /* no response */ /* Primality generation flags */ #define LTM_PRIME_BBS 0x0001 /* BBS style prime */ #define LTM_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */ #define LTM_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */ typedef int mp_err; /* you'll have to tune these... */ extern int KARATSUBA_MUL_CUTOFF, KARATSUBA_SQR_CUTOFF, TOOM_MUL_CUTOFF, TOOM_SQR_CUTOFF; /* define this to use lower memory usage routines (exptmods mostly) */ /* #define MP_LOW_MEM */ /* default precision */ #ifndef MP_PREC #ifndef MP_LOW_MEM #define MP_PREC 32 /* default digits of precision */ #else #define MP_PREC 8 /* default digits of precision */ #endif #endif /* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ #define MP_WARRAY (1 << (sizeof(mp_word) * CHAR_BIT - 2 * DIGIT_BIT + 1)) /* the infamous mp_int structure */ #ifndef MP_INT_DECLARED #define MP_INT_DECLARED typedef struct mp_int mp_int; #endif struct mp_int { int used, alloc, sign; mp_digit *dp; }; /* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */ typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); #define USED(m) ((m)->used) #define DIGIT(m,k) ((m)->dp[(k)]) #define SIGN(m) ((m)->sign) /* error code to char* string */ TOMMATH_STORAGE_CLASS char *mp_error_to_string(int code); /* ---> init and deinit bignum functions <--- */ /* init a bignum */ TOMMATH_STORAGE_CLASS int mp_init(mp_int *a); /* free a bignum */ TOMMATH_STORAGE_CLASS void mp_clear(mp_int *a); /* init a null terminated series of arguments */ TOMMATH_STORAGE_CLASS int mp_init_multi(mp_int *mp, ...); /* clear a null terminated series of arguments */ TOMMATH_STORAGE_CLASS void mp_clear_multi(mp_int *mp, ...); /* exchange two ints */ TOMMATH_STORAGE_CLASS void mp_exch(mp_int *a, mp_int *b); /* shrink ram required for a bignum */ TOMMATH_STORAGE_CLASS int mp_shrink(mp_int *a); /* grow an int to a given size */ TOMMATH_STORAGE_CLASS int mp_grow(mp_int *a, int size); /* init to a given number of digits */ TOMMATH_STORAGE_CLASS int mp_init_size(mp_int *a, int size); /* ---> Basic Manipulations <--- */ #define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO) #define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO) #define mp_isodd(a) (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO) /* set to zero */ TOMMATH_STORAGE_CLASS void mp_zero(mp_int *a); /* set to a digit */ TOMMATH_STORAGE_CLASS void mp_set(mp_int *a, mp_digit b); /* set a 32-bit const */ TOMMATH_STORAGE_CLASS int mp_set_int(mp_int *a, unsigned long b); /* get a 32-bit value */ unsigned long mp_get_int(mp_int * a); /* initialize and set a digit */ TOMMATH_STORAGE_CLASS int mp_init_set (mp_int * a, mp_digit b); /* initialize and set 32-bit value */ TOMMATH_STORAGE_CLASS int mp_init_set_int (mp_int * a, unsigned long b); /* copy, b = a */ TOMMATH_STORAGE_CLASS int mp_copy(mp_int *a, mp_int *b); /* inits and copies, a = b */ TOMMATH_STORAGE_CLASS int mp_init_copy(mp_int *a, mp_int *b); /* trim unused digits */ TOMMATH_STORAGE_CLASS void mp_clamp(mp_int *a); /* ---> digit manipulation <--- */ /* right shift by "b" digits */ TOMMATH_STORAGE_CLASS void mp_rshd(mp_int *a, int b); /* left shift by "b" digits */ TOMMATH_STORAGE_CLASS int mp_lshd(mp_int *a, int b); /* c = a / 2**b */ TOMMATH_STORAGE_CLASS int mp_div_2d(mp_int *a, int b, mp_int *c, mp_int *d); /* b = a/2 */ TOMMATH_STORAGE_CLASS int mp_div_2(mp_int *a, mp_int *b); /* c = a * 2**b */ TOMMATH_STORAGE_CLASS int mp_mul_2d(mp_int *a, int b, mp_int *c); /* b = a*2 */ TOMMATH_STORAGE_CLASS int mp_mul_2(mp_int *a, mp_int *b); /* c = a mod 2**d */ TOMMATH_STORAGE_CLASS int mp_mod_2d(mp_int *a, int b, mp_int *c); /* computes a = 2**b */ TOMMATH_STORAGE_CLASS int mp_2expt(mp_int *a, int b); /* Counts the number of lsbs which are zero before the first zero bit */ TOMMATH_STORAGE_CLASS int mp_cnt_lsb(mp_int *a); /* I Love Earth! */ /* makes a pseudo-random int of a given size */ TOMMATH_STORAGE_CLASS int mp_rand(mp_int *a, int digits); /* ---> binary operations <--- */ /* c = a XOR b */ TOMMATH_STORAGE_CLASS int mp_xor(mp_int *a, mp_int *b, mp_int *c); /* c = a OR b */ TOMMATH_STORAGE_CLASS int mp_or(mp_int *a, mp_int *b, mp_int *c); /* c = a AND b */ TOMMATH_STORAGE_CLASS int mp_and(mp_int *a, mp_int *b, mp_int *c); /* ---> Basic arithmetic <--- */ /* b = -a */ TOMMATH_STORAGE_CLASS int mp_neg(mp_int *a, mp_int *b); /* b = |a| */ TOMMATH_STORAGE_CLASS int mp_abs(mp_int *a, mp_int *b); /* compare a to b */ TOMMATH_STORAGE_CLASS int mp_cmp(mp_int *a, mp_int *b); /* compare |a| to |b| */ TOMMATH_STORAGE_CLASS int mp_cmp_mag(mp_int *a, mp_int *b); /* c = a + b */ TOMMATH_STORAGE_CLASS int mp_add(mp_int *a, mp_int *b, mp_int *c); /* c = a - b */ TOMMATH_STORAGE_CLASS int mp_sub(mp_int *a, mp_int *b, mp_int *c); /* c = a * b */ TOMMATH_STORAGE_CLASS int mp_mul(mp_int *a, mp_int *b, mp_int *c); /* b = a*a */ TOMMATH_STORAGE_CLASS int mp_sqr(mp_int *a, mp_int *b); /* a/b => cb + d == a */ TOMMATH_STORAGE_CLASS int mp_div(mp_int *a, mp_int *b, mp_int *c, mp_int *d); /* c = a mod b, 0 <= c < b */ TOMMATH_STORAGE_CLASS int mp_mod(mp_int *a, mp_int *b, mp_int *c); /* ---> single digit functions <--- */ /* compare against a single digit */ TOMMATH_STORAGE_CLASS int mp_cmp_d(mp_int *a, mp_digit b); /* c = a + b */ TOMMATH_STORAGE_CLASS int mp_add_d(mp_int *a, mp_digit b, mp_int *c); /* c = a - b */ TOMMATH_STORAGE_CLASS int mp_sub_d(mp_int *a, mp_digit b, mp_int *c); /* c = a * b */ TOMMATH_STORAGE_CLASS int mp_mul_d(mp_int *a, mp_digit b, mp_int *c); /* a/b => cb + d == a */ TOMMATH_STORAGE_CLASS int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d); /* a/3 => 3c + d == a */ TOMMATH_STORAGE_CLASS int mp_div_3(mp_int *a, mp_int *c, mp_digit *d); /* c = a**b */ TOMMATH_STORAGE_CLASS int mp_expt_d(mp_int *a, mp_digit b, mp_int *c); /* c = a mod b, 0 <= c < b */ TOMMATH_STORAGE_CLASS int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c); /* ---> number theory <--- */ /* d = a + b (mod c) */ TOMMATH_STORAGE_CLASS int mp_addmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); /* d = a - b (mod c) */ TOMMATH_STORAGE_CLASS int mp_submod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); /* d = a * b (mod c) */ TOMMATH_STORAGE_CLASS int mp_mulmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); /* c = a * a (mod b) */ TOMMATH_STORAGE_CLASS int mp_sqrmod(mp_int *a, mp_int *b, mp_int *c); /* c = 1/a (mod b) */ TOMMATH_STORAGE_CLASS int mp_invmod(mp_int *a, mp_int *b, mp_int *c); /* c = (a, b) */ TOMMATH_STORAGE_CLASS int mp_gcd(mp_int *a, mp_int *b, mp_int *c); /* produces value such that U1*a + U2*b = U3 */ TOMMATH_STORAGE_CLASS int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3); /* c = [a, b] or (a*b)/(a, b) */ TOMMATH_STORAGE_CLASS int mp_lcm(mp_int *a, mp_int *b, mp_int *c); /* finds one of the b'th root of a, such that |c|**b <= |a| * * returns error if a < 0 and b is even */ TOMMATH_STORAGE_CLASS int mp_n_root(mp_int *a, mp_digit b, mp_int *c); /* special sqrt algo */ TOMMATH_STORAGE_CLASS int mp_sqrt(mp_int *arg, mp_int *ret); /* is number a square? */ TOMMATH_STORAGE_CLASS int mp_is_square(mp_int *arg, int *ret); /* computes the jacobi c = (a | n) (or Legendre if b is prime) */ TOMMATH_STORAGE_CLASS int mp_jacobi(mp_int *a, mp_int *n, int *c); /* used to setup the Barrett reduction for a given modulus b */ TOMMATH_STORAGE_CLASS int mp_reduce_setup(mp_int *a, mp_int *b); /* Barrett Reduction, computes a (mod b) with a precomputed value c * * Assumes that 0 < a <= b*b, note if 0 > a > -(b*b) then you can merely * compute the reduction as -1 * mp_reduce(mp_abs(a)) [pseudo code]. */ TOMMATH_STORAGE_CLASS int mp_reduce(mp_int *a, mp_int *b, mp_int *c); /* setups the montgomery reduction */ TOMMATH_STORAGE_CLASS int mp_montgomery_setup(mp_int *a, mp_digit *mp); /* computes a = B**n mod b without division or multiplication useful for * normalizing numbers in a Montgomery system. */ TOMMATH_STORAGE_CLASS int mp_montgomery_calc_normalization(mp_int *a, mp_int *b); /* computes x/R == x (mod N) via Montgomery Reduction */ TOMMATH_STORAGE_CLASS int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); /* returns 1 if a is a valid DR modulus */ TOMMATH_STORAGE_CLASS int mp_dr_is_modulus(mp_int *a); /* sets the value of "d" required for mp_dr_reduce */ TOMMATH_STORAGE_CLASS void mp_dr_setup(mp_int *a, mp_digit *d); /* reduces a modulo b using the Diminished Radix method */ TOMMATH_STORAGE_CLASS int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp); /* returns true if a can be reduced with mp_reduce_2k */ TOMMATH_STORAGE_CLASS int mp_reduce_is_2k(mp_int *a); /* determines k value for 2k reduction */ TOMMATH_STORAGE_CLASS int mp_reduce_2k_setup(mp_int *a, mp_digit *d); /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ TOMMATH_STORAGE_CLASS int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d); /* returns true if a can be reduced with mp_reduce_2k_l */ TOMMATH_STORAGE_CLASS int mp_reduce_is_2k_l(mp_int *a); /* determines k value for 2k reduction */ TOMMATH_STORAGE_CLASS int mp_reduce_2k_setup_l(mp_int *a, mp_int *d); /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ TOMMATH_STORAGE_CLASS int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d); /* d = a**b (mod c) */ TOMMATH_STORAGE_CLASS int mp_exptmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); /* ---> Primes <--- */ /* number of primes */ #ifdef MP_8BIT #define PRIME_SIZE 31 #else #define PRIME_SIZE 256 #endif /* table of first PRIME_SIZE primes */ extern const mp_digit ltm_prime_tab[]; /* result=1 if a is divisible by one of the first PRIME_SIZE primes */ TOMMATH_STORAGE_CLASS int mp_prime_is_divisible(mp_int *a, int *result); /* performs one Fermat test of "a" using base "b". * Sets result to 0 if composite or 1 if probable prime */ TOMMATH_STORAGE_CLASS int mp_prime_fermat(mp_int *a, mp_int *b, int *result); /* performs one Miller-Rabin test of "a" using base "b". * Sets result to 0 if composite or 1 if probable prime */ TOMMATH_STORAGE_CLASS int mp_prime_miller_rabin(mp_int *a, mp_int *b, int *result); /* This gives [for a given bit size] the number of trials required * such that Miller-Rabin gives a prob of failure lower than 2^-96 */ TOMMATH_STORAGE_CLASS int mp_prime_rabin_miller_trials(int size); /* performs t rounds of Miller-Rabin on "a" using the first * t prime bases. Also performs an initial sieve of trial * division. Determines if "a" is prime with probability * of error no more than (1/4)**t. * * Sets result to 1 if probably prime, 0 otherwise */ TOMMATH_STORAGE_CLASS int mp_prime_is_prime(mp_int *a, int t, int *result); /* finds the next prime after the number "a" using "t" trials * of Miller-Rabin. * * bbs_style = 1 means the prime must be congruent to 3 mod 4 */ TOMMATH_STORAGE_CLASS int mp_prime_next_prime(mp_int *a, int t, int bbs_style); /* makes a truly random prime of a given size (bytes), * call with bbs = 1 if you want it to be congruent to 3 mod 4 * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself * so it can be NULL * * The prime generated will be larger than 2^(8*size). */ #define mp_prime_random(a, t, size, bbs, cb, dat) mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?LTM_PRIME_BBS:0, cb, dat) /* makes a truly random prime of a given size (bits), * * Flags are as follows: * * LTM_PRIME_BBS - make prime congruent to 3 mod 4 * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero * LTM_PRIME_2MSB_ON - make the 2nd highest bit one * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself * so it can be NULL * */ TOMMATH_STORAGE_CLASS int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat); /* ---> radix conversion <--- */ TOMMATH_STORAGE_CLASS int mp_count_bits(mp_int *a); TOMMATH_STORAGE_CLASS int mp_unsigned_bin_size(mp_int *a); TOMMATH_STORAGE_CLASS int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c); TOMMATH_STORAGE_CLASS int mp_to_unsigned_bin(mp_int *a, unsigned char *b); TOMMATH_STORAGE_CLASS int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); TOMMATH_STORAGE_CLASS int mp_signed_bin_size(mp_int *a); TOMMATH_STORAGE_CLASS int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c); TOMMATH_STORAGE_CLASS int mp_to_signed_bin(mp_int *a, unsigned char *b); TOMMATH_STORAGE_CLASS int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); TOMMATH_STORAGE_CLASS int mp_read_radix(mp_int *a, const char *str, int radix); TOMMATH_STORAGE_CLASS int mp_toradix(mp_int *a, char *str, int radix); TOMMATH_STORAGE_CLASS int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen); TOMMATH_STORAGE_CLASS int mp_radix_size(mp_int *a, int radix, int *size); TOMMATH_STORAGE_CLASS int mp_fread(mp_int *a, int radix, FILE *stream); TOMMATH_STORAGE_CLASS int mp_fwrite(mp_int *a, int radix, FILE *stream); #define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len)) #define mp_raw_size(mp) mp_signed_bin_size(mp) #define mp_toraw(mp, str) mp_to_signed_bin((mp), (str)) #define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len)) #define mp_mag_size(mp) mp_unsigned_bin_size(mp) #define mp_tomag(mp, str) mp_to_unsigned_bin((mp), (str)) #define mp_tobinary(M, S) mp_toradix((M), (S), 2) #define mp_tooctal(M, S) mp_toradix((M), (S), 8) #define mp_todecimal(M, S) mp_toradix((M), (S), 10) #define mp_tohex(M, S) mp_toradix((M), (S), 16) /* lowlevel functions, do not call! */ TOMMATH_STORAGE_CLASS int s_mp_add(mp_int *a, mp_int *b, mp_int *c); TOMMATH_STORAGE_CLASS int s_mp_sub(mp_int *a, mp_int *b, mp_int *c); #define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1) TOMMATH_STORAGE_CLASS int fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); TOMMATH_STORAGE_CLASS int s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); TOMMATH_STORAGE_CLASS int fast_s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); TOMMATH_STORAGE_CLASS int s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); TOMMATH_STORAGE_CLASS int fast_s_mp_sqr(mp_int *a, mp_int *b); TOMMATH_STORAGE_CLASS int s_mp_sqr(mp_int *a, mp_int *b); TOMMATH_STORAGE_CLASS int mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c); TOMMATH_STORAGE_CLASS int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c); TOMMATH_STORAGE_CLASS int mp_karatsuba_sqr(mp_int *a, mp_int *b); TOMMATH_STORAGE_CLASS int mp_toom_sqr(mp_int *a, mp_int *b); TOMMATH_STORAGE_CLASS int fast_mp_invmod(mp_int *a, mp_int *b, mp_int *c); TOMMATH_STORAGE_CLASS int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c); TOMMATH_STORAGE_CLASS int fast_mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); TOMMATH_STORAGE_CLASS int mp_exptmod_fast(mp_int *G, mp_int *X, mp_int *P, mp_int *Y, int mode); TOMMATH_STORAGE_CLASS int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int mode); TOMMATH_STORAGE_CLASS void bn_reverse(unsigned char *s, int len); extern const char *mp_s_rmap; #ifdef __cplusplus } #endif #endif /* $Source: /root/tcl/repos-to-convert/tcl/generic/tommath.h,v $ */ /* $Revision: 1.1.2.4 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
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 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 | # 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.21.2.3 2005/08/02 18:16:14 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # auto_reset -- # # Destroy all cached information for auto-loading and auto-execution, # so that the information gets recomputed the next time it's needed. # Also delete any commands that are listed in the auto-load index. # # Arguments: # None. proc auto_reset {} { if {[array exists ::auto_index]} { foreach cmdName [array names ::auto_index] { set fqcn [namespace which $cmdName] if {$fqcn eq ""} {continue} rename $fqcn {} } } unset -nocomplain ::auto_execs ::auto_index ::tcl::auto_oldpath if {[catch {llength $::auto_path}]} { set ::auto_path [list [info library]] } else { if {[info library] ni $::auto_path} { lappend ::auto_path [info library] } } } # tcl_findLibrary -- # # This is a utility for extensions that searches for a library directory # using a canonical searching algorithm. A side effect is to source # the initialization script and set a global library variable. |
︙ | ︙ | |||
54 55 56 57 58 59 60 | global env set dirs {} set errors {} # The C application may have hardwired a path, which we honor | | < | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | global env set dirs {} set errors {} # The C application may have hardwired a path, which we honor if {[info exists the_library] && $the_library ne ""} { lappend dirs $the_library } else { # Do the canonical search # 1. From an environment variable, if it exists. # Placing this first gives the end-user ultimate control |
︙ | ︙ | |||
149 150 151 152 153 154 155 | return } else { append errors "$file: $msg\n" append errors [dict get $opts -errorinfo]\n } } } | < | < | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | return } else { append errors "$file: $msg\n" append errors [dict get $opts -errorinfo]\n } } } unset -nocomplain the_library set msg "Can't find a usable $initScript in the following directories: \n" append msg " $dirs\n\n" append msg "$errors\n\n" append msg "This probably means that $basename wasn't installed properly.\n" error $msg } |
︙ | ︙ | |||
207 208 209 210 211 212 213 | append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" if {[llength $args] == 0} { set args *.tcl } auto_mkindex_parser::init | | | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 | append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" if {[llength $args] == 0} { set args *.tcl } auto_mkindex_parser::init foreach file [glob -- {expand}$args] { if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} { append index $msg } else { cd $oldDir return -options $opts $msg } } |
︙ | ︙ | |||
240 241 242 243 244 245 246 | append index "# more commands. Typically each line is a command that\n" append index "# sets an element in the auto_index array, where the\n" append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" if {[llength $args] == 0} { set args *.tcl } | | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | append index "# more commands. Typically each line is a command that\n" append index "# sets an element in the auto_index array, where the\n" append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" if {[llength $args] == 0} { set args *.tcl } foreach file [glob -- {expand}$args] { set f "" set error [catch { set f [open $file] while {[gets $f line] >= 0} { if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} { set procName [lindex [auto_qualify $procName "::"] 0] append index "set [list auto_index($procName)]" |
︙ | ︙ | |||
285 286 287 288 289 290 291 | namespace eval auto_mkindex_parser { variable parser "" ;# parser used to build index variable index "" ;# maintains index as it is built variable scriptFile "" ;# name of file being processed variable contextStack "" ;# stack of namespace scopes variable imports "" ;# keeps track of all imported cmds | | > > > | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 | namespace eval auto_mkindex_parser { variable parser "" ;# parser used to build index variable index "" ;# maintains index as it is built variable scriptFile "" ;# name of file being processed variable contextStack "" ;# stack of namespace scopes variable imports "" ;# keeps track of all imported cmds variable initCommands ;# list of commands that create aliases if {![info exists initCommands]} { set initCommands [list] } proc init {} { variable parser variable initCommands if {![interp issafe]} { set parser [interp create -safe] |
︙ | ︙ | |||
433 434 435 436 437 438 439 | # body Implementation of command to handle indexing. proc auto_mkindex_parser::commandInit {name arglist body} { variable parser set ns [namespace qualifiers $name] set tail [namespace tail $name] | | | < | | | 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 | # body Implementation of command to handle indexing. proc auto_mkindex_parser::commandInit {name arglist body} { variable parser set ns [namespace qualifiers $name] set tail [namespace tail $name] if {$ns eq ""} { set fakeName [namespace current]::_%@fake_$tail } else { set fakeName [namespace current]::[string map {:: _} _%@fake_$name] } proc $fakeName $arglist $body # YUK! Tcl won't let us alias fully qualified command names, # so we can't handle names like "::itcl::class". Instead, # we have to build procs with the fully qualified names, and # have the procs point to the aliases. if {[string match *::* $name]} { set exportCmd [list _%@namespace export [namespace tail $name]] $parser eval [list _%@namespace eval $ns $exportCmd] # The following proc definition does not work if you # want to tolerate space or something else diabolical # in the procedure name, (i.e., space in $alias) # The following does not work: |
︙ | ︙ | |||
496 497 498 499 500 501 502 | set name "${ns}::$name" if {[string match ::* $name]} { break } } } | | > > > > | 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 | set name "${ns}::$name" if {[string match ::* $name]} { break } } } if {[namespace qualifiers $name] eq ""} { set name [namespace tail $name] } elseif {![string match ::* $name]} { set name "::$name" } # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse # that replacement. return [string map [list \0 \$] $name] } if {[llength $::auto_mkindex_parser::initCommands]} { return } # Register all of the procedures for the auto_mkindex parser that # will build the "tclIndex" file. # AUTO MKINDEX: proc name arglist body # Adds an entry to the auto index list for the given procedure name. |
︙ | ︙ | |||
536 537 538 539 540 541 542 | # variable. Second, because the package index file may defer loading the # library until we invoke a command, we need to explicitly invoke auto_load # to force it to be loaded. This should be a noop if the package has # already been loaded auto_mkindex_parser::hook { if {![catch {package require tbcload}]} { | | | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 | # variable. Second, because the package index file may defer loading the # library until we invoke a command, we need to explicitly invoke auto_load # to force it to be loaded. This should be a noop if the package has # already been loaded auto_mkindex_parser::hook { if {![catch {package require tbcload}]} { if {[namespace which -command tbcload::bcproc] eq ""} { auto_load tbcload::bcproc } load {} tbcload $auto_mkindex_parser::parser # AUTO MKINDEX: tbcload::bcproc name arglist body # Adds an entry to the auto index list for the given pre-compiled # procedure name. |
︙ | ︙ | |||
587 588 589 590 591 592 593 | $parser eval [list _%@namespace eval $name] $args set contextStack [lrange $contextStack 1 end] } import { variable parser variable imports foreach pattern $args { | | | 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 | $parser eval [list _%@namespace eval $name] $args set contextStack [lrange $contextStack 1 end] } import { variable parser variable imports foreach pattern $args { if {$pattern ne "-force"} { lappend imports $pattern } } catch {$parser eval "_%@namespace import $args"} } } } return |
Changes to library/clock.tcl.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # #---------------------------------------------------------------------- # # Copyright (c) 2004 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) 2004 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: clock.tcl,v 1.12.2.4 2005/08/15 18:14:00 dgp Exp $ # #---------------------------------------------------------------------- # We must have message catalogs that support the root locale, and # we need access to the Registry on Windows systems. We also need # Tcl 8.5 dictionaries. |
︙ | ︙ | |||
78 79 80 81 82 83 84 85 86 | namespace export add # Import the message catalog commands that we use. namespace import ::msgcat::mcload namespace import ::msgcat::mclocale # Define the Greenwich time zone | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 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 | namespace export add # Import the message catalog commands that we use. namespace import ::msgcat::mcload namespace import ::msgcat::mclocale } #---------------------------------------------------------------------- # # ::tcl::clock::Initialize -- # # Finish initializing the 'clock' subsystem # # Results: # None. # # Side effects: # Namespace variable in the 'clock' subsystem are initialized. # # The '::tcl::clock::Initialize' procedure initializes the namespace # variables and root locale message catalog for the 'clock' subsystem. # It is broken into a procedure rather than simply evaluated as a script # so that it will be able to use local variables, avoiding the dangers # of 'creative writing' as in Bug 1185933. # #---------------------------------------------------------------------- proc ::tcl::clock::Initialize {} { rename ::tcl::clock::Initialize {} variable LibDir # Define the Greenwich time zone proc InitTZData {} { variable TZData array unset TZData set TZData(:Etc/GMT) { {-9223372036854775808 0 0 GMT} } set TZData(:GMT) $TZData(:Etc/GMT) set TZData(:Etc/UTC) { {-9223372036854775808 0 0 UTC} } set TZData(:UTC) $TZData(:Etc/UTC) } InitTZData # Define the message catalog for the root locale. ::msgcat::mcmset {} { AM {am} BCE {B.C.E.} CE {C.E.} |
︙ | ︙ | |||
223 224 225 226 227 228 229 | # #------------------------------------------------------------------ # Paths at which binary time zone data for the Olson libraries # are known to reside on various operating systems variable ZoneinfoPaths {} | < < < | | | > | | | | | | | < < | 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 | # #------------------------------------------------------------------ # Paths at which binary time zone data for the Olson libraries # are known to reside on various operating systems variable ZoneinfoPaths {} foreach path { /usr/share/zoneinfo /usr/share/lib/zoneinfo /usr/lib/zoneinfo /usr/local/etc/zoneinfo C:/Progra~1/cygwin/usr/local/etc/zoneinfo } { if { [file isdirectory $path] } { lappend ZoneinfoPaths $path } } # Define the directories for time zone data and message catalogs. variable DataDir [file join $LibDir tzdata] variable MsgDir [file join $LibDir msgs] # Number of days in the months, in common years and leap years. |
︙ | ︙ | |||
260 261 262 263 264 265 266 | foreach j $DaysInRomanMonthInCommonYear { lappend DaysInPriorMonthsInCommonYear [incr i $j] } set i 0 foreach j $DaysInRomanMonthInLeapYear { lappend DaysInPriorMonthsInLeapYear [incr i $j] } | < | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 | foreach j $DaysInRomanMonthInCommonYear { lappend DaysInPriorMonthsInCommonYear [incr i $j] } set i 0 foreach j $DaysInRomanMonthInLeapYear { lappend DaysInPriorMonthsInLeapYear [incr i $j] } # Another epoch (Hi, Jeff!) variable Roddenberry 1946 # Integer ranges |
︙ | ︙ | |||
594 595 596 597 598 599 600 601 602 603 604 605 606 607 | # if it is known. variable TZData; # Array whose keys are time zone names # and whose values are lists of quads # comprising start time, UTC offset, # Daylight Saving Time indicator, and # time zone abbreviation. } #---------------------------------------------------------------------- # # clock format -- # # Formats a count of seconds since the Posix Epoch as a time # of day. | > | 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 | # if it is known. variable TZData; # Array whose keys are time zone names # and whose values are lists of quads # comprising start time, UTC offset, # Daylight Saving Time indicator, and # time zone abbreviation. } ::tcl::clock::Initialize #---------------------------------------------------------------------- # # clock format -- # # Formats a count of seconds since the Posix Epoch as a time # of day. |
︙ | ︙ | |||
703 704 705 706 707 708 709 | set date [GetYearWeekDay $date[set date {}]] # Format the result set state {} set retval {} foreach char [split $format {}] { | | | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 | set date [GetYearWeekDay $date[set date {}]] # Format the result set state {} set retval {} foreach char [split $format {}] { switch -exact -- $state { {} { if { [string equal % $char] } { set state percent } else { append retval $char } } |
︙ | ︙ | |||
1300 1301 1302 1303 1304 1305 1306 | -timezone $timezone -locale $locale] } # Do relative weekday if { [llength $parseWeekday] > 0 } { | < < < < | 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 | -timezone $timezone -locale $locale] } # Do relative weekday if { [llength $parseWeekday] > 0 } { foreach {dayOrdinal dayOfWeek} $parseWeekday break set date2 [GetJulianDay \ [ConvertUTCToLocal \ [dict create seconds $seconds] \ $timezone]] dict set date2 era CE set jdwkday [WeekdayOnOrBefore $dayOfWeek \ |
︙ | ︙ | |||
2903 2904 2905 2906 2907 2908 2909 | variable CachedSystemTimeZone variable TimeZoneBad if { ![catch {getenv TCL_TZ} result] } { set timezone $result } elseif { ![catch {getenv TZ} result] } { set timezone $result | < | | < | | > > > > | | | | < < | 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 | variable CachedSystemTimeZone variable TimeZoneBad if { ![catch {getenv TCL_TZ} result] } { set timezone $result } elseif { ![catch {getenv TZ} result] } { set timezone $result } elseif { [info exists CachedSystemTimeZone] } { set timezone $CachedSystemTimeZone } elseif { $::tcl_platform(platform) eq {windows} } { set timezone [GuessWindowsTimeZone] } elseif { [file exists /etc/localtime] && ![catch {ReadZoneinfoFile \ Tcl/Localtime /etc/localtime}] } { set timezone :Tcl/Localtime } else { set timezone :localtime } set CachedSystemTimeZone $timezone if { ![dict exists $TimeZoneBad $timezone] } { dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}] } if { [dict get $TimeZoneBad $timezone] } { return :localtime } else { return $timezone |
︙ | ︙ | |||
3291 3292 3293 3294 3295 3296 3297 | } else { # We couldn't parse this as a POSIX time zone. Try # again with a time zone file - this time without a colon if { [catch { LoadTimeZoneFile $timezone }] | | | 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 | } else { # We couldn't parse this as a POSIX time zone. Try # again with a time zone file - this time without a colon if { [catch { LoadTimeZoneFile $timezone }] && [catch { ZoneinfoFile $timezone } - opts] } { dict unset opts -errorinfo return -options $opts "time zone $timezone not found" } set TZData($timezone) $TZData(:$timezone) } } |
︙ | ︙ | |||
3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 | # #---------------------------------------------------------------------- proc ::tcl::clock::GuessWindowsTimeZone {} { variable WinZoneInfo variable NoRegistry if { [info exists NoRegistry] } { return :localtime } # Dredge time zone information out of the registry | > | 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 | # #---------------------------------------------------------------------- proc ::tcl::clock::GuessWindowsTimeZone {} { variable WinZoneInfo variable NoRegistry variable TimeZoneBad if { [info exists NoRegistry] } { return :localtime } # Dredge time zone information out of the registry |
︙ | ︙ | |||
3366 3367 3368 3369 3370 3371 3372 | }] } { # Missing values in the Registry - bail out return :localtime } | | > > > | > > > > > > > > > > > | > > | | 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 | }] } { # Missing values in the Registry - bail out return :localtime } # Make up a Posix time zone specifier if we can't find one. # Check here that the tzdata file exists, in case we're running # in an environment (e.g. starpack) where tzdata is incomplete. # (Bug 1237907) if { [dict exists $WinZoneInfo $data] } { set tzname [dict get $WinZoneInfo $data] if { ! [dict exists $TimeZoneBad $tzname] } { dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}] } } else { set tzname {} } if { $tzname eq {} || [dict get $TimeZoneBad $tzname] } { foreach { bias stdBias dstBias stdYear stdMonth stdDayOfWeek stdDayOfMonth stdHour stdMinute stdSecond stdMillisec dstYear dstMonth dstDayOfWeek dstDayOfMonth dstHour dstMinute dstSecond dstMillisec } $data break set stdDelta [expr { $bias + $stdBias }] set dstDelta [expr { $bias + $dstBias }] if { $stdDelta <= 0 } { set stdSignum + set stdDelta [expr { - $stdDelta }] set dispStdSignum - } else { set stdSignum - set dispStdSignum + } set hh [::format %02d [expr { $stdDelta / 3600 }]] set mm [::format %02d [expr { ($stdDelta / 60 ) % 60 }]] set ss [::format %02d [expr { $stdDelta % 60 }]] set tzname {} append tzname < $dispStdSignum $hh $mm > $stdSignum $hh : $mm : $ss if { $stdMonth >= 0 } { if { $dstDelta <= 0 } { set dstSignum + set dstDelta [expr { - $dstDelta }] set dispDstSignum - } else { set dstSignum - set dispDstSignum + } set hh [::format %02d [expr { $dstDelta / 3600 }]] set mm [::format %02d [expr { ($dstDelta / 60 ) % 60 }]] set ss [::format %02d [expr { $dstDelta % 60 }]] append tzname < $dispDstSignum $hh $mm > $dstSignum $hh : $mm : $ss if { $dstYear == 0 } { append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek } else { # I have not been able to find any locale on which # Windows converts time zone on a fixed day of the year, # hence don't know how to interpret the fields. # If someone can inform me, I'd be glad to code it up. |
︙ | ︙ | |||
3485 3486 3487 3488 3489 3490 3491 | #---------------------------------------------------------------------- # # LoadZoneinfoFile -- # # Loads a binary time zone information file in Olson format. # # Parameters: | | < < > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #---------------------------------------------------------------------- # # LoadZoneinfoFile -- # # Loads a binary time zone information file in Olson format. # # Parameters: # fileName - Relative path name of the file to load. # # Results: # Returns an empty result normally; returns an error if no # Olson file was found or the file was malformed in some way. # # Side effects: # TZData(:fileName) contains the time zone data # #---------------------------------------------------------------------- proc ::tcl::clock::LoadZoneinfoFile { fileName } { variable ZoneinfoPaths # Since an unsafe interp uses the [clock] command in the master, # this code is security sensitive. Make sure that the path name # cannot escape the given directory. if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } { return -code error \ -errorcode [list CLOCK badTimeZone $:fileName] \ "time zone \":$fileName\" not valid" } foreach d $ZoneinfoPaths { set fname [file join $d $fileName] if { [file readable $fname] && [file isfile $fname] } { break } unset fname } ReadZoneinfoFile $fileName $fname } #---------------------------------------------------------------------- # # LoadZoneinfoFile -- # # Loads a binary time zone information file in Olson format. # # Parameters: # fileName - Name of the time zone (relative path name of the # file). # fname - Absolute path name of the file. # # Results: # Returns an empty result normally; returns an error if no # Olson file was found or the file was malformed in some way. # # Side effects: # TZData(:fileName) contains the time zone data # #---------------------------------------------------------------------- proc ReadZoneinfoFile {fileName fname} { variable MINWIDE variable TZData if { ![info exists fname] } { return -code error "$fileName not found" } if { [file size $fname] > 262144 } { return -code error "$fileName too big" } |
︙ | ︙ | |||
3603 3604 3605 3606 3607 3608 3609 | set lastTime $t foreach { gmtoff isDst abbrInd } [lindex $types $c] break set abbrev [dict get $abbrevs $abbrInd] lappend r [list $t $gmtoff $isDst $abbrev] } set TZData(:$fileName) $r | | | 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 | set lastTime $t foreach { gmtoff isDst abbrInd } [lindex $types $c] break set abbrev [dict get $abbrevs $abbrInd] lappend r [list $t $gmtoff $isDst $abbrev] } set TZData(:$fileName) $r return } #---------------------------------------------------------------------- # # ParsePosixTimeZone -- # # Parses the TZ environment variable in Posix form |
︙ | ︙ | |||
4407 4408 4409 4410 4411 4412 4413 | proc ::tcl::clock::GetJulianDayFromEraYearMonthDay { date } { variable DaysInPriorMonthsInCommonYear variable DaysInPriorMonthsInLeapYear # Get absolute year number from the civil year | | > > > > > > > > | | | | | 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 | proc ::tcl::clock::GetJulianDayFromEraYearMonthDay { date } { variable DaysInPriorMonthsInCommonYear variable DaysInPriorMonthsInLeapYear # Get absolute year number from the civil year switch -exact -- [dict get $date era] { BCE { set year [expr { 1 - [dict get $date year] }] } CE { set year [dict get $date year] } } # If month is out of range, reduce modulo 12 and adjust year accordingly. set month [expr { [dict get $date month] - 1 }] incr year [expr { $month / 12 }] set month [expr { ( $month % 12 ) + 1 }] dict set date era CE; dict set date year $year; dict set date month $month set ym1 [expr { $year - 1 }] # Try the Gregorian calendar first. dict set date gregorian 1 set jd [expr { 1721425 + [dict get $date dayOfMonth] + ( [IsGregorianLeapYear $date] ? [lindex $DaysInPriorMonthsInLeapYear \ [expr { $month - 1}]] : [lindex $DaysInPriorMonthsInCommonYear \ [expr { $month - 1}]] ) + ( 365 * $ym1 ) + ( $ym1 / 4 ) - ( $ym1 / 100 ) + ( $ym1 / 400 ) }] # If the date is before the Gregorian change, use the Julian calendar. if { $jd < [mc GREGORIAN_CHANGE_DATE] } { dict set date gregorian 0 set jd [expr { 1721423 + [dict get $date dayOfMonth] + ( ( $year % 4 == 0 ) ? [lindex $DaysInPriorMonthsInLeapYear \ [expr { $month - 1}]] : [lindex $DaysInPriorMonthsInCommonYear \ [expr { $month - 1}]] ) + ( 365 * $ym1 ) + ( $ym1 / 4 ) }] } dict set date julianDay $jd return $date |
︙ | ︙ | |||
4479 4480 4481 4482 4483 4484 4485 | # Side effects: # None. # #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearDay { date } { | < < < | | 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 | # Side effects: # None. # #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearDay { date } { # Get absolute year number from the civil year switch -exact -- [dict get $date era] { BCE { set year [expr { 1 - [dict get $date year] }] } CE { set year [dict get $date year] } } |
︙ | ︙ | |||
5024 5025 5026 5027 5028 5029 5030 | #---------------------------------------------------------------------- proc ::tcl::clock::ClearCaches {} { variable LocaleNumeralCache variable McLoaded variable CachedSystemTimeZone | | > | | 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 | #---------------------------------------------------------------------- proc ::tcl::clock::ClearCaches {} { variable LocaleNumeralCache variable McLoaded variable CachedSystemTimeZone variable TimeZoneBad foreach p [info procs [namespace current]::scanproc'*] { rename $p {} } set LocaleNumeralCache {} set McLoaded {} catch {unset CachedSystemTimeZone} set TimeZoneBad {} InitTZData } |
Changes to library/history.tcl.
1 2 3 4 | # history.tcl -- # # Implementation of the history command. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # history.tcl -- # # Implementation of the history command. # # RCS: @(#) $Id: history.tcl,v 1.6.4.1 2005/08/02 18:16:14 dgp Exp $ # # Copyright (c) 1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # |
︙ | ︙ | |||
164 165 166 167 168 169 170 | # Side Effects: # Adds to the history list proc tcl::HistAdd {command {exec {}}} { variable history # Do not add empty commands to the history | | | | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 | # Side Effects: # Adds to the history list proc tcl::HistAdd {command {exec {}}} { variable history # Do not add empty commands to the history if {[string trim $command] eq ""} { return "" } set i [incr history(nextid)] set history($i) $command set j [incr history(oldest)] unset -nocomplain history($j) if {[string match e* $exec]} { return [uplevel #0 $command] } else { return {} } } |
︙ | ︙ | |||
194 195 196 197 198 199 200 | # If no limit is specified, the current limit is returned # # Side Effects: # Updates history(keep) if a limit is specified proc tcl::HistKeep {{limit {}}} { variable history | | | | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | # If no limit is specified, the current limit is returned # # Side Effects: # Updates history(keep) if a limit is specified proc tcl::HistKeep {{limit {}}} { variable history if {$limit eq ""} { return $history(keep) } else { set oldold $history(oldest) set history(oldest) [expr {$history(nextid) - $limit}] for {} {$oldold <= $history(oldest)} {incr oldold} { unset -nocomplain history($oldold) } set history(keep) $limit } } # tcl::HistClear -- # |
︙ | ︙ | |||
242 243 244 245 246 247 248 | # num (optional) the length of the history list to return # # Results: # A formatted history list proc tcl::HistInfo {{num {}}} { variable history | | | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 | # num (optional) the length of the history list to return # # Results: # A formatted history list proc tcl::HistInfo {{num {}}} { variable history if {$num eq ""} { set num [expr {$history(keep) + 1}] } set result {} set newline "" for {set i [expr {$history(nextid) - $num + 1}]} \ {$i <= $history(nextid)} {incr i} { if {![info exists history($i)]} { |
︙ | ︙ | |||
276 277 278 279 280 281 282 | # Those of the command being redone. # # Side Effects: # Replaces the current history list item with the one being redone. proc tcl::HistRedo {{event -1}} { variable history | | | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 | # Those of the command being redone. # # Side Effects: # Replaces the current history list item with the one being redone. proc tcl::HistRedo {{event -1}} { variable history if {$event eq ""} { set event -1 } set i [HistIndex $event] if {$i == $history(nextid)} { return -code error "cannot redo the current event" } set cmd $history($i) |
︙ | ︙ |
Changes to library/http/http.tcl.
1 2 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 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 | # 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.48.2.2 2005/10/08 13:44:37 dgp Exp $ # Rough version history: # 1.0 Old http_get interface # 2.0 http:: namespace and http::geturl # 2.1 Added callbacks to handle arriving data, and timeouts # 2.2 Added ability to fetch into a channel # 2.3 Added SSL support, and ability to post from a channel # This version also cleans up error cases and eliminates the # "ioerror" status in favor of raising an error # 2.4 Added -binary option to http::geturl and charset element # to the state array. package require Tcl 8.4 # keep this in sync with pkgIndex.tcl # and with the install directories in Makefiles package provide http 2.5.1 namespace eval http { variable http array set http { -accept */* -proxyhost {} -proxyport {} -proxyfilter http::ProxyRequired -urlencoding utf-8 } set http(-useragent) "Tcl http client package [package provide http]" proc init {} { # Set up the map for quoting chars # RFC3986 Section 2.3 say percent encode all except: # "... percent-encoded octets in the ranges of ALPHA # (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), # period (%2E), underscore (%5F), or tilde (%7E) should # not be created by URI producers ..." for {set i 0} {$i <= 256} {incr i} { set c [format %c $i] if {![string match {[-._~a-zA-Z0-9]} $c]} { set map($c) %[format %.2x $i] } } # These are handled specially array set map { " " + \n %0d%0a } variable formMap [array get map] } init variable urlTypes array set urlTypes { http {80 ::socket} } |
︙ | ︙ | |||
364 365 366 367 368 369 370 | # Wait for the connection to complete if {$state(-timeout) > 0} { fileevent $s writable [list http::Connect $token] http::wait $token | | | | 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 | # Wait for the connection to complete if {$state(-timeout) > 0} { fileevent $s writable [list http::Connect $token] http::wait $token if {$state(status) eq "error"} { # something went wrong while trying to establish the connection # Clean up after events and such, but DON'T call the command # callback (if available) because we're going to throw an # exception from here instead. set err [lindex $state(error) 0] cleanup $token return -code error $err } elseif {$state(status) ne "connect"} { # Likely to be connection timeout return $token } set state(status) "" } # Send data in cr-lf format, but accept any line terminators |
︙ | ︙ | |||
422 423 424 425 426 427 428 | } else { puts $s "Host: $host:$port" } puts $s "User-Agent: $http(-useragent)" foreach {key value} $state(-headers) { set value [string map [list \n "" \r ""] $value] set key [string trim $key] | | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 | } else { puts $s "Host: $host:$port" } puts $s "User-Agent: $http(-useragent)" foreach {key value} $state(-headers) { set value [string map [list \n "" \r ""] $value] set key [string trim $key] if {$key eq "Content-Length"} { set contDone 1 set state(querylength) $value } if {[string length $key]} { puts $s "$key: $value" } } |
︙ | ︙ | |||
478 479 480 481 482 483 484 | if {! [info exists state(-command)]} { # geturl does EVERYTHING asynchronously, so if the user # calls it synchronously, we just do a wait here. wait $token | | | | 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 | if {! [info exists state(-command)]} { # geturl does EVERYTHING asynchronously, so if the user # calls it synchronously, we just do a wait here. wait $token if {$state(status) eq "error"} { # Something went wrong, so throw the exception, and the # enclosing catch will do cleanup. return -code error [lindex $state(error) 0] } } } err]} { # The socket probably was never connected, # or the connection dropped later. # Clean up after events and such, but DON'T call the command callback # (if available) because we're going to throw an exception from here # instead. # if state(status) is error, it means someone's already called Finish # to do the above-described clean up. if {$state(status) eq "error"} { Finish $token $err 1 } cleanup $token return -code error $err } return $token |
︙ | ︙ | |||
674 675 676 677 678 679 680 | upvar 0 $token state set s $state(sock) if {[eof $s]} { Eof $token return } | | | 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 | upvar 0 $token state set s $state(sock) if {[eof $s]} { Eof $token return } if {$state(state) eq "header"} { if {[catch {gets $s line} n]} { Finish $token $n } elseif {$n == 0} { variable encodings set state(state) body if {$state(-binary) || ![string match -nocase text* $state(type)] || [string match *gzip* $state(coding)] |
︙ | ︙ | |||
812 813 814 815 816 817 818 | # # Side Effects # Clean up the socket proc http::Eof {token} { variable $token upvar 0 $token state | | | 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 | # # Side Effects # Clean up the socket proc http::Eof {token} { variable $token upvar 0 $token state if {$state(state) eq "header"} { # Premature eof set state(status) eof } else { set state(status) ok } set state(state) eof Finish $token |
︙ | ︙ | |||
862 863 864 865 866 867 868 | # TODO proc http::formatQuery {args} { set result "" set sep "" foreach i $args { append result $sep [mapReply $i] | | | 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 | # TODO proc http::formatQuery {args} { set result "" set sep "" foreach i $args { append result $sep [mapReply $i] if {$sep eq "="} { set sep & } else { set sep = } } return $result } |
︙ | ︙ | |||
884 885 886 887 888 889 890 | # # Results: # The encoded string proc http::mapReply {string} { variable http variable formMap | < < > | < < > | | > > > > > | | 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 | # # Results: # The encoded string proc http::mapReply {string} { variable http variable formMap # The spec says: "non-alphanumeric characters are replaced by '%HH'" # Use a pre-computed map and [string map] to do the conversion # (much faster than [regsub]/[subst]). [Bug 1020491] if {$http(-urlencoding) ne ""} { set string [encoding convertto $http(-urlencoding) $string] return [string map $formMap $string] } set converted [string map $formMap $string] if {[string match "*\[\u0100-\uffff\]*" $converted]} { regexp {[\u0100-\uffff]} $converted badChar # Return this error message for maximum compatability... :^/ return -code error \ "can't read \"formMap($badChar)\": no such element in array" } return $converted } # http::ProxyRequired -- # Default proxy filter. # # Arguments: # host The destination host |
︙ | ︙ |
Changes to library/http/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. | | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.4]} {return} package ifneeded http 2.5.1 [list tclPkgSetup $dir http 2.5.1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister}}}] |
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.69.2.7 2005/10/08 13:44:37 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 Scriptics Corporation. # Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution |
︙ | ︙ | |||
44 45 46 47 48 49 50 | set auto_path $env(TCLLIBPATH) } else { set auto_path "" } } namespace eval tcl { variable Dir | < | | | < | | | | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | < | > > > | > | > > > > > | > | > > > > > > > > > > > > > > > > > > > > | | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 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 | set auto_path $env(TCLLIBPATH) } else { set auto_path "" } } namespace eval tcl { variable Dir foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { if {$Dir ni $::auto_path} { lappend ::auto_path $Dir } } set Dir [file join [file dirname [file dirname \ [info nameofexecutable]]] lib] if {$Dir ni $::auto_path} { lappend ::auto_path $Dir } catch { foreach Dir $::tcl_pkgPath { if {$Dir ni $::auto_path} { lappend ::auto_path $Dir } } } variable Path [unsupported::EncodingDirs] set Dir [file join $::tcl_library encoding] if {$Dir ni $Path} { lappend Path $Dir unsupported::EncodingDirs $Path } # Set up the 'chan' ensemble (TIP #208). namespace eval chan { # TIP #219. Added methods: create, postevent. namespace ensemble create -command ::chan -map { blocked ::fblocked close ::close configure ::fconfigure copy ::fcopy create ::tcl::chan::rCreate eof ::eof event ::fileevent flush ::flush gets ::gets names {::file channels} postevent ::tcl::chan::rPostevent puts ::puts read ::read seek ::seek tell ::tell truncate ::tcl::chan::Truncate } } # TIP #255 min and max functions namespace eval mathfunc { proc min {args} { if {[llength $args] == 0} { return -code error \ "too few arguments to math function \"min\"" } set val Inf foreach arg $args { # This will handle forcing the numeric value without # ruining the internal type of a numeric object if {[catch {expr {double($arg)}} err]} { return -code error $err } if {$arg < $val} { set val $arg } } return $val } proc max {args} { if {[llength $args] == 0} { return -code error \ "too few arguments to math function \"max\"" } set val -Inf foreach arg $args { # This will handle forcing the numeric value without # ruining the internal type of a numeric object if {[catch {expr {double($arg)}} err]} { return -code error $err } if {$arg > $val} { set val $arg } } return $val } } } # Windows specific end of initialization if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { namespace eval tcl { proc EnvTraceProc {lo n1 n2 op} { set x $::env($n2) set ::env($lo) $x set ::env([string toupper $lo]) $x } proc InitWinEnv {} { global env tcl_platform foreach p [array names env] { set u [string toupper $p] if {$u ne $p} { switch -- $u { COMSPEC - PATH { if {![info exists env($u)]} { set env($u) $env($p) } trace add variable env($p) write \ [namespace code [list EnvTraceProc $p]] trace add variable env($u) write \ [namespace code [list EnvTraceProc $p]] } } } } if {![info exists env(COMSPEC)]} { if {$tcl_platform(os) eq "Windows NT"} { set env(COMSPEC) cmd.exe } else { set env(COMSPEC) command.com } } } InitWinEnv } } # Setup the unknown package handler if {[interp issafe]} { package unknown ::tclPkgUnknown } else { # Set up search for Tcl Modules (TIP #189). # and setup platform specific unknown package handlers if {$::tcl_platform(os) eq "Darwin" && $::tcl_platform(platform) eq "unix"} { package unknown {::tcl::tm::UnknownHandler \ {::tcl::MacOSXPkgUnknown ::tclPkgUnknown}} } else { package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} } # Set up the 'clock' ensemble namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library] proc clock args { namespace eval ::tcl::clock [list namespace ensemble create -command \ [uplevel 1 [list namespace origin [lindex [info level 0] 0]]] \ -subcommands { add clicks format microseconds milliseconds scan seconds }] # Auto-loading stubs for 'clock.tcl' foreach cmd {add format scan} { proc ::tcl::clock::$cmd args { variable TclLibDir source -encoding utf-8 [file join $TclLibDir clock.tcl] return [uplevel 1 [info level 0]] } } return [uplevel 1 [info level 0]] } } # Conditionalize for presence of exec. if {[namespace which -command exec] eq ""} { # Some machines do not have exec. Also, on all # platforms, safe interpreters do not have exec. set auto_noexec 1 } # Define a log command (which can be overwitten to log errors # differently, specially when stderr is not available) if {[namespace which -command tclLog] eq ""} { proc tclLog {string} { catch {puts stderr $string} } } # unknown -- # This procedure is called when a Tcl command is invoked that doesn't |
︙ | ︙ | |||
177 178 179 180 181 182 183 | dict unset opts -errorinfo dict incr opts -level return -options $opts $result } catch {set savedErrorInfo $::errorInfo} catch {set savedErrorCode $::errorCode} | | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 | dict unset opts -errorinfo dict incr opts -level return -options $opts $result } catch {set savedErrorInfo $::errorInfo} catch {set savedErrorCode $::errorCode} set name $cmd if {![info exists auto_noload]} { # # Make sure we're not trying to load the same proc twice. # if {[info exists UnknownPending($name)]} { return -code error "self-referential recursion\ in \"unknown\" for command \"$name\""; |
︙ | ︙ | |||
211 212 213 214 215 216 217 | # Compute stack trace contribution from the [uplevel]. # Note the dependence on how Tcl_AddErrorInfo, etc. # construct the stack trace. # set errorInfo [dict get $opts -errorinfo] set errorCode [dict get $opts -errorcode] set cinfo $args | | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 | # Compute stack trace contribution from the [uplevel]. # Note the dependence on how Tcl_AddErrorInfo, etc. # construct the stack trace. # set errorInfo [dict get $opts -errorinfo] set errorCode [dict get $opts -errorcode] set cinfo $args if {[string bytelength $cinfo] > 150} { set cinfo [string range $cinfo 0 150] while {[string bytelength $cinfo] > 150} { set cinfo [string range $cinfo 0 end-1] } append cinfo ... } append cinfo "\"\n (\"uplevel\" body line 1)" append cinfo "\n invoked from within" |
︙ | ︙ | |||
255 256 257 258 259 260 261 | if {$errorInfo ne "$einfo$expect"} { error "Tcl bug: unexpected stack trace in \"unknown\"" {} \ [list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo] } return -code error -errorcode $errorCode \ -errorinfo $einfo $msg } else { | > | | | | > | > > > | | | | > > > | > > > > > > > > | | > > > < < < < | < | | 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 | if {$errorInfo ne "$einfo$expect"} { error "Tcl bug: unexpected stack trace in \"unknown\"" {} \ [list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo] } return -code error -errorcode $errorCode \ -errorinfo $einfo $msg } else { dict incr opts -level return -options $opts $msg } } } if {([info level] == 1) && ([info script] eq "") \ && [info exists tcl_interactive] && $tcl_interactive} { if {![info exists auto_noexec]} { set new [auto_execok $name] if {$new ne ""} { set redir "" if {[namespace which -command console] eq ""} { set redir ">&@stdout <@stdin" } uplevel 1 [list ::catch \ [concat exec $redir $new [lrange $args 1 end]] \ ::tcl::UnknownResult ::tcl::UnknownOptions] dict incr ::tcl::UnknownOptions -level return -options $::tcl::UnknownOptions $::tcl::UnknownResult } } if {$name eq "!!"} { set newcmd [history event] } elseif {[regexp {^!(.+)$} $name -> event]} { set newcmd [history event $event] } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { set newcmd [history event -1] catch {regsub -all -- $old $newcmd $new newcmd} } if {[info exists newcmd]} { tclLog $newcmd history change $newcmd 0 uplevel 1 [list ::catch $newcmd \ ::tcl::UnknownResult ::tcl::UnknownOptions] dict incr ::tcl::UnknownOptions -level return -options $::tcl::UnknownOptions $::tcl::UnknownResult } set ret [catch {set candidates [info commands $name*]} msg] if {$name eq "::"} { set name "" } if {$ret != 0} { dict append opts -errorinfo \ "\n (expanding command prefix \"$name\" in unknown)" return -options $opts $msg } # Handle empty $name separately due to strangeness in [string first] if {$name eq ""} { if {[llength $candidates] != 1} { return -code error "empty command name \"\"" } # It's not really possible to reach here. return [uplevel 1 [lreplace $args 0 0 [lindex $candidates 0]]] } # Filter out bogus matches when $name contained # a glob-special char [Bug 946952] set cmds [list] foreach x $candidates { if {[string first $name $x] == 0} { lappend cmds $x } } if {[llength $cmds] == 1} { uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ ::tcl::UnknownResult ::tcl::UnknownOptions] dict incr ::tcl::UnknownOptions -level return -options $::tcl::UnknownOptions $::tcl::UnknownResult } if {[llength $cmds]} { return -code error "ambiguous command name \"$name\": [lsort $cmds]" } } return -code error "invalid command name \"$name\"" } # auto_load -- # Checks a collection of library directories to see if a procedure # is defined in one of them. If so, it sources the appropriate # library file to create the procedure. Returns 1 if it successfully # loaded the procedure, 0 otherwise. # # Arguments: # cmd - Name of the command to find and load. # namespace (optional) The namespace where the command is being used - must be # a canonical namespace as returned [namespace current] # for instance. If not given, namespace current is used. proc auto_load {cmd {namespace {}}} { global auto_index auto_path if {$namespace eq ""} { set namespace [uplevel 1 [list ::namespace current]] } set nameList [auto_qualify $cmd $namespace] # workaround non canonical auto_index entries that might be around # from older auto_mkindex versions lappend nameList $cmd foreach name $nameList { |
︙ | ︙ | |||
386 387 388 389 390 391 392 | # Arguments: # None. proc auto_load_index {} { variable ::tcl::auto_oldpath global auto_index auto_path | | < < | | | | | 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 | # Arguments: # None. proc auto_load_index {} { variable ::tcl::auto_oldpath global auto_index auto_path if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} { return 0 } set auto_oldpath $auto_path # Check if we are a safe interpreter. In that case, we support only # newer format tclIndex files. set issafe [interp issafe] for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} { set dir [lindex $auto_path $i] set f "" if {$issafe} { catch {source [file join $dir tclIndex]} } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { continue } else { set error [catch { set id [gets $f] if {$id eq "# Tcl autoload index file, version 2.0"} { eval [read $f] } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"]} { while {[gets $f line] >= 0} { if {([string index $line 0] eq "#") \ || ([llength $line] != 2)} { continue } set name [lindex $line 0] set auto_index($name) \ "source [file join $dir [lindex $line 1]]" } } else { error "[file join $dir tclIndex] isn't a proper Tcl index file" } } msg opts] if {$f ne ""} { close $f } if {$error} { return -options $opts $msg } } } |
︙ | ︙ | |||
462 463 464 465 466 467 468 | # Ignore namespace if the name starts with :: # Handle special case of only leading :: # Before each return case we give an example of which category it is # with the following form : # ( inputCmd, inputNameSpace) -> output | | | | | | 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 | # Ignore namespace if the name starts with :: # Handle special case of only leading :: # Before each return case we give an example of which category it is # with the following form : # ( inputCmd, inputNameSpace) -> output if {[string match ::* $cmd]} { if {$n > 1} { # ( ::foo::bar , * ) -> ::foo::bar return [list $cmd] } else { # ( ::global , * ) -> global return [list [string range $cmd 2 end]] } } # Potentially returning 2 elements to try : # (if the current namespace is not the global one) if {$n == 0} { if {$namespace eq "::"} { # ( nocolons , :: ) -> nocolons return [list $cmd] } else { # ( nocolons , ::sub ) -> ::sub::nocolons nocolons return [list ${namespace}::$cmd $cmd] } } elseif {$namespace eq "::"} { # ( foo::bar , :: ) -> ::foo::bar return [list ::$cmd] } else { # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar return [list ${namespace}::$cmd ::$cmd] } } |
︙ | ︙ | |||
538 539 540 541 542 543 544 | # Windows search path, or "" otherwise. Builds an associative # array auto_execs that caches information about previous checks, # for speed. # # Arguments: # name - Name of a command. | | | | | 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 | # Windows search path, or "" otherwise. Builds an associative # array auto_execs that caches information about previous checks, # for speed. # # Arguments: # name - Name of a command. if {$tcl_platform(platform) eq "windows"} { # Windows version. # # Note that info executable doesn't work under Windows, so we have to # look for files with .exe, .com, or .bat extensions. Also, the path # may be in the Path or PATH environment variables, and path # components are separated with semicolons, not colons as under Unix. # proc auto_execok name { global auto_execs env tcl_platform if {[info exists auto_execs($name)]} { return $auto_execs($name) } set auto_execs($name) "" set shellBuiltins [list cls copy date del erase dir echo mkdir \ md rename ren rmdir rd time type ver vol] if {$tcl_platform(os) eq "Windows NT"} { # NT includes the 'start' built-in lappend shellBuiltins "start" } if {[info exists env(PATHEXT)]} { # Add an initial ; to have the {} extension check first. set execExtensions [split ";$env(PATHEXT)" ";"] } else { set execExtensions [list {} .com .exe .bat] } if {$name in $shellBuiltins} { # When this is command.com for some reason on Win2K, Tcl won't # exec it unless the case is right, which this corrects. COMSPEC # may not point to a real file, so do the check. set cmd $env(COMSPEC) if {[file exists $cmd]} { set cmd [file attributes $cmd -shortname] } |
︙ | ︙ | |||
593 594 595 596 597 598 599 | } set path "[file dirname [info nameof]];.;" if {[info exists env(WINDIR)]} { set windir $env(WINDIR) } if {[info exists windir]} { | | | | 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 | } set path "[file dirname [info nameof]];.;" if {[info exists env(WINDIR)]} { set windir $env(WINDIR) } if {[info exists windir]} { if {$tcl_platform(os) eq "Windows NT"} { append path "$windir/system32;" } append path "$windir/system;$windir;" } foreach var {PATH Path path} { if {[info exists env($var)]} { append path ";$env($var)" } } foreach dir [split $path {;}] { # Skip already checked directories if {[info exists checked($dir)] || ($dir eq {})} { continue } set checked($dir) {} foreach ext $execExtensions { set file [file join $dir ${name}${ext}] if {[file exists $file] && ![file isdirectory $file]} { return [set auto_execs($name) [list $file]] } } |
︙ | ︙ | |||
636 637 638 639 640 641 642 | if {[llength [file split $name]] != 1} { if {[file executable $name] && ![file isdirectory $name]} { set auto_execs($name) [list $name] } return $auto_execs($name) } foreach dir [split $env(PATH) :] { | | | 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 | if {[llength [file split $name]] != 1} { if {[file executable $name] && ![file isdirectory $name]} { set auto_execs($name) [list $name] } return $auto_execs($name) } foreach dir [split $env(PATH) :] { if {$dir eq ""} { set dir . } set file [file join $dir $name] if {[file executable $file] && ![file isdirectory $file]} { set auto_execs($name) [list $file] return $auto_execs($name) } |
︙ | ︙ | |||
668 669 670 671 672 673 674 | # 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] | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | # action - "renaming" or "copying" # src - source directory # dest - destination directory proc tcl::CopyDirectory {action src dest} { set nsrc [file normalize $src] set ndest [file normalize $dest] if {$action eq "renaming"} { # Can't rename volumes. We could give a more precise # error message here, but that would break the test suite. if {$nsrc in [file volumes]} { return -code error "error $action \"$src\" to\ \"$dest\": trying to rename a volume or move a directory\ into itself" } } if {[file exists $dest]} { if {$nsrc eq $ndest} { return -code error "error $action \"$src\" to\ \"$dest\": trying to rename a volume or move a directory\ into itself" } if {$action eq "copying"} { # We used to throw an error here, but, looking more closely # at the core copy code in tclFCmd.c, if the destination # exists, then we should only call this function if -force # is true, which means we just want to over-write. So, # the following code is now commented out. # # return -code error "error $action \"$src\" to\ # \"$dest\": file already exists" } else { # Depending on the platform, and on the current # working directory, the directories '.', '..' # can be returned in various combinations. Anyway, # if any other file is returned, we must signal an error. set existing [glob -nocomplain -directory $dest * .*] lappend existing {expand}[glob -nocomplain -directory $dest \ -type hidden * .*] foreach s $existing { if {([file tail $s] ne ".") && ([file tail $s] ne "..")} { return -code error "error $action \"$src\" to\ \"$dest\": file already exists" } } } } else { if {[string first $nsrc $ndest] != -1} { set srclen [expr {[llength [file split $nsrc]] -1}] set ndest [lindex [file split $ndest] $srclen] if {$ndest eq [file tail $nsrc]} { return -code error "error $action \"$src\" to\ \"$dest\": trying to rename a volume or move a directory\ into itself" } } file mkdir $dest } # Have to be careful to capture both visible and hidden files. # We will also be more generous to the file system and not # assume the hidden and non-hidden lists are non-overlapping. # # On Unix 'hidden' files begin with '.'. On other platforms # or filesystems hidden files may have other interpretations. set filelist [concat [glob -nocomplain -directory $src *] \ [glob -nocomplain -directory $src -types hidden *]] foreach s [lsort -unique $filelist] { if {([file tail $s] ne ".") && ([file tail $s] ne "..")} { file copy -force $s [file join $dest [file tail $s]] } } return } |
Deleted library/ldAout.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted library/msgs/af_ZA.msg.
|
| < < < < < < |
Added library/msgs/af_za.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset af_ZA DATE_FORMAT "%d %B %Y" ::msgcat::mcset af_ZA TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset af_ZA DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" } |
Deleted library/msgs/ar_IN.msg.
|
| < < < < < < |
Deleted library/msgs/ar_JO.msg.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted library/msgs/ar_LB.msg.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted library/msgs/ar_SY.msg.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added library/msgs/ar_in.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ar_IN DATE_FORMAT "%A %d %B %Y" ::msgcat::mcset ar_IN TIME_FORMAT_12 "%I:%M:%S %z" ::msgcat::mcset ar_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S %z %z" } |
Added library/msgs/ar_jo.msg.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ar_JO DAYS_OF_WEEK_ABBREV [list \ "\u0627\u0644\u0623\u062d\u062f"\ "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\ "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\ "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\ "\u0627\u0644\u062e\u0645\u064a\u0633"\ "\u0627\u0644\u062c\u0645\u0639\u0629"\ "\u0627\u0644\u0633\u0628\u062a"] ::msgcat::mcset ar_JO MONTHS_ABBREV [list \ "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ "\u0634\u0628\u0627\u0637"\ "\u0622\u0630\u0627\u0631"\ "\u0646\u064a\u0633\u0627\u0646"\ "\u0646\u0648\u0627\u0631"\ "\u062d\u0632\u064a\u0631\u0627\u0646"\ "\u062a\u0645\u0648\u0632"\ "\u0622\u0628"\ "\u0623\u064a\u0644\u0648\u0644"\ "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ ""] ::msgcat::mcset ar_JO MONTHS_FULL [list \ "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ "\u0634\u0628\u0627\u0637"\ "\u0622\u0630\u0627\u0631"\ "\u0646\u064a\u0633\u0627\u0646"\ "\u0646\u0648\u0627\u0631"\ "\u062d\u0632\u064a\u0631\u0627\u0646"\ "\u062a\u0645\u0648\u0632"\ "\u0622\u0628"\ "\u0623\u064a\u0644\u0648\u0644"\ "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ ""] } |
Added library/msgs/ar_lb.msg.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ar_LB DAYS_OF_WEEK_ABBREV [list \ "\u0627\u0644\u0623\u062d\u062f"\ "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\ "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\ "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\ "\u0627\u0644\u062e\u0645\u064a\u0633"\ "\u0627\u0644\u062c\u0645\u0639\u0629"\ "\u0627\u0644\u0633\u0628\u062a"] ::msgcat::mcset ar_LB MONTHS_ABBREV [list \ "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ "\u0634\u0628\u0627\u0637"\ "\u0622\u0630\u0627\u0631"\ "\u0646\u064a\u0633\u0627\u0646"\ "\u0646\u0648\u0627\u0631"\ "\u062d\u0632\u064a\u0631\u0627\u0646"\ "\u062a\u0645\u0648\u0632"\ "\u0622\u0628"\ "\u0623\u064a\u0644\u0648\u0644"\ "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ ""] ::msgcat::mcset ar_LB MONTHS_FULL [list \ "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ "\u0634\u0628\u0627\u0637"\ "\u0622\u0630\u0627\u0631"\ "\u0646\u064a\u0633\u0627\u0646"\ "\u0646\u0648\u0627\u0631"\ "\u062d\u0632\u064a\u0631\u0627\u0646"\ "\u062a\u0645\u0648\u0632"\ "\u0622\u0628"\ "\u0623\u064a\u0644\u0648\u0644"\ "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ ""] } |
Added library/msgs/ar_sy.msg.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ar_SY DAYS_OF_WEEK_ABBREV [list \ "\u0627\u0644\u0623\u062d\u062f"\ "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\ "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\ "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\ "\u0627\u0644\u062e\u0645\u064a\u0633"\ "\u0627\u0644\u062c\u0645\u0639\u0629"\ "\u0627\u0644\u0633\u0628\u062a"] ::msgcat::mcset ar_SY MONTHS_ABBREV [list \ "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ "\u0634\u0628\u0627\u0637"\ "\u0622\u0630\u0627\u0631"\ "\u0646\u064a\u0633\u0627\u0646"\ "\u0646\u0648\u0627\u0631"\ "\u062d\u0632\u064a\u0631\u0627\u0646"\ "\u062a\u0645\u0648\u0632"\ "\u0622\u0628"\ "\u0623\u064a\u0644\u0648\u0644"\ "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ ""] ::msgcat::mcset ar_SY MONTHS_FULL [list \ "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ "\u0634\u0628\u0627\u0637"\ "\u0622\u0630\u0627\u0631"\ "\u0646\u064a\u0633\u0627\u0646"\ "\u0646\u0648\u0627\u0631\u0627\u0646"\ "\u062d\u0632\u064a\u0631"\ "\u062a\u0645\u0648\u0632"\ "\u0622\u0628"\ "\u0623\u064a\u0644\u0648\u0644"\ "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\ "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\ "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\ ""] } |
Deleted library/msgs/bn_IN.msg.
|
| < < < < < < |
Added library/msgs/bn_in.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset bn_IN DATE_FORMAT "%A %d %b %Y" ::msgcat::mcset bn_IN TIME_FORMAT_12 "%I:%M:%S %z" ::msgcat::mcset bn_IN DATE_TIME_FORMAT "%A %d %b %Y %I:%M:%S %z %z" } |
Deleted library/msgs/de_AT.msg.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted library/msgs/de_BE.msg.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added library/msgs/de_at.msg.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset de_AT MONTHS_ABBREV [list \ "J\u00e4n"\ "Feb"\ "M\u00e4r"\ "Apr"\ "Mai"\ "Jun"\ "Jul"\ "Aug"\ "Sep"\ "Okt"\ "Nov"\ "Dez"\ ""] ::msgcat::mcset de_AT MONTHS_FULL [list \ "J\u00e4nner"\ "Februar"\ "M\u00e4rz"\ "April"\ "Mai"\ "Juni"\ "Juli"\ "August"\ "September"\ "Oktober"\ "November"\ "Dezember"\ ""] ::msgcat::mcset de_AT DATE_FORMAT "%Y-%m-%d" ::msgcat::mcset de_AT TIME_FORMAT "%T" ::msgcat::mcset de_AT TIME_FORMAT_12 "%T" ::msgcat::mcset de_AT DATE_TIME_FORMAT "%a %d %b %Y %T %z" } |
Added library/msgs/de_be.msg.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset de_BE DAYS_OF_WEEK_ABBREV [list \ "Son"\ "Mon"\ "Die"\ "Mit"\ "Don"\ "Fre"\ "Sam"] ::msgcat::mcset de_BE DAYS_OF_WEEK_FULL [list \ "Sonntag"\ "Montag"\ "Dienstag"\ "Mittwoch"\ "Donnerstag"\ "Freitag"\ "Samstag"] ::msgcat::mcset de_BE MONTHS_ABBREV [list \ "Jan"\ "Feb"\ "M\u00e4r"\ "Apr"\ "Mai"\ "Jun"\ "Jul"\ "Aug"\ "Sep"\ "Okt"\ "Nov"\ "Dez"\ ""] ::msgcat::mcset de_BE MONTHS_FULL [list \ "Januar"\ "Februar"\ "M\u00e4rz"\ "April"\ "Mai"\ "Juni"\ "Juli"\ "August"\ "September"\ "Oktober"\ "November"\ "Dezember"\ ""] ::msgcat::mcset de_BE AM "vorm" ::msgcat::mcset de_BE PM "nachm" ::msgcat::mcset de_BE DATE_FORMAT "%Y-%m-%d" ::msgcat::mcset de_BE TIME_FORMAT "%T" ::msgcat::mcset de_BE TIME_FORMAT_12 "%T" ::msgcat::mcset de_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z" } |
Deleted library/msgs/en_AU.msg.
|
| < < < < < < < |
Deleted library/msgs/en_BE.msg.
|
| < < < < < < < |
Deleted library/msgs/en_BW.msg.
|
| < < < < < < |
Deleted library/msgs/en_CA.msg.
|
| < < < < < < < |
Deleted library/msgs/en_GB.msg.
|
| < < < < < < < |
Deleted library/msgs/en_HK.msg.
|
| < < < < < < < < |
Deleted library/msgs/en_IE.msg.
|
| < < < < < < < |
Deleted library/msgs/en_IN.msg.
|
| < < < < < < < < |
Deleted library/msgs/en_NZ.msg.
|
| < < < < < < < |
Deleted library/msgs/en_PH.msg.
|
| < < < < < < < < |
Deleted library/msgs/en_SG.msg.
|
| < < < < < < |
Deleted library/msgs/en_ZA.msg.
|
| < < < < < < |
Deleted library/msgs/en_ZW.msg.
|
| < < < < < < |
Added library/msgs/en_au.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset en_AU DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset en_AU TIME_FORMAT "%H:%M:%S" ::msgcat::mcset en_AU TIME_FORMAT_12 "%I:%M:%S %P %z" ::msgcat::mcset en_AU DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z" } |
Added library/msgs/en_be.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset en_BE DATE_FORMAT "%d %b %Y" ::msgcat::mcset en_BE TIME_FORMAT "%k:%M:%S" ::msgcat::mcset en_BE TIME_FORMAT_12 "%k h %M min %S s %z" ::msgcat::mcset en_BE DATE_TIME_FORMAT "%d %b %Y %k:%M:%S %z" } |
Added library/msgs/en_bw.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset en_BW DATE_FORMAT "%d %B %Y" ::msgcat::mcset en_BW TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset en_BW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" } |
Added library/msgs/en_ca.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset en_CA DATE_FORMAT "%d/%m/%y" ::msgcat::mcset en_CA TIME_FORMAT "%r" ::msgcat::mcset en_CA TIME_FORMAT_12 "%I:%M:%S %p" ::msgcat::mcset en_CA DATE_TIME_FORMAT "%a %d %b %Y %r %z" } |
Added library/msgs/en_gb.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset en_GB DATE_FORMAT "%d/%m/%y" ::msgcat::mcset en_GB TIME_FORMAT "%T" ::msgcat::mcset en_GB TIME_FORMAT_12 "%T" ::msgcat::mcset en_GB DATE_TIME_FORMAT "%a %d %b %Y %T %z" } |
Added library/msgs/en_hk.msg.
> > > > > > > > | 1 2 3 4 5 6 7 8 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset en_HK AM "AM" ::msgcat::mcset en_HK PM "PM" ::msgcat::mcset en_HK DATE_FORMAT "%B %e, %Y" ::msgcat::mcset en_HK TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset en_HK DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z" } |
Added library/msgs/en_ie.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset en_IE DATE_FORMAT "%d/%m/%y" ::msgcat::mcset en_IE TIME_FORMAT "%T" ::msgcat::mcset en_IE TIME_FORMAT_12 "%T" ::msgcat::mcset en_IE DATE_TIME_FORMAT "%a %d %b %Y %T %z" } |
Added library/msgs/en_in.msg.
> > > > > > > > | 1 2 3 4 5 6 7 8 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset en_IN AM "AM" ::msgcat::mcset en_IN PM "PM" ::msgcat::mcset en_IN DATE_FORMAT "%d %B %Y" ::msgcat::mcset en_IN TIME_FORMAT "%H:%M:%S" ::msgcat::mcset en_IN DATE_TIME_FORMAT "%d %B %Y %H:%M:%S %z" } |
Added library/msgs/en_nz.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset en_NZ DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset en_NZ TIME_FORMAT "%H:%M:%S" ::msgcat::mcset en_NZ TIME_FORMAT_12 "%I:%M:%S %P %z" ::msgcat::mcset en_NZ DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z" } |
Added library/msgs/en_ph.msg.
> > > > > > > > | 1 2 3 4 5 6 7 8 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset en_PH AM "AM" ::msgcat::mcset en_PH PM "PM" ::msgcat::mcset en_PH DATE_FORMAT "%B %e, %Y" ::msgcat::mcset en_PH TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset en_PH DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z" } |
Added library/msgs/en_sg.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset en_SG DATE_FORMAT "%d %b %Y" ::msgcat::mcset en_SG TIME_FORMAT_12 "%P %I:%M:%S" ::msgcat::mcset en_SG DATE_TIME_FORMAT "%d %b %Y %P %I:%M:%S %z" } |
Added library/msgs/en_za.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset en_ZA DATE_FORMAT "%Y/%m/%d" ::msgcat::mcset en_ZA TIME_FORMAT_12 "%I:%M:%S" ::msgcat::mcset en_ZA DATE_TIME_FORMAT "%Y/%m/%d %I:%M:%S %z" } |
Added library/msgs/en_zw.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset en_ZW DATE_FORMAT "%d %B %Y" ::msgcat::mcset en_ZW TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset en_ZW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" } |
Deleted library/msgs/es_AR.msg.
|
| < < < < < < |
Deleted library/msgs/es_BO.msg.
|
| < < < < < < |
Deleted library/msgs/es_CL.msg.
|
| < < < < < < |
Deleted library/msgs/es_CO.msg.
|
| < < < < < < |
Deleted library/msgs/es_CR.msg.
|
| < < < < < < |
Deleted library/msgs/es_DO.msg.
|
| < < < < < < |
Deleted library/msgs/es_EC.msg.
|
| < < < < < < |
Deleted library/msgs/es_GT.msg.
|
| < < < < < < |
Deleted library/msgs/es_HN.msg.
|
| < < < < < < |
Deleted library/msgs/es_MX.msg.
|
| < < < < < < |
Deleted library/msgs/es_NI.msg.
|
| < < < < < < |
Deleted library/msgs/es_PA.msg.
|
| < < < < < < |
Deleted library/msgs/es_PE.msg.
|
| < < < < < < |
Deleted library/msgs/es_PR.msg.
|
| < < < < < < |
Deleted library/msgs/es_PY.msg.
|
| < < < < < < |
Deleted library/msgs/es_SV.msg.
|
| < < < < < < |
Deleted library/msgs/es_UY.msg.
|
| < < < < < < |
Deleted library/msgs/es_VE.msg.
|
| < < < < < < |
Added library/msgs/es_ar.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_AR DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_AR TIME_FORMAT "%H:%M:%S" ::msgcat::mcset es_AR DATE_TIME_FORMAT "%d/%m/%Y %H:%M:%S %z" } |
Added library/msgs/es_bo.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_BO DATE_FORMAT "%d-%m-%Y" ::msgcat::mcset es_BO TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_BO DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z" } |
Added library/msgs/es_cl.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_CL DATE_FORMAT "%d-%m-%Y" ::msgcat::mcset es_CL TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_CL DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z" } |
Added library/msgs/es_co.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_CO DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset es_CO TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_CO DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z" } |
Added library/msgs/es_cr.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_CR DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_CR TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_CR DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" } |
Added library/msgs/es_do.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_DO DATE_FORMAT "%m/%d/%Y" ::msgcat::mcset es_DO TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_DO DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z" } |
Added library/msgs/es_ec.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_EC DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_EC TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_EC DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" } |
Added library/msgs/es_gt.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_GT DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset es_GT TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_GT DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z" } |
Added library/msgs/es_hn.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_HN DATE_FORMAT "%m-%d-%Y" ::msgcat::mcset es_HN TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_HN DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" } |
Added library/msgs/es_mx.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_MX DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset es_MX TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_MX DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z" } |
Added library/msgs/es_ni.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_NI DATE_FORMAT "%m-%d-%Y" ::msgcat::mcset es_NI TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_NI DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" } |
Added library/msgs/es_pa.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_PA DATE_FORMAT "%m/%d/%Y" ::msgcat::mcset es_PA TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_PA DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z" } |
Added library/msgs/es_pe.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_PE DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_PE TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_PE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" } |
Added library/msgs/es_pr.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_PR DATE_FORMAT "%m-%d-%Y" ::msgcat::mcset es_PR TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_PR DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" } |
Added library/msgs/es_py.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_PY DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_PY TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_PY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" } |
Added library/msgs/es_sv.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_SV DATE_FORMAT "%m-%d-%Y" ::msgcat::mcset es_SV TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_SV DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" } |
Added library/msgs/es_uy.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_UY DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_UY TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_UY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" } |
Added library/msgs/es_ve.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset es_VE DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_VE TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_VE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" } |
Deleted library/msgs/eu_ES.msg.
|
| < < < < < < < |
Added library/msgs/eu_es.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset eu_ES DATE_FORMAT "%a, %Yeko %bren %da" ::msgcat::mcset eu_ES TIME_FORMAT "%T" ::msgcat::mcset eu_ES TIME_FORMAT_12 "%T" ::msgcat::mcset eu_ES DATE_TIME_FORMAT "%y-%m-%d %T %z" } |
Deleted library/msgs/fa_IN.msg.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted library/msgs/fa_IR.msg.
|
| < < < < < < < < < |
Added library/msgs/fa_in.msg.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset fa_IN DAYS_OF_WEEK_ABBREV [list \ "\u06cc\u2214"\ "\u062f\u2214"\ "\u0633\u2214"\ "\u0686\u2214"\ "\u067e\u2214"\ "\u062c\u2214"\ "\u0634\u2214"] ::msgcat::mcset fa_IN DAYS_OF_WEEK_FULL [list \ "\u06cc\u06cc\u200c\u0634\u0646\u0628\u0647"\ "\u062f\u0648\u0634\u0646\u0628\u0647"\ "\u0633\u0647\u200c\u0634\u0646\u0628\u0647"\ "\u0686\u0647\u0627\u0631\u0634\u0646\u0628\u0647"\ "\u067e\u0646\u062c\u200c\u0634\u0646\u0628\u0647"\ "\u062c\u0645\u0639\u0647"\ "\u0634\u0646\u0628\u0647"] ::msgcat::mcset fa_IN MONTHS_ABBREV [list \ "\u0698\u0627\u0646"\ "\u0641\u0648\u0631"\ "\u0645\u0627\u0631"\ "\u0622\u0648\u0631"\ "\u0645\u0640\u0647"\ "\u0698\u0648\u0646"\ "\u0698\u0648\u06cc"\ "\u0627\u0648\u062a"\ "\u0633\u067e\u062a"\ "\u0627\u0643\u062a"\ "\u0646\u0648\u0627"\ "\u062f\u0633\u0627"\ ""] ::msgcat::mcset fa_IN MONTHS_FULL [list \ "\u0698\u0627\u0646\u0648\u06cc\u0647"\ "\u0641\u0648\u0631\u0648\u06cc\u0647"\ "\u0645\u0627\u0631\u0633"\ "\u0622\u0648\u0631\u06cc\u0644"\ "\u0645\u0647"\ "\u0698\u0648\u0626\u0646"\ "\u0698\u0648\u0626\u06cc\u0647"\ "\u0627\u0648\u062a"\ "\u0633\u067e\u062a\u0627\u0645\u0628\u0631"\ "\u0627\u0643\u062a\u0628\u0631"\ "\u0646\u0648\u0627\u0645\u0628\u0631"\ "\u062f\u0633\u0627\u0645\u0628\u0631"\ ""] ::msgcat::mcset fa_IN AM "\u0635\u0628\u062d" ::msgcat::mcset fa_IN PM "\u0639\u0635\u0631" ::msgcat::mcset fa_IN DATE_FORMAT "%A %d %B %Y" ::msgcat::mcset fa_IN TIME_FORMAT_12 "%I:%M:%S %z" ::msgcat::mcset fa_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S %z %z" } |
Added library/msgs/fa_ir.msg.
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset fa_IR AM "\u0635\u0628\u062d" ::msgcat::mcset fa_IR PM "\u0639\u0635\u0631" ::msgcat::mcset fa_IR DATE_FORMAT "%d\u2044%m\u2044%Y" ::msgcat::mcset fa_IR TIME_FORMAT "%S:%M:%H" ::msgcat::mcset fa_IR TIME_FORMAT_12 "%S:%M:%l %P" ::msgcat::mcset fa_IR DATE_TIME_FORMAT "%d\u2044%m\u2044%Y %S:%M:%H %z" } |
Deleted library/msgs/fo_FO.msg.
|
| < < < < < < < |
Added library/msgs/fo_fo.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset fo_FO DATE_FORMAT "%d/%m-%Y" ::msgcat::mcset fo_FO TIME_FORMAT "%T" ::msgcat::mcset fo_FO TIME_FORMAT_12 "%T" ::msgcat::mcset fo_FO DATE_TIME_FORMAT "%a %d %b %Y %T %z" } |
Deleted library/msgs/fr_BE.msg.
|
| < < < < < < < |
Deleted library/msgs/fr_CA.msg.
|
| < < < < < < < |
Deleted library/msgs/fr_CH.msg.
|
| < < < < < < < |
Added library/msgs/fr_be.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset fr_BE DATE_FORMAT "%d/%m/%y" ::msgcat::mcset fr_BE TIME_FORMAT "%T" ::msgcat::mcset fr_BE TIME_FORMAT_12 "%T" ::msgcat::mcset fr_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z" } |
Added library/msgs/fr_ca.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset fr_CA DATE_FORMAT "%Y-%m-%d" ::msgcat::mcset fr_CA TIME_FORMAT "%T" ::msgcat::mcset fr_CA TIME_FORMAT_12 "%T" ::msgcat::mcset fr_CA DATE_TIME_FORMAT "%a %d %b %Y %T %z" } |
Added library/msgs/fr_ch.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset fr_CH DATE_FORMAT "%d. %m. %y" ::msgcat::mcset fr_CH TIME_FORMAT "%T" ::msgcat::mcset fr_CH TIME_FORMAT_12 "%T" ::msgcat::mcset fr_CH DATE_TIME_FORMAT "%a %d %b %Y %T %z" } |
Deleted library/msgs/ga_IE.msg.
|
| < < < < < < < |
Added library/msgs/ga_ie.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ga_IE DATE_FORMAT "%d.%m.%y" ::msgcat::mcset ga_IE TIME_FORMAT "%T" ::msgcat::mcset ga_IE TIME_FORMAT_12 "%T" ::msgcat::mcset ga_IE DATE_TIME_FORMAT "%a %d %b %Y %T %z" } |
Deleted library/msgs/gl_ES.msg.
|
| < < < < < < |
Added library/msgs/gl_es.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset gl_ES DATE_FORMAT "%d %B %Y" ::msgcat::mcset gl_ES TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset gl_ES DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" } |
Deleted library/msgs/gv_GB.msg.
|
| < < < < < < |
Added library/msgs/gv_gb.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset gv_GB DATE_FORMAT "%d %B %Y" ::msgcat::mcset gv_GB TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset gv_GB DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" } |
Deleted library/msgs/hi_IN.msg.
|
| < < < < < < |
Added library/msgs/hi_in.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset hi_IN DATE_FORMAT "%d %M %Y" ::msgcat::mcset hi_IN TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset hi_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" } |
Deleted library/msgs/id_ID.msg.
|
| < < < < < < |
Added library/msgs/id_id.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset id_ID DATE_FORMAT "%d %B %Y" ::msgcat::mcset id_ID TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset id_ID DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" } |
Deleted library/msgs/it_CH.msg.
|
| < < < < < < |
Added library/msgs/it_ch.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset it_CH DATE_FORMAT "%e. %B %Y" ::msgcat::mcset it_CH TIME_FORMAT "%H:%M:%S" ::msgcat::mcset it_CH DATE_TIME_FORMAT "%e. %B %Y %H:%M:%S %z" } |
Deleted library/msgs/kl_GL.msg.
|
| < < < < < < < |
Added library/msgs/kl_gl.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset kl_GL DATE_FORMAT "%d %b %Y" ::msgcat::mcset kl_GL TIME_FORMAT "%T" ::msgcat::mcset kl_GL TIME_FORMAT_12 "%T" ::msgcat::mcset kl_GL DATE_TIME_FORMAT "%a %d %b %Y %T %z" } |
Deleted library/msgs/ko_KR.msg.
|
| < < < < < < < < |
Added library/msgs/ko_kr.msg.
> > > > > > > > | 1 2 3 4 5 6 7 8 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ko_KR BCE "\uae30\uc6d0\uc804" ::msgcat::mcset ko_KR CE "\uc11c\uae30" ::msgcat::mcset ko_KR DATE_FORMAT "%Y.%m.%d" ::msgcat::mcset ko_KR TIME_FORMAT_12 "%P %l:%M:%S" ::msgcat::mcset ko_KR DATE_TIME_FORMAT "%Y.%m.%d %P %l:%M:%S %z" } |
Deleted library/msgs/kok_IN.msg.
|
| < < < < < < |
Added library/msgs/kok_in.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset kok_IN DATE_FORMAT "%d %M %Y" ::msgcat::mcset kok_IN TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset kok_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" } |
Deleted library/msgs/kw_GB.msg.
|
| < < < < < < |
Added library/msgs/kw_gb.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset kw_GB DATE_FORMAT "%d %B %Y" ::msgcat::mcset kw_GB TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset kw_GB DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" } |
Deleted library/msgs/mr_IN.msg.
|
| < < < < < < |
Added library/msgs/mr_in.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset mr_IN DATE_FORMAT "%d %M %Y" ::msgcat::mcset mr_IN TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset mr_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" } |
Deleted library/msgs/ms_MY.msg.
|
| < < < < < < |
Added library/msgs/ms_my.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ms_MY DATE_FORMAT "%A %d %b %Y" ::msgcat::mcset ms_MY TIME_FORMAT_12 "%I:%M:%S %z" ::msgcat::mcset ms_MY DATE_TIME_FORMAT "%A %d %b %Y %I:%M:%S %z %z" } |
Deleted library/msgs/nl_BE.msg.
|
| < < < < < < < |
Added library/msgs/nl_be.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset nl_BE DATE_FORMAT "%d-%m-%y" ::msgcat::mcset nl_BE TIME_FORMAT "%T" ::msgcat::mcset nl_BE TIME_FORMAT_12 "%T" ::msgcat::mcset nl_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z" } |
Deleted library/msgs/pt_BR.msg.
|
| < < < < < < < |
Added library/msgs/pt_br.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset pt_BR DATE_FORMAT "%d-%m-%Y" ::msgcat::mcset pt_BR TIME_FORMAT "%T" ::msgcat::mcset pt_BR TIME_FORMAT_12 "%T" ::msgcat::mcset pt_BR DATE_TIME_FORMAT "%a %d %b %Y %T %z" } |
Deleted library/msgs/ru_UA.msg.
|
| < < < < < < |
Added library/msgs/ru_ua.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ru_UA DATE_FORMAT "%d.%m.%Y" ::msgcat::mcset ru_UA TIME_FORMAT "%k:%M:%S" ::msgcat::mcset ru_UA DATE_TIME_FORMAT "%d.%m.%Y %k:%M:%S %z" } |
Deleted library/msgs/ta_IN.msg.
|
| < < < < < < |
Added library/msgs/ta_in.msg.
> > > > > > | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset ta_IN DATE_FORMAT "%d %M %Y" ::msgcat::mcset ta_IN TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset ta_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" } |
Deleted library/msgs/te_IN.msg.
|
| < < < < < < < < |
Added library/msgs/te_in.msg.
> > > > > > > > | 1 2 3 4 5 6 7 8 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset te_IN AM "\u0c2a\u0c42\u0c30\u0c4d\u0c35\u0c3e\u0c39\u0c4d\u0c28" ::msgcat::mcset te_IN PM "\u0c05\u0c2a\u0c30\u0c3e\u0c39\u0c4d\u0c28" ::msgcat::mcset te_IN DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset te_IN TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset te_IN DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" } |
Deleted library/msgs/zh_CN.msg.
|
| < < < < < < < |
Deleted library/msgs/zh_HK.msg.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted library/msgs/zh_SG.msg.
|
| < < < < < < < < |
Deleted library/msgs/zh_TW.msg.
|
| < < < < < < < < |
Added library/msgs/zh_cn.msg.
> > > > > > > | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset zh_CN DATE_FORMAT "%Y-%m-%e" ::msgcat::mcset zh_CN TIME_FORMAT "%k:%M:%S" ::msgcat::mcset zh_CN TIME_FORMAT_12 "%P%I\u65f6%M\u5206%S\u79d2" ::msgcat::mcset zh_CN DATE_TIME_FORMAT "%Y-%m-%e %k:%M:%S %z" } |
Added library/msgs/zh_hk.msg.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset zh_HK DAYS_OF_WEEK_ABBREV [list \ "\u65e5"\ "\u4e00"\ "\u4e8c"\ "\u4e09"\ "\u56db"\ "\u4e94"\ "\u516d"] ::msgcat::mcset zh_HK MONTHS_ABBREV [list \ "1\u6708"\ "2\u6708"\ "3\u6708"\ "4\u6708"\ "5\u6708"\ "6\u6708"\ "7\u6708"\ "8\u6708"\ "9\u6708"\ "10\u6708"\ "11\u6708"\ "12\u6708"\ ""] ::msgcat::mcset zh_HK DATE_FORMAT "%Y\u5e74%m\u6708%e\u65e5" ::msgcat::mcset zh_HK TIME_FORMAT_12 "%P%I:%M:%S" ::msgcat::mcset zh_HK DATE_TIME_FORMAT "%Y\u5e74%m\u6708%e\u65e5 %P%I:%M:%S %z" } |
Added library/msgs/zh_sg.msg.
> > > > > > > > | 1 2 3 4 5 6 7 8 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset zh_SG AM "\u4e0a\u5348" ::msgcat::mcset zh_SG PM "\u4e2d\u5348" ::msgcat::mcset zh_SG DATE_FORMAT "%d %B %Y" ::msgcat::mcset zh_SG TIME_FORMAT_12 "%P %I:%M:%S" ::msgcat::mcset zh_SG DATE_TIME_FORMAT "%d %B %Y %P %I:%M:%S %z" } |
Added library/msgs/zh_tw.msg.
> > > > > > > > | 1 2 3 4 5 6 7 8 | # created by tools/loadICU.tcl -- do not edit namespace eval ::tcl::clock { ::msgcat::mcset zh_TW BCE "\u6c11\u570b\u524d" ::msgcat::mcset zh_TW CE "\u6c11\u570b" ::msgcat::mcset zh_TW DATE_FORMAT "%Y/%m/%e" ::msgcat::mcset zh_TW TIME_FORMAT_12 "%P %I:%M:%S" ::msgcat::mcset zh_TW DATE_TIME_FORMAT "%Y/%m/%e %P %I:%M:%S %z" } |
Changes to library/package.tcl.
1 2 3 4 5 | # package.tcl -- # # utility procs formerly in init.tcl which can be loaded on demand # for package management. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | # package.tcl -- # # utility procs formerly in init.tcl which can be loaded on demand # for package management. # # RCS: @(#) $Id: package.tcl,v 1.32.2.1 2005/08/02 18:16:15 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # |
︙ | ︙ | |||
27 28 29 30 31 32 33 | # Defaults to [info sharedlibextension] # # Results: # Returns 1 if the extension matches, 0 otherwise proc tcl::Pkg::CompareExtension { fileName {ext {}} } { global tcl_platform | | | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | # Defaults to [info sharedlibextension] # # Results: # Returns 1 if the extension matches, 0 otherwise proc tcl::Pkg::CompareExtension { fileName {ext {}} } { global tcl_platform if {$ext eq ""} {set ext [info sharedlibextension]} if {$tcl_platform(platform) eq "windows"} { return [string equal -nocase [file extension $fileName] $ext] } else { # Some unices add trailing numbers after the .so, so # we could have something like '.so.1.2'. set root $fileName while {1} { set currExt [file extension $root] if {$currExt eq $ext} { return 1 } # The current extension does not match; if it is not a numeric # value, quit, as we are only looking to ignore version number # extensions. Otherwise we might return 1 in this case: # tcl::Pkg::CompareExtension foo.so.bar .so |
︙ | ︙ | |||
131 132 133 134 135 136 137 | set dir [lindex $args $idx] set patternList [lrange $args [expr {$idx + 1}] end] if {[llength $patternList] == 0} { set patternList [list "*.tcl" "*[info sharedlibextension]"] } if {[catch { | | | | | 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 | set dir [lindex $args $idx] set patternList [lrange $args [expr {$idx + 1}] end] if {[llength $patternList] == 0} { set patternList [list "*.tcl" "*[info sharedlibextension]"] } if {[catch { glob -directory $dir -tails -types {r f} -- {expand}$patternList } fileList o]} { return -options $o $fileList } foreach file $fileList { # For each file, figure out what commands and packages it provides. # To do this, create a child interpreter, load the file into the # interpreter, and get a list of the new commands and packages # that are defined. if {$file eq "pkgIndex.tcl"} { continue } set c [interp create] # Load into the child any packages currently loaded in the parent # interpreter that match the -load pattern. if {$loadPat ne ""} { if {$doVerbose} { tclLog "currently loaded packages: '[info loaded]'" tclLog "trying to load all packages matching $loadPat" } if {![llength [info loaded]]} { tclLog "warning: no packages are currently loaded, nothing" tclLog "can possibly match '$loadPat'" |
︙ | ︙ | |||
176 177 178 179 180 181 182 | } err]} { if {$doVerbose} { tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err" } } elseif {$doVerbose} { tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]" } | | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 | } err]} { if {$doVerbose} { tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err" } } elseif {$doVerbose} { tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]" } if {[lindex $pkg 1] eq "Tk"} { # Withdraw . if Tk was loaded, to avoid showing a window. $c eval [list wm withdraw .] } } $c eval { # Stub out the package command so packages can |
︙ | ︙ | |||
259 260 261 262 263 264 265 | # init the list of existing namespaces, packages, commands foreach ::tcl::x [::tcl::GetAllNamespaces] { set ::tcl::namespaces($::tcl::x) 1 } foreach ::tcl::x [package names] { | | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | # init the list of existing namespaces, packages, commands foreach ::tcl::x [::tcl::GetAllNamespaces] { set ::tcl::namespaces($::tcl::x) 1 } foreach ::tcl::x [package names] { if {[package provide $::tcl::x] ne ""} { set ::tcl::packages($::tcl::x) 1 } } set ::tcl::origCmds [info commands] # Try to load the file if it has the shared library # extension, otherwise source it. It's important not to |
︙ | ︙ | |||
307 308 309 310 311 312 313 | # Figure out what commands appeared foreach ::tcl::x [info commands] { set ::tcl::newCmds($::tcl::x) 1 } foreach ::tcl::x $::tcl::origCmds { | | | | | 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 | # Figure out what commands appeared foreach ::tcl::x [info commands] { set ::tcl::newCmds($::tcl::x) 1 } foreach ::tcl::x $::tcl::origCmds { unset -nocomplain ::tcl::newCmds($::tcl::x) } foreach ::tcl::x [array names ::tcl::newCmds] { # determine which namespace a command comes from set ::tcl::abs [namespace origin $::tcl::x] # special case so that global names have no leading # ::, this is required by the unknown command set ::tcl::abs \ [lindex [auto_qualify $::tcl::abs ::] 0] if {$::tcl::x ne $::tcl::abs} { # Name changed during qualification set ::tcl::newCmds($::tcl::abs) 1 unset ::tcl::newCmds($::tcl::x) } } } } # Look through the packages that appeared, and if there is # a version provided, then record it foreach ::tcl::x [package names] { if {[package provide $::tcl::x] ne "" && ![info exists ::tcl::packages($::tcl::x)]} { lappend ::tcl::newPkgs \ [list $::tcl::x [package provide $::tcl::x]] } } } } msg] == 1} { |
︙ | ︙ | |||
433 434 435 436 437 438 439 | global auto_index package provide $pkg $version foreach fileInfo $files { set f [lindex $fileInfo 0] set type [lindex $fileInfo 1] foreach cmd [lindex $fileInfo 2] { | | | 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 | global auto_index package provide $pkg $version foreach fileInfo $files { set f [lindex $fileInfo 0] set type [lindex $fileInfo 1] foreach cmd [lindex $fileInfo 2] { if {$type eq "load"} { set auto_index($cmd) [list load [file join $dir $f] $pkg] } else { set auto_index($cmd) [list source [file join $dir $f]] } } } } |
︙ | ︙ |
Changes to library/parray.tcl.
1 2 3 | # parray: # Print the contents of a global array on stdout. # | | | > | | 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 | # parray: # Print the contents of a global array on stdout. # # RCS: @(#) $Id: parray.tcl,v 1.3.44.1 2005/07/12 20:37:06 kennykb Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # proc parray {a {pattern *}} { upvar 1 $a array if {![array exists array]} { error "\"$a\" isn't an array" } set maxl 0 set names [lsort [array names array $pattern]] foreach name $names { if {[string length $name] > $maxl} { set maxl [string length $name] } } set maxl [expr {$maxl + [string length $a] + 2}] foreach name $names { set nameString [format %s(%s) $a $name] puts stdout [format "%-*s = %s" $maxl $nameString $array($name)] } } |
Changes to library/safe.tcl.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # See the safe.n man page for details. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # See the safe.n man page for details. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: safe.tcl,v 1.14.2.1 2005/08/02 18:16:15 dgp Exp $ # # The implementation is based on namespaces. These naming conventions # are followed: # Private procs starts with uppercase. # Public procs are exported and starts with lowercase # |
︙ | ︙ | |||
73 74 75 76 77 78 79 | # Helper function to resolve the dual way of specifying staticsok # (either by -noStatics or -statics 0) proc InterpStatics {} { foreach v {Args statics noStatics} { upvar $v $v } set flag [::tcl::OptProcArgGiven -noStatics]; | | | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | # Helper function to resolve the dual way of specifying staticsok # (either by -noStatics or -statics 0) proc InterpStatics {} { foreach v {Args statics noStatics} { upvar $v $v } set flag [::tcl::OptProcArgGiven -noStatics]; if {$flag && (!$noStatics == !$statics) && ([::tcl::OptProcArgGiven -statics])} { return -code error\ "conflicting values given for -statics and -noStatics" } if {$flag} { return [expr {!$noStatics}] } else { return $statics } } # Helper function to resolve the dual way of specifying nested loading # (either by -nestedLoadOk or -nested 1) proc InterpNested {} { foreach v {Args nested nestedLoadOk} { upvar $v $v } set flag [::tcl::OptProcArgGiven -nestedLoadOk]; # note that the test here is the opposite of the "InterpStatics" # one (it is not -noNested... because of the wanted default value) if {$flag && (!$nestedLoadOk != !$nested) && ([::tcl::OptProcArgGiven -nested])} { return -code error\ "conflicting values given for -nested and -nestedLoadOk" } if {$flag} { # another difference with "InterpStatics" return $nestedLoadOk |
︙ | ︙ | |||
320 321 322 323 324 325 326 | # you probably need to call "auto_reset" in the slave in order that it # gets the right auto_index() array values. proc ::safe::InterpSetConfig {slave access_path staticsok\ nestedok deletehook} { # determine and store the access path if empty | | | 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 | # you probably need to call "auto_reset" in the slave in order that it # gets the right auto_index() array values. proc ::safe::InterpSetConfig {slave access_path staticsok\ nestedok deletehook} { # determine and store the access path if empty if {$access_path eq ""} { set access_path [uplevel \#0 set auto_path] # Make sure that tcl_library is in auto_path # and at the first position (needed by setAccessPath) set where [lsearch -exact $access_path [info library]] if {$where == -1} { # not found, add it. set access_path [concat [list [info library]] $access_path] |
︙ | ︙ | |||
760 761 762 763 764 765 766 | # package name (can be empty if file is not). set package [lindex $args 0] # Determine where to load. load use a relative interp path # and {} means self, so we can directly and safely use passed arg. set target [lindex $args 1] | | | | | 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 | # package name (can be empty if file is not). set package [lindex $args 0] # Determine where to load. load use a relative interp path # and {} means self, so we can directly and safely use passed arg. set target [lindex $args 1] if {$target ne ""} { # we will try to load into a sub sub interp # check that we want to authorize that. if {![NestedOk $slave]} { Log $slave "loading to a sub interp (nestedok)\ disabled (trying to load $package to $target)" return -code error "permission denied (nested load)" } } # Determine what kind of load is requested if {$file eq ""} { # static package loading if {$package eq ""} { set msg "load error: empty filename and no package name" Log $slave $msg return -code error $msg } if {![StaticsOk $slave]} { Log $slave "static packages loading disabled\ (trying to load $package to $target)" |
︙ | ︙ | |||
842 843 844 845 846 847 848 | # This procedure enables access from a safe interpreter to only a subset of # the subcommands of a command: proc Subset {slave command okpat args} { set subcommand [lindex $args 0] if {[regexp $okpat $subcommand]} { | | | 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 | # This procedure enables access from a safe interpreter to only a subset of # the subcommands of a command: proc Subset {slave command okpat args} { set subcommand [lindex $args 0] if {[regexp $okpat $subcommand]} { return [$command {expand}$args] } set msg "not allowed to invoke subcommand $subcommand of $command" Log $slave $msg error $msg } # This procedure installs an alias in a slave that invokes "safesubset" |
︙ | ︙ | |||
877 878 879 880 881 882 883 | set argc [llength $args] set okpat "^(name.*|convert.*)\$" set subcommand [lindex $args 0] if {[regexp $okpat $subcommand]} { | | < | | 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 | set argc [llength $args] set okpat "^(name.*|convert.*)\$" set subcommand [lindex $args 0] if {[regexp $okpat $subcommand]} { return [::interp invokehidden $slave encoding {expand}$args] } if {[string first $subcommand system] == 0} { if {$argc == 1} { # passed all the tests , lets source it: if {[catch {::interp invokehidden \ $slave encoding system} msg]} { Log $slave $msg return -code error "script error" } |
︙ | ︙ |
Changes to library/tclIndex.
︙ | ︙ | |||
70 71 72 73 74 75 76 77 78 79 80 81 | set auto_index(::safe::Log) [list source [file join $dir safe.tcl]] set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]] set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]] set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]] set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]] set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]] set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]] set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]] set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]] | > > > > > > | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | set auto_index(::safe::Log) [list source [file join $dir safe.tcl]] set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]] set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]] set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]] set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]] set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]] set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]] set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]] set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]] set auto_index(::tcl::tm::add) [list source [file join $dir tm.tcl]] set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]] set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]] set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]] set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]] |
Changes to library/tcltest/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex -direct" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.3]} {return} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex -direct" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.3]} {return} package ifneeded tcltest 2.2.8 [list source [file join $dir tcltest.tcl]] |
Changes to library/tcltest/tcltest.tcl.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2000 by Ajuba Solutions # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. # | | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2000 by Ajuba Solutions # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. # # RCS: @(#) $Id: tcltest.tcl,v 1.93.2.1 2005/03/09 15:57:18 kennykb Exp $ package require Tcl 8.3 ;# uses [glob -directory] namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. variable Version 2.2.8 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] # yourself. You don't need tcltest to wrap it for you. variable version [package provide Tcl] variable patchLevel [info patchlevel] |
︙ | ︙ | |||
2565 2566 2567 2568 2569 2570 2571 | set matchingFiles [list] foreach directory $dirList { # List files in $directory that match patterns to run. set matchFileList [list] foreach match [matchFiles] { set matchFileList [concat $matchFileList \ | | > | > | 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 | set matchingFiles [list] foreach directory $dirList { # List files in $directory that match patterns to run. set matchFileList [list] foreach match [matchFiles] { set matchFileList [concat $matchFileList \ [glob -directory $directory -types {b c f p s} \ -nocomplain -- $match]] } # List files in $directory that match patterns to skip. set skipFileList [list] foreach skip [skipFiles] { set skipFileList [concat $skipFileList \ [glob -directory $directory -types {b c f p s} \ -nocomplain -- $skip]] } # Add to result list all files in match list and not in skip list foreach file $matchFileList { if {[lsearch -exact $skipFileList $file] == -1} { lappend matchingFiles $file } |
︙ | ︙ | |||
2614 2615 2616 2617 2618 2619 2620 | proc tcltest::GetMatchingDirectories {rootdir} { # Determine the skip list first, to avoid [glob]-ing over subdirectories # we're going to throw away anyway. Be sure we skip the $rootdir if it # comes up to avoid infinite loops. set skipDirs [list $rootdir] foreach pattern [skipDirectories] { | | | < < < | | | | < | | < | 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 | proc tcltest::GetMatchingDirectories {rootdir} { # Determine the skip list first, to avoid [glob]-ing over subdirectories # we're going to throw away anyway. Be sure we skip the $rootdir if it # comes up to avoid infinite loops. set skipDirs [list $rootdir] foreach pattern [skipDirectories] { set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \ -nocomplain -- $pattern]] } # Now step through the matching directories, prune out the skipped ones # as you go. set matchDirs [list] foreach pattern [matchDirectories] { foreach path [glob -directory $rootdir -types d -nocomplain -- \ $pattern] { if {[lsearch -exact $skipDirs $path] == -1} { set matchDirs [concat $matchDirs [GetMatchingDirectories $path]] if {[file exists [file join $path all.tcl]]} { lappend matchDirs $path } } } } if {[llength $matchDirs] == 0} { DebugPuts 1 "No test directories remain after applying match\ |
︙ | ︙ |
Changes to library/tm.tcl.
︙ | ︙ | |||
349 350 351 352 353 354 355 | proc ::tcl::tm::roots {paths} { foreach {major minor} [split [info tclversion] .] break foreach pa $paths { set p [file join $pa tcl$major] for {set n $minor} {$n >= 0} {incr n -1} { path add [file normalize [file join $p ${major}.${n}]] } | | < | 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 | proc ::tcl::tm::roots {paths} { foreach {major minor} [split [info tclversion] .] break foreach pa $paths { set p [file join $pa tcl$major] for {set n $minor} {$n >= 0} {incr n -1} { path add [file normalize [file join $p ${major}.${n}]] } path add [file normalize [file join $p site-tcl]] } return } # Initialization. Set up the default paths, then insert the new # handler into the chain. ::tcl::tm::Defaults |
Changes to library/tzdata/Africa/Timbuktu.
1 | # created by ../tools/tclZIC.tcl - do not edit | > > | | < < < | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(Africa/Bamako)]} { LoadTimeZoneFile Africa/Bamako } set TZData(:Africa/Timbuktu) $TZData(:Africa/Bamako) |
Changes to library/tzdata/Africa/Tunis.
︙ | ︙ | |||
24 25 26 27 28 29 30 31 | {276048000 3600 0 CET} {581126400 7200 1 CEST} {591148800 3600 0 CET} {606873600 7200 1 CEST} {622598400 3600 0 CET} {641520000 7200 1 CEST} {654652800 3600 0 CET} } | > > | 24 25 26 27 28 29 30 31 32 33 | {276048000 3600 0 CET} {581126400 7200 1 CEST} {591148800 3600 0 CET} {606873600 7200 1 CEST} {622598400 3600 0 CET} {641520000 7200 1 CEST} {654652800 3600 0 CET} {1114905600 7200 1 CEST} {1128042000 3600 0 CET} } |
Changes to library/tzdata/America/Adak.
︙ | ︙ | |||
83 84 85 86 87 88 89 | {1067166000 -36000 0 HAST} {1081080000 -32400 1 HADT} {1099220400 -36000 0 HAST} {1112529600 -32400 1 HADT} {1130670000 -36000 0 HAST} {1143979200 -32400 1 HADT} {1162119600 -36000 0 HAST} | | | | | | > > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | 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 | {1067166000 -36000 0 HAST} {1081080000 -32400 1 HADT} {1099220400 -36000 0 HAST} {1112529600 -32400 1 HADT} {1130670000 -36000 0 HAST} {1143979200 -32400 1 HADT} {1162119600 -36000 0 HAST} {1173614400 -32400 1 HADT} {1194174000 -36000 0 HAST} {1205064000 -32400 1 HADT} {1225623600 -36000 0 HAST} {1236513600 -32400 1 HADT} {1257073200 -36000 0 HAST} {1268568000 -32400 1 HADT} {1289127600 -36000 0 HAST} {1300017600 -32400 1 HADT} {1320577200 -36000 0 HAST} {1331467200 -32400 1 HADT} {1352026800 -36000 0 HAST} {1362916800 -32400 1 HADT} {1383476400 -36000 0 HAST} {1394366400 -32400 1 HADT} {1414926000 -36000 0 HAST} {1425816000 -32400 1 HADT} {1446375600 -36000 0 HAST} {1457870400 -32400 1 HADT} {1478430000 -36000 0 HAST} {1489320000 -32400 1 HADT} {1509879600 -36000 0 HAST} {1520769600 -32400 1 HADT} {1541329200 -36000 0 HAST} {1552219200 -32400 1 HADT} {1572778800 -36000 0 HAST} {1583668800 -32400 1 HADT} {1604228400 -36000 0 HAST} {1615723200 -32400 1 HADT} {1636282800 -36000 0 HAST} {1647172800 -32400 1 HADT} {1667732400 -36000 0 HAST} {1678622400 -32400 1 HADT} {1699182000 -36000 0 HAST} {1710072000 -32400 1 HADT} {1730631600 -36000 0 HAST} {1741521600 -32400 1 HADT} {1762081200 -36000 0 HAST} {1772971200 -32400 1 HADT} {1793530800 -36000 0 HAST} {1805025600 -32400 1 HADT} {1825585200 -36000 0 HAST} {1836475200 -32400 1 HADT} {1857034800 -36000 0 HAST} {1867924800 -32400 1 HADT} {1888484400 -36000 0 HAST} {1899374400 -32400 1 HADT} {1919934000 -36000 0 HAST} {1930824000 -32400 1 HADT} {1951383600 -36000 0 HAST} {1962878400 -32400 1 HADT} {1983438000 -36000 0 HAST} {1994328000 -32400 1 HADT} {2014887600 -36000 0 HAST} {2025777600 -32400 1 HADT} {2046337200 -36000 0 HAST} {2057227200 -32400 1 HADT} {2077786800 -36000 0 HAST} {2088676800 -32400 1 HADT} {2109236400 -36000 0 HAST} {2120126400 -32400 1 HADT} {2140686000 -36000 0 HAST} {2152180800 -32400 1 HADT} {2172740400 -36000 0 HAST} {2183630400 -32400 1 HADT} {2204190000 -36000 0 HAST} {2215080000 -32400 1 HADT} {2235639600 -36000 0 HAST} {2246529600 -32400 1 HADT} {2267089200 -36000 0 HAST} {2277979200 -32400 1 HADT} {2298538800 -36000 0 HAST} {2309428800 -32400 1 HADT} {2329988400 -36000 0 HAST} {2341483200 -32400 1 HADT} {2362042800 -36000 0 HAST} {2372932800 -32400 1 HADT} {2393492400 -36000 0 HAST} {2404382400 -32400 1 HADT} {2424942000 -36000 0 HAST} {2435832000 -32400 1 HADT} {2456391600 -36000 0 HAST} {2467281600 -32400 1 HADT} {2487841200 -36000 0 HAST} {2499336000 -32400 1 HADT} {2519895600 -36000 0 HAST} {2530785600 -32400 1 HADT} {2551345200 -36000 0 HAST} {2562235200 -32400 1 HADT} {2582794800 -36000 0 HAST} {2593684800 -32400 1 HADT} {2614244400 -36000 0 HAST} {2625134400 -32400 1 HADT} {2645694000 -36000 0 HAST} {2656584000 -32400 1 HADT} {2677143600 -36000 0 HAST} {2688638400 -32400 1 HADT} {2709198000 -36000 0 HAST} {2720088000 -32400 1 HADT} {2740647600 -36000 0 HAST} {2751537600 -32400 1 HADT} {2772097200 -36000 0 HAST} {2782987200 -32400 1 HADT} {2803546800 -36000 0 HAST} {2814436800 -32400 1 HADT} {2834996400 -36000 0 HAST} {2846491200 -32400 1 HADT} {2867050800 -36000 0 HAST} {2877940800 -32400 1 HADT} {2898500400 -36000 0 HAST} {2909390400 -32400 1 HADT} {2929950000 -36000 0 HAST} {2940840000 -32400 1 HADT} {2961399600 -36000 0 HAST} {2972289600 -32400 1 HADT} {2992849200 -36000 0 HAST} {3003739200 -32400 1 HADT} {3024298800 -36000 0 HAST} {3035793600 -32400 1 HADT} {3056353200 -36000 0 HAST} {3067243200 -32400 1 HADT} {3087802800 -36000 0 HAST} {3098692800 -32400 1 HADT} {3119252400 -36000 0 HAST} {3130142400 -32400 1 HADT} {3150702000 -36000 0 HAST} {3161592000 -32400 1 HADT} {3182151600 -36000 0 HAST} {3193041600 -32400 1 HADT} {3213601200 -36000 0 HAST} {3225096000 -32400 1 HADT} {3245655600 -36000 0 HAST} {3256545600 -32400 1 HADT} {3277105200 -36000 0 HAST} {3287995200 -32400 1 HADT} {3308554800 -36000 0 HAST} {3319444800 -32400 1 HADT} {3340004400 -36000 0 HAST} {3350894400 -32400 1 HADT} {3371454000 -36000 0 HAST} {3382948800 -32400 1 HADT} {3403508400 -36000 0 HAST} {3414398400 -32400 1 HADT} {3434958000 -36000 0 HAST} {3445848000 -32400 1 HADT} {3466407600 -36000 0 HAST} {3477297600 -32400 1 HADT} {3497857200 -36000 0 HAST} {3508747200 -32400 1 HADT} {3529306800 -36000 0 HAST} {3540196800 -32400 1 HADT} {3560756400 -36000 0 HAST} {3572251200 -32400 1 HADT} {3592810800 -36000 0 HAST} {3603700800 -32400 1 HADT} {3624260400 -36000 0 HAST} {3635150400 -32400 1 HADT} {3655710000 -36000 0 HAST} {3666600000 -32400 1 HADT} {3687159600 -36000 0 HAST} {3698049600 -32400 1 HADT} {3718609200 -36000 0 HAST} {3730104000 -32400 1 HADT} {3750663600 -36000 0 HAST} {3761553600 -32400 1 HADT} {3782113200 -36000 0 HAST} {3793003200 -32400 1 HADT} {3813562800 -36000 0 HAST} {3824452800 -32400 1 HADT} {3845012400 -36000 0 HAST} {3855902400 -32400 1 HADT} {3876462000 -36000 0 HAST} {3887352000 -32400 1 HADT} {3907911600 -36000 0 HAST} {3919406400 -32400 1 HADT} {3939966000 -36000 0 HAST} {3950856000 -32400 1 HADT} {3971415600 -36000 0 HAST} {3982305600 -32400 1 HADT} {4002865200 -36000 0 HAST} {4013755200 -32400 1 HADT} {4034314800 -36000 0 HAST} {4045204800 -32400 1 HADT} {4065764400 -36000 0 HAST} {4076654400 -32400 1 HADT} {4097214000 -36000 0 HAST} } |
Changes to library/tzdata/America/Anchorage.
︙ | ︙ | |||
83 84 85 86 87 88 89 | {1067162400 -32400 0 AKST} {1081076400 -28800 1 AKDT} {1099216800 -32400 0 AKST} {1112526000 -28800 1 AKDT} {1130666400 -32400 0 AKST} {1143975600 -28800 1 AKDT} {1162116000 -32400 0 AKST} | | | | | | | | < < | | | | | | | | | | | | < < | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | > > | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | 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 | {1067162400 -32400 0 AKST} {1081076400 -28800 1 AKDT} {1099216800 -32400 0 AKST} {1112526000 -28800 1 AKDT} {1130666400 -32400 0 AKST} {1143975600 -28800 1 AKDT} {1162116000 -32400 0 AKST} {1173610800 -28800 1 AKDT} {1194170400 -32400 0 AKST} {1205060400 -28800 1 AKDT} {1225620000 -32400 0 AKST} {1236510000 -28800 1 AKDT} {1257069600 -32400 0 AKST} {1268564400 -28800 1 AKDT} {1289124000 -32400 0 AKST} {1300014000 -28800 1 AKDT} {1320573600 -32400 0 AKST} {1331463600 -28800 1 AKDT} {1352023200 -32400 0 AKST} {1362913200 -28800 1 AKDT} {1383472800 -32400 0 AKST} {1394362800 -28800 1 AKDT} {1414922400 -32400 0 AKST} {1425812400 -28800 1 AKDT} {1446372000 -32400 0 AKST} {1457866800 -28800 1 AKDT} {1478426400 -32400 0 AKST} {1489316400 -28800 1 AKDT} {1509876000 -32400 0 AKST} {1520766000 -28800 1 AKDT} {1541325600 -32400 0 AKST} {1552215600 -28800 1 AKDT} {1572775200 -32400 0 AKST} {1583665200 -28800 1 AKDT} {1604224800 -32400 0 AKST} {1615719600 -28800 1 AKDT} {1636279200 -32400 0 AKST} {1647169200 -28800 1 AKDT} {1667728800 -32400 0 AKST} {1678618800 -28800 1 AKDT} {1699178400 -32400 0 AKST} {1710068400 -28800 1 AKDT} {1730628000 -32400 0 AKST} {1741518000 -28800 1 AKDT} {1762077600 -32400 0 AKST} {1772967600 -28800 1 AKDT} {1793527200 -32400 0 AKST} {1805022000 -28800 1 AKDT} {1825581600 -32400 0 AKST} {1836471600 -28800 1 AKDT} {1857031200 -32400 0 AKST} {1867921200 -28800 1 AKDT} {1888480800 -32400 0 AKST} {1899370800 -28800 1 AKDT} {1919930400 -32400 0 AKST} {1930820400 -28800 1 AKDT} {1951380000 -32400 0 AKST} {1962874800 -28800 1 AKDT} {1983434400 -32400 0 AKST} {1994324400 -28800 1 AKDT} {2014884000 -32400 0 AKST} {2025774000 -28800 1 AKDT} {2046333600 -32400 0 AKST} {2057223600 -28800 1 AKDT} {2077783200 -32400 0 AKST} {2088673200 -28800 1 AKDT} {2109232800 -32400 0 AKST} {2120122800 -28800 1 AKDT} {2140682400 -32400 0 AKST} {2152177200 -28800 1 AKDT} {2172736800 -32400 0 AKST} {2183626800 -28800 1 AKDT} {2204186400 -32400 0 AKST} {2215076400 -28800 1 AKDT} {2235636000 -32400 0 AKST} {2246526000 -28800 1 AKDT} {2267085600 -32400 0 AKST} {2277975600 -28800 1 AKDT} {2298535200 -32400 0 AKST} {2309425200 -28800 1 AKDT} {2329984800 -32400 0 AKST} {2341479600 -28800 1 AKDT} {2362039200 -32400 0 AKST} {2372929200 -28800 1 AKDT} {2393488800 -32400 0 AKST} {2404378800 -28800 1 AKDT} {2424938400 -32400 0 AKST} {2435828400 -28800 1 AKDT} {2456388000 -32400 0 AKST} {2467278000 -28800 1 AKDT} {2487837600 -32400 0 AKST} {2499332400 -28800 1 AKDT} {2519892000 -32400 0 AKST} {2530782000 -28800 1 AKDT} {2551341600 -32400 0 AKST} {2562231600 -28800 1 AKDT} {2582791200 -32400 0 AKST} {2593681200 -28800 1 AKDT} {2614240800 -32400 0 AKST} {2625130800 -28800 1 AKDT} {2645690400 -32400 0 AKST} {2656580400 -28800 1 AKDT} {2677140000 -32400 0 AKST} {2688634800 -28800 1 AKDT} {2709194400 -32400 0 AKST} {2720084400 -28800 1 AKDT} {2740644000 -32400 0 AKST} {2751534000 -28800 1 AKDT} {2772093600 -32400 0 AKST} {2782983600 -28800 1 AKDT} {2803543200 -32400 0 AKST} {2814433200 -28800 1 AKDT} {2834992800 -32400 0 AKST} {2846487600 -28800 1 AKDT} {2867047200 -32400 0 AKST} {2877937200 -28800 1 AKDT} {2898496800 -32400 0 AKST} {2909386800 -28800 1 AKDT} {2929946400 -32400 0 AKST} {2940836400 -28800 1 AKDT} {2961396000 -32400 0 AKST} {2972286000 -28800 1 AKDT} {2992845600 -32400 0 AKST} {3003735600 -28800 1 AKDT} {3024295200 -32400 0 AKST} {3035790000 -28800 1 AKDT} {3056349600 -32400 0 AKST} {3067239600 -28800 1 AKDT} {3087799200 -32400 0 AKST} {3098689200 -28800 1 AKDT} {3119248800 -32400 0 AKST} {3130138800 -28800 1 AKDT} {3150698400 -32400 0 AKST} {3161588400 -28800 1 AKDT} {3182148000 -32400 0 AKST} {3193038000 -28800 1 AKDT} {3213597600 -32400 0 AKST} {3225092400 -28800 1 AKDT} {3245652000 -32400 0 AKST} {3256542000 -28800 1 AKDT} {3277101600 -32400 0 AKST} {3287991600 -28800 1 AKDT} {3308551200 -32400 0 AKST} {3319441200 -28800 1 AKDT} {3340000800 -32400 0 AKST} {3350890800 -28800 1 AKDT} {3371450400 -32400 0 AKST} {3382945200 -28800 1 AKDT} {3403504800 -32400 0 AKST} {3414394800 -28800 1 AKDT} {3434954400 -32400 0 AKST} {3445844400 -28800 1 AKDT} {3466404000 -32400 0 AKST} {3477294000 -28800 1 AKDT} {3497853600 -32400 0 AKST} {3508743600 -28800 1 AKDT} {3529303200 -32400 0 AKST} {3540193200 -28800 1 AKDT} {3560752800 -32400 0 AKST} {3572247600 -28800 1 AKDT} {3592807200 -32400 0 AKST} {3603697200 -28800 1 AKDT} {3624256800 -32400 0 AKST} {3635146800 -28800 1 AKDT} {3655706400 -32400 0 AKST} {3666596400 -28800 1 AKDT} {3687156000 -32400 0 AKST} {3698046000 -28800 1 AKDT} {3718605600 -32400 0 AKST} {3730100400 -28800 1 AKDT} {3750660000 -32400 0 AKST} {3761550000 -28800 1 AKDT} {3782109600 -32400 0 AKST} {3792999600 -28800 1 AKDT} {3813559200 -32400 0 AKST} {3824449200 -28800 1 AKDT} {3845008800 -32400 0 AKST} {3855898800 -28800 1 AKDT} {3876458400 -32400 0 AKST} {3887348400 -28800 1 AKDT} {3907908000 -32400 0 AKST} {3919402800 -28800 1 AKDT} {3939962400 -32400 0 AKST} {3950852400 -28800 1 AKDT} {3971412000 -32400 0 AKST} {3982302000 -28800 1 AKDT} {4002861600 -32400 0 AKST} {4013751600 -28800 1 AKDT} {4034311200 -32400 0 AKST} {4045201200 -28800 1 AKDT} {4065760800 -32400 0 AKST} {4076650800 -28800 1 AKDT} {4097210400 -32400 0 AKST} } |
Changes to library/tzdata/America/Argentina/ComodRivadavia.
1 | # created by ../tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(America/Argentina/Catamarca)]} { LoadTimeZoneFile America/Argentina/Catamarca } set TZData(:America/Argentina/ComodRivadavia) $TZData(:America/Argentina/Catamarca) |
Changes to library/tzdata/America/Asuncion.
︙ | ︙ | |||
61 62 63 64 65 66 67 | {983674800 -14400 0 PYT} {1002427200 -10800 1 PYST} {1018148400 -14400 0 PYT} {1030852800 -10800 1 PYST} {1049598000 -14400 0 PYT} {1062907200 -10800 1 PYST} {1081047600 -14400 0 PYT} | | | | | | < < | | | | | | | | | | | | | | | < < | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | 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 | {983674800 -14400 0 PYT} {1002427200 -10800 1 PYST} {1018148400 -14400 0 PYT} {1030852800 -10800 1 PYST} {1049598000 -14400 0 PYT} {1062907200 -10800 1 PYST} {1081047600 -14400 0 PYT} {1097985600 -10800 1 PYST} {1110682800 -14400 0 PYT} {1129435200 -10800 1 PYST} {1142132400 -14400 0 PYT} {1160884800 -10800 1 PYST} {1173582000 -14400 0 PYT} {1192939200 -10800 1 PYST} {1205031600 -14400 0 PYT} {1224388800 -10800 1 PYST} {1236481200 -14400 0 PYT} {1255838400 -10800 1 PYST} {1268535600 -14400 0 PYT} {1287288000 -10800 1 PYST} {1299985200 -14400 0 PYT} {1318737600 -10800 1 PYST} {1331434800 -14400 0 PYT} {1350792000 -10800 1 PYST} {1362884400 -14400 0 PYT} {1382241600 -10800 1 PYST} {1394334000 -14400 0 PYT} {1413691200 -10800 1 PYST} {1425783600 -14400 0 PYT} {1445140800 -10800 1 PYST} {1457838000 -14400 0 PYT} {1476590400 -10800 1 PYST} {1489287600 -14400 0 PYT} {1508040000 -10800 1 PYST} {1520737200 -14400 0 PYT} {1540094400 -10800 1 PYST} {1552186800 -14400 0 PYT} {1571544000 -10800 1 PYST} {1583636400 -14400 0 PYT} {1602993600 -10800 1 PYST} {1615690800 -14400 0 PYT} {1634443200 -10800 1 PYST} {1647140400 -14400 0 PYT} {1665892800 -10800 1 PYST} {1678590000 -14400 0 PYT} {1697342400 -10800 1 PYST} {1710039600 -14400 0 PYT} {1729396800 -10800 1 PYST} {1741489200 -14400 0 PYT} {1760846400 -10800 1 PYST} {1772938800 -14400 0 PYT} {1792296000 -10800 1 PYST} {1804993200 -14400 0 PYT} {1823745600 -10800 1 PYST} {1836442800 -14400 0 PYT} {1855195200 -10800 1 PYST} {1867892400 -14400 0 PYT} {1887249600 -10800 1 PYST} {1899342000 -14400 0 PYT} {1918699200 -10800 1 PYST} {1930791600 -14400 0 PYT} {1950148800 -10800 1 PYST} {1962846000 -14400 0 PYT} {1981598400 -10800 1 PYST} {1994295600 -14400 0 PYT} {2013048000 -10800 1 PYST} {2025745200 -14400 0 PYT} {2044497600 -10800 1 PYST} {2057194800 -14400 0 PYT} {2076552000 -10800 1 PYST} {2088644400 -14400 0 PYT} {2108001600 -10800 1 PYST} {2120094000 -14400 0 PYT} {2139451200 -10800 1 PYST} {2152148400 -14400 0 PYT} {2170900800 -10800 1 PYST} {2183598000 -14400 0 PYT} {2202350400 -10800 1 PYST} {2215047600 -14400 0 PYT} {2234404800 -10800 1 PYST} {2246497200 -14400 0 PYT} {2265854400 -10800 1 PYST} {2277946800 -14400 0 PYT} {2297304000 -10800 1 PYST} {2309396400 -14400 0 PYT} {2328753600 -10800 1 PYST} {2341450800 -14400 0 PYT} {2360203200 -10800 1 PYST} {2372900400 -14400 0 PYT} {2391652800 -10800 1 PYST} {2404350000 -14400 0 PYT} {2423707200 -10800 1 PYST} {2435799600 -14400 0 PYT} {2455156800 -10800 1 PYST} {2467249200 -14400 0 PYT} {2486606400 -10800 1 PYST} {2499303600 -14400 0 PYT} {2518056000 -10800 1 PYST} {2530753200 -14400 0 PYT} {2549505600 -10800 1 PYST} {2562202800 -14400 0 PYT} {2580955200 -10800 1 PYST} {2593652400 -14400 0 PYT} {2613009600 -10800 1 PYST} {2625102000 -14400 0 PYT} {2644459200 -10800 1 PYST} {2656551600 -14400 0 PYT} {2675908800 -10800 1 PYST} {2688606000 -14400 0 PYT} {2707358400 -10800 1 PYST} {2720055600 -14400 0 PYT} {2738808000 -10800 1 PYST} {2751505200 -14400 0 PYT} {2770862400 -10800 1 PYST} {2782954800 -14400 0 PYT} {2802312000 -10800 1 PYST} {2814404400 -14400 0 PYT} {2833761600 -10800 1 PYST} {2846458800 -14400 0 PYT} {2865211200 -10800 1 PYST} {2877908400 -14400 0 PYT} {2896660800 -10800 1 PYST} {2909358000 -14400 0 PYT} {2928110400 -10800 1 PYST} {2940807600 -14400 0 PYT} {2960164800 -10800 1 PYST} {2972257200 -14400 0 PYT} {2991614400 -10800 1 PYST} {3003706800 -14400 0 PYT} {3023064000 -10800 1 PYST} {3035761200 -14400 0 PYT} {3054513600 -10800 1 PYST} {3067210800 -14400 0 PYT} {3085963200 -10800 1 PYST} {3098660400 -14400 0 PYT} {3118017600 -10800 1 PYST} {3130110000 -14400 0 PYT} {3149467200 -10800 1 PYST} {3161559600 -14400 0 PYT} {3180916800 -10800 1 PYST} {3193009200 -14400 0 PYT} {3212366400 -10800 1 PYST} {3225063600 -14400 0 PYT} {3243816000 -10800 1 PYST} {3256513200 -14400 0 PYT} {3275265600 -10800 1 PYST} {3287962800 -14400 0 PYT} {3307320000 -10800 1 PYST} {3319412400 -14400 0 PYT} {3338769600 -10800 1 PYST} {3350862000 -14400 0 PYT} {3370219200 -10800 1 PYST} {3382916400 -14400 0 PYT} {3401668800 -10800 1 PYST} {3414366000 -14400 0 PYT} {3433118400 -10800 1 PYST} {3445815600 -14400 0 PYT} {3464568000 -10800 1 PYST} {3477265200 -14400 0 PYT} {3496622400 -10800 1 PYST} {3508714800 -14400 0 PYT} {3528072000 -10800 1 PYST} {3540164400 -14400 0 PYT} {3559521600 -10800 1 PYST} {3572218800 -14400 0 PYT} {3590971200 -10800 1 PYST} {3603668400 -14400 0 PYT} {3622420800 -10800 1 PYST} {3635118000 -14400 0 PYT} {3654475200 -10800 1 PYST} {3666567600 -14400 0 PYT} {3685924800 -10800 1 PYST} {3698017200 -14400 0 PYT} {3717374400 -10800 1 PYST} {3730071600 -14400 0 PYT} {3748824000 -10800 1 PYST} {3761521200 -14400 0 PYT} {3780273600 -10800 1 PYST} {3792970800 -14400 0 PYT} {3811723200 -10800 1 PYST} {3824420400 -14400 0 PYT} {3843777600 -10800 1 PYST} {3855870000 -14400 0 PYT} {3875227200 -10800 1 PYST} {3887319600 -14400 0 PYT} {3906676800 -10800 1 PYST} {3919374000 -14400 0 PYT} {3938126400 -10800 1 PYST} {3950823600 -14400 0 PYT} {3969576000 -10800 1 PYST} {3982273200 -14400 0 PYT} {4001630400 -10800 1 PYST} {4013722800 -14400 0 PYT} {4033080000 -10800 1 PYST} {4045172400 -14400 0 PYT} {4064529600 -10800 1 PYST} {4076622000 -14400 0 PYT} {4095979200 -10800 1 PYST} } |
Changes to library/tzdata/America/Boise.
1 2 3 4 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Boise) { {-9223372036854775808 -27889 0 LMT} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Boise) { {-9223372036854775808 -27889 0 LMT} {-2717640000 -28800 0 PST} {-1633269600 -25200 1 PDT} {-1615129200 -28800 0 PST} {-1601820000 -25200 1 PDT} {-1583679600 -28800 0 PST} {-1471788000 -25200 0 MST} {-880210800 -21600 1 MWT} {-769395600 -21600 1 MPT} |
︙ | ︙ | |||
88 89 90 91 92 93 94 | {1067155200 -25200 0 MST} {1081069200 -21600 1 MDT} {1099209600 -25200 0 MST} {1112518800 -21600 1 MDT} {1130659200 -25200 0 MST} {1143968400 -21600 1 MDT} {1162108800 -25200 0 MST} | | | | | | | | | > > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | > > | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | < < | 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 | {1067155200 -25200 0 MST} {1081069200 -21600 1 MDT} {1099209600 -25200 0 MST} {1112518800 -21600 1 MDT} {1130659200 -25200 0 MST} {1143968400 -21600 1 MDT} {1162108800 -25200 0 MST} {1173603600 -21600 1 MDT} {1194163200 -25200 0 MST} {1205053200 -21600 1 MDT} {1225612800 -25200 0 MST} {1236502800 -21600 1 MDT} {1257062400 -25200 0 MST} {1268557200 -21600 1 MDT} {1289116800 -25200 0 MST} {1300006800 -21600 1 MDT} {1320566400 -25200 0 MST} {1331456400 -21600 1 MDT} {1352016000 -25200 0 MST} {1362906000 -21600 1 MDT} {1383465600 -25200 0 MST} {1394355600 -21600 1 MDT} {1414915200 -25200 0 MST} {1425805200 -21600 1 MDT} {1446364800 -25200 0 MST} {1457859600 -21600 1 MDT} {1478419200 -25200 0 MST} {1489309200 -21600 1 MDT} {1509868800 -25200 0 MST} {1520758800 -21600 1 MDT} {1541318400 -25200 0 MST} {1552208400 -21600 1 MDT} {1572768000 -25200 0 MST} {1583658000 -21600 1 MDT} {1604217600 -25200 0 MST} {1615712400 -21600 1 MDT} {1636272000 -25200 0 MST} {1647162000 -21600 1 MDT} {1667721600 -25200 0 MST} {1678611600 -21600 1 MDT} {1699171200 -25200 0 MST} {1710061200 -21600 1 MDT} {1730620800 -25200 0 MST} {1741510800 -21600 1 MDT} {1762070400 -25200 0 MST} {1772960400 -21600 1 MDT} {1793520000 -25200 0 MST} {1805014800 -21600 1 MDT} {1825574400 -25200 0 MST} {1836464400 -21600 1 MDT} {1857024000 -25200 0 MST} {1867914000 -21600 1 MDT} {1888473600 -25200 0 MST} {1899363600 -21600 1 MDT} {1919923200 -25200 0 MST} {1930813200 -21600 1 MDT} {1951372800 -25200 0 MST} {1962867600 -21600 1 MDT} {1983427200 -25200 0 MST} {1994317200 -21600 1 MDT} {2014876800 -25200 0 MST} {2025766800 -21600 1 MDT} {2046326400 -25200 0 MST} {2057216400 -21600 1 MDT} {2077776000 -25200 0 MST} {2088666000 -21600 1 MDT} {2109225600 -25200 0 MST} {2120115600 -21600 1 MDT} {2140675200 -25200 0 MST} {2152170000 -21600 1 MDT} {2172729600 -25200 0 MST} {2183619600 -21600 1 MDT} {2204179200 -25200 0 MST} {2215069200 -21600 1 MDT} {2235628800 -25200 0 MST} {2246518800 -21600 1 MDT} {2267078400 -25200 0 MST} {2277968400 -21600 1 MDT} {2298528000 -25200 0 MST} {2309418000 -21600 1 MDT} {2329977600 -25200 0 MST} {2341472400 -21600 1 MDT} {2362032000 -25200 0 MST} {2372922000 -21600 1 MDT} {2393481600 -25200 0 MST} {2404371600 -21600 1 MDT} {2424931200 -25200 0 MST} {2435821200 -21600 1 MDT} {2456380800 -25200 0 MST} {2467270800 -21600 1 MDT} {2487830400 -25200 0 MST} {2499325200 -21600 1 MDT} {2519884800 -25200 0 MST} {2530774800 -21600 1 MDT} {2551334400 -25200 0 MST} {2562224400 -21600 1 MDT} {2582784000 -25200 0 MST} {2593674000 -21600 1 MDT} {2614233600 -25200 0 MST} {2625123600 -21600 1 MDT} {2645683200 -25200 0 MST} {2656573200 -21600 1 MDT} {2677132800 -25200 0 MST} {2688627600 -21600 1 MDT} {2709187200 -25200 0 MST} {2720077200 -21600 1 MDT} {2740636800 -25200 0 MST} {2751526800 -21600 1 MDT} {2772086400 -25200 0 MST} {2782976400 -21600 1 MDT} {2803536000 -25200 0 MST} {2814426000 -21600 1 MDT} {2834985600 -25200 0 MST} {2846480400 -21600 1 MDT} {2867040000 -25200 0 MST} {2877930000 -21600 1 MDT} {2898489600 -25200 0 MST} {2909379600 -21600 1 MDT} {2929939200 -25200 0 MST} {2940829200 -21600 1 MDT} {2961388800 -25200 0 MST} {2972278800 -21600 1 MDT} {2992838400 -25200 0 MST} {3003728400 -21600 1 MDT} {3024288000 -25200 0 MST} {3035782800 -21600 1 MDT} {3056342400 -25200 0 MST} {3067232400 -21600 1 MDT} {3087792000 -25200 0 MST} {3098682000 -21600 1 MDT} {3119241600 -25200 0 MST} {3130131600 -21600 1 MDT} {3150691200 -25200 0 MST} {3161581200 -21600 1 MDT} {3182140800 -25200 0 MST} {3193030800 -21600 1 MDT} {3213590400 -25200 0 MST} {3225085200 -21600 1 MDT} {3245644800 -25200 0 MST} {3256534800 -21600 1 MDT} {3277094400 -25200 0 MST} {3287984400 -21600 1 MDT} {3308544000 -25200 0 MST} {3319434000 -21600 1 MDT} {3339993600 -25200 0 MST} {3350883600 -21600 1 MDT} {3371443200 -25200 0 MST} {3382938000 -21600 1 MDT} {3403497600 -25200 0 MST} {3414387600 -21600 1 MDT} {3434947200 -25200 0 MST} {3445837200 -21600 1 MDT} {3466396800 -25200 0 MST} {3477286800 -21600 1 MDT} {3497846400 -25200 0 MST} {3508736400 -21600 1 MDT} {3529296000 -25200 0 MST} {3540186000 -21600 1 MDT} {3560745600 -25200 0 MST} {3572240400 -21600 1 MDT} {3592800000 -25200 0 MST} {3603690000 -21600 1 MDT} {3624249600 -25200 0 MST} {3635139600 -21600 1 MDT} {3655699200 -25200 0 MST} {3666589200 -21600 1 MDT} {3687148800 -25200 0 MST} {3698038800 -21600 1 MDT} {3718598400 -25200 0 MST} {3730093200 -21600 1 MDT} {3750652800 -25200 0 MST} {3761542800 -21600 1 MDT} {3782102400 -25200 0 MST} {3792992400 -21600 1 MDT} {3813552000 -25200 0 MST} {3824442000 -21600 1 MDT} {3845001600 -25200 0 MST} {3855891600 -21600 1 MDT} {3876451200 -25200 0 MST} {3887341200 -21600 1 MDT} {3907900800 -25200 0 MST} {3919395600 -21600 1 MDT} {3939955200 -25200 0 MST} {3950845200 -21600 1 MDT} {3971404800 -25200 0 MST} {3982294800 -21600 1 MDT} {4002854400 -25200 0 MST} {4013744400 -21600 1 MDT} {4034304000 -25200 0 MST} {4045194000 -21600 1 MDT} {4065753600 -25200 0 MST} {4076643600 -21600 1 MDT} {4097203200 -25200 0 MST} } |
Changes to library/tzdata/America/Chicago.
1 2 3 4 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Chicago) { {-9223372036854775808 -21036 0 LMT} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Chicago) { {-9223372036854775808 -21036 0 LMT} {-2717647200 -21600 0 CST} {-1633276800 -18000 1 CDT} {-1615136400 -21600 0 CST} {-1601827200 -18000 1 CDT} {-1583686800 -21600 0 CST} {-1577901600 -21600 0 CST} {-1563724800 -18000 1 CDT} {-1551632400 -21600 0 CST} |
︙ | ︙ | |||
176 177 178 179 180 181 182 | {1067151600 -21600 0 CST} {1081065600 -18000 1 CDT} {1099206000 -21600 0 CST} {1112515200 -18000 1 CDT} {1130655600 -21600 0 CST} {1143964800 -18000 1 CDT} {1162105200 -21600 0 CST} | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | {1067151600 -21600 0 CST} {1081065600 -18000 1 CDT} {1099206000 -21600 0 CST} {1112515200 -18000 1 CDT} {1130655600 -21600 0 CST} {1143964800 -18000 1 CDT} {1162105200 -21600 0 CST} {1173600000 -18000 1 CDT} {1194159600 -21600 0 CST} {1205049600 -18000 1 CDT} {1225609200 -21600 0 CST} {1236499200 -18000 1 CDT} {1257058800 -21600 0 CST} {1268553600 -18000 1 CDT} {1289113200 -21600 0 CST} {1300003200 -18000 1 CDT} {1320562800 -21600 0 CST} {1331452800 -18000 1 CDT} {1352012400 -21600 0 CST} {1362902400 -18000 1 CDT} {1383462000 -21600 0 CST} {1394352000 -18000 1 CDT} {1414911600 -21600 0 CST} {1425801600 -18000 1 CDT} {1446361200 -21600 0 CST} {1457856000 -18000 1 CDT} {1478415600 -21600 0 CST} {1489305600 -18000 1 CDT} {1509865200 -21600 0 CST} {1520755200 -18000 1 CDT} {1541314800 -21600 0 CST} {1552204800 -18000 1 CDT} {1572764400 -21600 0 CST} {1583654400 -18000 1 CDT} {1604214000 -21600 0 CST} {1615708800 -18000 1 CDT} {1636268400 -21600 0 CST} {1647158400 -18000 1 CDT} {1667718000 -21600 0 CST} {1678608000 -18000 1 CDT} {1699167600 -21600 0 CST} {1710057600 -18000 1 CDT} {1730617200 -21600 0 CST} {1741507200 -18000 1 CDT} {1762066800 -21600 0 CST} {1772956800 -18000 1 CDT} {1793516400 -21600 0 CST} {1805011200 -18000 1 CDT} {1825570800 -21600 0 CST} {1836460800 -18000 1 CDT} {1857020400 -21600 0 CST} {1867910400 -18000 1 CDT} {1888470000 -21600 0 CST} {1899360000 -18000 1 CDT} {1919919600 -21600 0 CST} {1930809600 -18000 1 CDT} {1951369200 -21600 0 CST} {1962864000 -18000 1 CDT} {1983423600 -21600 0 CST} {1994313600 -18000 1 CDT} {2014873200 -21600 0 CST} {2025763200 -18000 1 CDT} {2046322800 -21600 0 CST} {2057212800 -18000 1 CDT} {2077772400 -21600 0 CST} {2088662400 -18000 1 CDT} {2109222000 -21600 0 CST} {2120112000 -18000 1 CDT} {2140671600 -21600 0 CST} {2152166400 -18000 1 CDT} {2172726000 -21600 0 CST} {2183616000 -18000 1 CDT} {2204175600 -21600 0 CST} {2215065600 -18000 1 CDT} {2235625200 -21600 0 CST} {2246515200 -18000 1 CDT} {2267074800 -21600 0 CST} {2277964800 -18000 1 CDT} {2298524400 -21600 0 CST} {2309414400 -18000 1 CDT} {2329974000 -21600 0 CST} {2341468800 -18000 1 CDT} {2362028400 -21600 0 CST} {2372918400 -18000 1 CDT} {2393478000 -21600 0 CST} {2404368000 -18000 1 CDT} {2424927600 -21600 0 CST} {2435817600 -18000 1 CDT} {2456377200 -21600 0 CST} {2467267200 -18000 1 CDT} {2487826800 -21600 0 CST} {2499321600 -18000 1 CDT} {2519881200 -21600 0 CST} {2530771200 -18000 1 CDT} {2551330800 -21600 0 CST} {2562220800 -18000 1 CDT} {2582780400 -21600 0 CST} {2593670400 -18000 1 CDT} {2614230000 -21600 0 CST} {2625120000 -18000 1 CDT} {2645679600 -21600 0 CST} {2656569600 -18000 1 CDT} {2677129200 -21600 0 CST} {2688624000 -18000 1 CDT} {2709183600 -21600 0 CST} {2720073600 -18000 1 CDT} {2740633200 -21600 0 CST} {2751523200 -18000 1 CDT} {2772082800 -21600 0 CST} {2782972800 -18000 1 CDT} {2803532400 -21600 0 CST} {2814422400 -18000 1 CDT} {2834982000 -21600 0 CST} {2846476800 -18000 1 CDT} {2867036400 -21600 0 CST} {2877926400 -18000 1 CDT} {2898486000 -21600 0 CST} {2909376000 -18000 1 CDT} {2929935600 -21600 0 CST} {2940825600 -18000 1 CDT} {2961385200 -21600 0 CST} {2972275200 -18000 1 CDT} {2992834800 -21600 0 CST} {3003724800 -18000 1 CDT} {3024284400 -21600 0 CST} {3035779200 -18000 1 CDT} {3056338800 -21600 0 CST} {3067228800 -18000 1 CDT} {3087788400 -21600 0 CST} {3098678400 -18000 1 CDT} {3119238000 -21600 0 CST} {3130128000 -18000 1 CDT} {3150687600 -21600 0 CST} {3161577600 -18000 1 CDT} {3182137200 -21600 0 CST} {3193027200 -18000 1 CDT} {3213586800 -21600 0 CST} {3225081600 -18000 1 CDT} {3245641200 -21600 0 CST} {3256531200 -18000 1 CDT} {3277090800 -21600 0 CST} {3287980800 -18000 1 CDT} {3308540400 -21600 0 CST} {3319430400 -18000 1 CDT} {3339990000 -21600 0 CST} {3350880000 -18000 1 CDT} {3371439600 -21600 0 CST} {3382934400 -18000 1 CDT} {3403494000 -21600 0 CST} {3414384000 -18000 1 CDT} {3434943600 -21600 0 CST} {3445833600 -18000 1 CDT} {3466393200 -21600 0 CST} {3477283200 -18000 1 CDT} {3497842800 -21600 0 CST} {3508732800 -18000 1 CDT} {3529292400 -21600 0 CST} {3540182400 -18000 1 CDT} {3560742000 -21600 0 CST} {3572236800 -18000 1 CDT} {3592796400 -21600 0 CST} {3603686400 -18000 1 CDT} {3624246000 -21600 0 CST} {3635136000 -18000 1 CDT} {3655695600 -21600 0 CST} {3666585600 -18000 1 CDT} {3687145200 -21600 0 CST} {3698035200 -18000 1 CDT} {3718594800 -21600 0 CST} {3730089600 -18000 1 CDT} {3750649200 -21600 0 CST} {3761539200 -18000 1 CDT} {3782098800 -21600 0 CST} {3792988800 -18000 1 CDT} {3813548400 -21600 0 CST} {3824438400 -18000 1 CDT} {3844998000 -21600 0 CST} {3855888000 -18000 1 CDT} {3876447600 -21600 0 CST} {3887337600 -18000 1 CDT} {3907897200 -21600 0 CST} {3919392000 -18000 1 CDT} {3939951600 -21600 0 CST} {3950841600 -18000 1 CDT} {3971401200 -21600 0 CST} {3982291200 -18000 1 CDT} {4002850800 -21600 0 CST} {4013740800 -18000 1 CDT} {4034300400 -21600 0 CST} {4045190400 -18000 1 CDT} {4065750000 -21600 0 CST} {4076640000 -18000 1 CDT} {4097199600 -21600 0 CST} } |
Added library/tzdata/America/Coral_Harbour.
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Coral_Harbour) { {-9223372036854775808 -19960 0 LMT} {-2713890440 -18000 0 EST} {-1632070800 -14400 1 EDT} {-1615140000 -18000 0 EST} {-1596992400 -14400 1 EDT} {-1583179200 -18000 0 EST} {-880218000 -14400 1 EWT} {-769395600 -14400 1 EPT} {-765396000 -18000 0 EST} {-757364400 -18000 0 EST} } |
Changes to library/tzdata/America/Denver.
1 2 3 4 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Denver) { {-9223372036854775808 -25196 0 LMT} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Denver) { {-9223372036854775808 -25196 0 LMT} {-2717643600 -25200 0 MST} {-1633273200 -21600 1 MDT} {-1615132800 -25200 0 MST} {-1601823600 -21600 1 MDT} {-1583683200 -25200 0 MST} {-1577898000 -25200 0 MST} {-1570374000 -21600 1 MDT} {-1551628800 -25200 0 MST} |
︙ | ︙ | |||
98 99 100 101 102 103 104 | {1067155200 -25200 0 MST} {1081069200 -21600 1 MDT} {1099209600 -25200 0 MST} {1112518800 -21600 1 MDT} {1130659200 -25200 0 MST} {1143968400 -21600 1 MDT} {1162108800 -25200 0 MST} | | | | | | | | | > > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | > > | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | < < | 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 | {1067155200 -25200 0 MST} {1081069200 -21600 1 MDT} {1099209600 -25200 0 MST} {1112518800 -21600 1 MDT} {1130659200 -25200 0 MST} {1143968400 -21600 1 MDT} {1162108800 -25200 0 MST} {1173603600 -21600 1 MDT} {1194163200 -25200 0 MST} {1205053200 -21600 1 MDT} {1225612800 -25200 0 MST} {1236502800 -21600 1 MDT} {1257062400 -25200 0 MST} {1268557200 -21600 1 MDT} {1289116800 -25200 0 MST} {1300006800 -21600 1 MDT} {1320566400 -25200 0 MST} {1331456400 -21600 1 MDT} {1352016000 -25200 0 MST} {1362906000 -21600 1 MDT} {1383465600 -25200 0 MST} {1394355600 -21600 1 MDT} {1414915200 -25200 0 MST} {1425805200 -21600 1 MDT} {1446364800 -25200 0 MST} {1457859600 -21600 1 MDT} {1478419200 -25200 0 MST} {1489309200 -21600 1 MDT} {1509868800 -25200 0 MST} {1520758800 -21600 1 MDT} {1541318400 -25200 0 MST} {1552208400 -21600 1 MDT} {1572768000 -25200 0 MST} {1583658000 -21600 1 MDT} {1604217600 -25200 0 MST} {1615712400 -21600 1 MDT} {1636272000 -25200 0 MST} {1647162000 -21600 1 MDT} {1667721600 -25200 0 MST} {1678611600 -21600 1 MDT} {1699171200 -25200 0 MST} {1710061200 -21600 1 MDT} {1730620800 -25200 0 MST} {1741510800 -21600 1 MDT} {1762070400 -25200 0 MST} {1772960400 -21600 1 MDT} {1793520000 -25200 0 MST} {1805014800 -21600 1 MDT} {1825574400 -25200 0 MST} {1836464400 -21600 1 MDT} {1857024000 -25200 0 MST} {1867914000 -21600 1 MDT} {1888473600 -25200 0 MST} {1899363600 -21600 1 MDT} {1919923200 -25200 0 MST} {1930813200 -21600 1 MDT} {1951372800 -25200 0 MST} {1962867600 -21600 1 MDT} {1983427200 -25200 0 MST} {1994317200 -21600 1 MDT} {2014876800 -25200 0 MST} {2025766800 -21600 1 MDT} {2046326400 -25200 0 MST} {2057216400 -21600 1 MDT} {2077776000 -25200 0 MST} {2088666000 -21600 1 MDT} {2109225600 -25200 0 MST} {2120115600 -21600 1 MDT} {2140675200 -25200 0 MST} {2152170000 -21600 1 MDT} {2172729600 -25200 0 MST} {2183619600 -21600 1 MDT} {2204179200 -25200 0 MST} {2215069200 -21600 1 MDT} {2235628800 -25200 0 MST} {2246518800 -21600 1 MDT} {2267078400 -25200 0 MST} {2277968400 -21600 1 MDT} {2298528000 -25200 0 MST} {2309418000 -21600 1 MDT} {2329977600 -25200 0 MST} {2341472400 -21600 1 MDT} {2362032000 -25200 0 MST} {2372922000 -21600 1 MDT} {2393481600 -25200 0 MST} {2404371600 -21600 1 MDT} {2424931200 -25200 0 MST} {2435821200 -21600 1 MDT} {2456380800 -25200 0 MST} {2467270800 -21600 1 MDT} {2487830400 -25200 0 MST} {2499325200 -21600 1 MDT} {2519884800 -25200 0 MST} {2530774800 -21600 1 MDT} {2551334400 -25200 0 MST} {2562224400 -21600 1 MDT} {2582784000 -25200 0 MST} {2593674000 -21600 1 MDT} {2614233600 -25200 0 MST} {2625123600 -21600 1 MDT} {2645683200 -25200 0 MST} {2656573200 -21600 1 MDT} {2677132800 -25200 0 MST} {2688627600 -21600 1 MDT} {2709187200 -25200 0 MST} {2720077200 -21600 1 MDT} {2740636800 -25200 0 MST} {2751526800 -21600 1 MDT} {2772086400 -25200 0 MST} {2782976400 -21600 1 MDT} {2803536000 -25200 0 MST} {2814426000 -21600 1 MDT} {2834985600 -25200 0 MST} {2846480400 -21600 1 MDT} {2867040000 -25200 0 MST} {2877930000 -21600 1 MDT} {2898489600 -25200 0 MST} {2909379600 -21600 1 MDT} {2929939200 -25200 0 MST} {2940829200 -21600 1 MDT} {2961388800 -25200 0 MST} {2972278800 -21600 1 MDT} {2992838400 -25200 0 MST} {3003728400 -21600 1 MDT} {3024288000 -25200 0 MST} {3035782800 -21600 1 MDT} {3056342400 -25200 0 MST} {3067232400 -21600 1 MDT} {3087792000 -25200 0 MST} {3098682000 -21600 1 MDT} {3119241600 -25200 0 MST} {3130131600 -21600 1 MDT} {3150691200 -25200 0 MST} {3161581200 -21600 1 MDT} {3182140800 -25200 0 MST} {3193030800 -21600 1 MDT} {3213590400 -25200 0 MST} {3225085200 -21600 1 MDT} {3245644800 -25200 0 MST} {3256534800 -21600 1 MDT} {3277094400 -25200 0 MST} {3287984400 -21600 1 MDT} {3308544000 -25200 0 MST} {3319434000 -21600 1 MDT} {3339993600 -25200 0 MST} {3350883600 -21600 1 MDT} {3371443200 -25200 0 MST} {3382938000 -21600 1 MDT} {3403497600 -25200 0 MST} {3414387600 -21600 1 MDT} {3434947200 -25200 0 MST} {3445837200 -21600 1 MDT} {3466396800 -25200 0 MST} {3477286800 -21600 1 MDT} {3497846400 -25200 0 MST} {3508736400 -21600 1 MDT} {3529296000 -25200 0 MST} {3540186000 -21600 1 MDT} {3560745600 -25200 0 MST} {3572240400 -21600 1 MDT} {3592800000 -25200 0 MST} {3603690000 -21600 1 MDT} {3624249600 -25200 0 MST} {3635139600 -21600 1 MDT} {3655699200 -25200 0 MST} {3666589200 -21600 1 MDT} {3687148800 -25200 0 MST} {3698038800 -21600 1 MDT} {3718598400 -25200 0 MST} {3730093200 -21600 1 MDT} {3750652800 -25200 0 MST} {3761542800 -21600 1 MDT} {3782102400 -25200 0 MST} {3792992400 -21600 1 MDT} {3813552000 -25200 0 MST} {3824442000 -21600 1 MDT} {3845001600 -25200 0 MST} {3855891600 -21600 1 MDT} {3876451200 -25200 0 MST} {3887341200 -21600 1 MDT} {3907900800 -25200 0 MST} {3919395600 -21600 1 MDT} {3939955200 -25200 0 MST} {3950845200 -21600 1 MDT} {3971404800 -25200 0 MST} {3982294800 -21600 1 MDT} {4002854400 -25200 0 MST} {4013744400 -21600 1 MDT} {4034304000 -25200 0 MST} {4045194000 -21600 1 MDT} {4065753600 -25200 0 MST} {4076643600 -21600 1 MDT} {4097203200 -25200 0 MST} } |
Changes to library/tzdata/America/Detroit.
︙ | ︙ | |||
79 80 81 82 83 84 85 | {1067148000 -18000 0 EST} {1081062000 -14400 1 EDT} {1099202400 -18000 0 EST} {1112511600 -14400 1 EDT} {1130652000 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} | | | > > | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | > > | | | | | | | | | | > > | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | {1067148000 -18000 0 EST} {1081062000 -14400 1 EDT} {1099202400 -18000 0 EST} {1112511600 -14400 1 EDT} {1130652000 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} {1173596400 -14400 1 EDT} {1194156000 -18000 0 EST} {1205046000 -14400 1 EDT} {1225605600 -18000 0 EST} {1236495600 -14400 1 EDT} {1257055200 -18000 0 EST} {1268550000 -14400 1 EDT} {1289109600 -18000 0 EST} {1299999600 -14400 1 EDT} {1320559200 -18000 0 EST} {1331449200 -14400 1 EDT} {1352008800 -18000 0 EST} {1362898800 -14400 1 EDT} {1383458400 -18000 0 EST} {1394348400 -14400 1 EDT} {1414908000 -18000 0 EST} {1425798000 -14400 1 EDT} {1446357600 -18000 0 EST} {1457852400 -14400 1 EDT} {1478412000 -18000 0 EST} {1489302000 -14400 1 EDT} {1509861600 -18000 0 EST} {1520751600 -14400 1 EDT} {1541311200 -18000 0 EST} {1552201200 -14400 1 EDT} {1572760800 -18000 0 EST} {1583650800 -14400 1 EDT} {1604210400 -18000 0 EST} {1615705200 -14400 1 EDT} {1636264800 -18000 0 EST} {1647154800 -14400 1 EDT} {1667714400 -18000 0 EST} {1678604400 -14400 1 EDT} {1699164000 -18000 0 EST} {1710054000 -14400 1 EDT} {1730613600 -18000 0 EST} {1741503600 -14400 1 EDT} {1762063200 -18000 0 EST} {1772953200 -14400 1 EDT} {1793512800 -18000 0 EST} {1805007600 -14400 1 EDT} {1825567200 -18000 0 EST} {1836457200 -14400 1 EDT} {1857016800 -18000 0 EST} {1867906800 -14400 1 EDT} {1888466400 -18000 0 EST} {1899356400 -14400 1 EDT} {1919916000 -18000 0 EST} {1930806000 -14400 1 EDT} {1951365600 -18000 0 EST} {1962860400 -14400 1 EDT} {1983420000 -18000 0 EST} {1994310000 -14400 1 EDT} {2014869600 -18000 0 EST} {2025759600 -14400 1 EDT} {2046319200 -18000 0 EST} {2057209200 -14400 1 EDT} {2077768800 -18000 0 EST} {2088658800 -14400 1 EDT} {2109218400 -18000 0 EST} {2120108400 -14400 1 EDT} {2140668000 -18000 0 EST} {2152162800 -14400 1 EDT} {2172722400 -18000 0 EST} {2183612400 -14400 1 EDT} {2204172000 -18000 0 EST} {2215062000 -14400 1 EDT} {2235621600 -18000 0 EST} {2246511600 -14400 1 EDT} {2267071200 -18000 0 EST} {2277961200 -14400 1 EDT} {2298520800 -18000 0 EST} {2309410800 -14400 1 EDT} {2329970400 -18000 0 EST} {2341465200 -14400 1 EDT} {2362024800 -18000 0 EST} {2372914800 -14400 1 EDT} {2393474400 -18000 0 EST} {2404364400 -14400 1 EDT} {2424924000 -18000 0 EST} {2435814000 -14400 1 EDT} {2456373600 -18000 0 EST} {2467263600 -14400 1 EDT} {2487823200 -18000 0 EST} {2499318000 -14400 1 EDT} {2519877600 -18000 0 EST} {2530767600 -14400 1 EDT} {2551327200 -18000 0 EST} {2562217200 -14400 1 EDT} {2582776800 -18000 0 EST} {2593666800 -14400 1 EDT} {2614226400 -18000 0 EST} {2625116400 -14400 1 EDT} {2645676000 -18000 0 EST} {2656566000 -14400 1 EDT} {2677125600 -18000 0 EST} {2688620400 -14400 1 EDT} {2709180000 -18000 0 EST} {2720070000 -14400 1 EDT} {2740629600 -18000 0 EST} {2751519600 -14400 1 EDT} {2772079200 -18000 0 EST} {2782969200 -14400 1 EDT} {2803528800 -18000 0 EST} {2814418800 -14400 1 EDT} {2834978400 -18000 0 EST} {2846473200 -14400 1 EDT} {2867032800 -18000 0 EST} {2877922800 -14400 1 EDT} {2898482400 -18000 0 EST} {2909372400 -14400 1 EDT} {2929932000 -18000 0 EST} {2940822000 -14400 1 EDT} {2961381600 -18000 0 EST} {2972271600 -14400 1 EDT} {2992831200 -18000 0 EST} {3003721200 -14400 1 EDT} {3024280800 -18000 0 EST} {3035775600 -14400 1 EDT} {3056335200 -18000 0 EST} {3067225200 -14400 1 EDT} {3087784800 -18000 0 EST} {3098674800 -14400 1 EDT} {3119234400 -18000 0 EST} {3130124400 -14400 1 EDT} {3150684000 -18000 0 EST} {3161574000 -14400 1 EDT} {3182133600 -18000 0 EST} {3193023600 -14400 1 EDT} {3213583200 -18000 0 EST} {3225078000 -14400 1 EDT} {3245637600 -18000 0 EST} {3256527600 -14400 1 EDT} {3277087200 -18000 0 EST} {3287977200 -14400 1 EDT} {3308536800 -18000 0 EST} {3319426800 -14400 1 EDT} {3339986400 -18000 0 EST} {3350876400 -14400 1 EDT} {3371436000 -18000 0 EST} {3382930800 -14400 1 EDT} {3403490400 -18000 0 EST} {3414380400 -14400 1 EDT} {3434940000 -18000 0 EST} {3445830000 -14400 1 EDT} {3466389600 -18000 0 EST} {3477279600 -14400 1 EDT} {3497839200 -18000 0 EST} {3508729200 -14400 1 EDT} {3529288800 -18000 0 EST} {3540178800 -14400 1 EDT} {3560738400 -18000 0 EST} {3572233200 -14400 1 EDT} {3592792800 -18000 0 EST} {3603682800 -14400 1 EDT} {3624242400 -18000 0 EST} {3635132400 -14400 1 EDT} {3655692000 -18000 0 EST} {3666582000 -14400 1 EDT} {3687141600 -18000 0 EST} {3698031600 -14400 1 EDT} {3718591200 -18000 0 EST} {3730086000 -14400 1 EDT} {3750645600 -18000 0 EST} {3761535600 -14400 1 EDT} {3782095200 -18000 0 EST} {3792985200 -14400 1 EDT} {3813544800 -18000 0 EST} {3824434800 -14400 1 EDT} {3844994400 -18000 0 EST} {3855884400 -14400 1 EDT} {3876444000 -18000 0 EST} {3887334000 -14400 1 EDT} {3907893600 -18000 0 EST} {3919388400 -14400 1 EDT} {3939948000 -18000 0 EST} {3950838000 -14400 1 EDT} {3971397600 -18000 0 EST} {3982287600 -14400 1 EDT} {4002847200 -18000 0 EST} {4013737200 -14400 1 EDT} {4034296800 -18000 0 EST} {4045186800 -14400 1 EDT} {4065746400 -18000 0 EST} {4076636400 -14400 1 EDT} {4097196000 -18000 0 EST} } |
Changes to library/tzdata/America/Fort_Wayne.
1 | # created by ../tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(America/Indiana/Indianapolis)]} { LoadTimeZoneFile America/Indiana/Indianapolis } set TZData(:America/Fort_Wayne) $TZData(:America/Indiana/Indianapolis) |
Changes to library/tzdata/America/Indiana/Indianapolis.
1 | # created by ../tools/tclZIC.tcl - do not edit | < < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Indiana/Indianapolis) { {-9223372036854775808 -20678 0 LMT} {-2717647200 -21600 0 CST} {-1633276800 -18000 1 CDT} {-1615136400 -21600 0 CST} {-1601827200 -18000 1 CDT} {-1583686800 -21600 0 CST} {-1577901600 -21600 0 CST} {-900259200 -18000 1 CDT} {-891795600 -21600 0 CST} {-883591200 -21600 0 CST} {-880214400 -18000 1 CWT} {-769395600 -18000 1 CPT} {-765392400 -21600 0 CST} {-757360800 -21600 0 CST} {-747244800 -18000 1 CDT} {-733942800 -21600 0 CST} {-715795200 -18000 1 CDT} {-702493200 -21600 0 CST} {-684345600 -18000 1 CDT} {-671043600 -21600 0 CST} {-652896000 -18000 1 CDT} {-639594000 -21600 0 CST} {-620841600 -18000 1 CDT} {-608144400 -21600 0 CST} {-589392000 -18000 1 CDT} {-576090000 -21600 0 CST} {-557942400 -18000 1 CDT} {-544640400 -21600 0 CST} {-526492800 -18000 1 CDT} {-513190800 -21600 0 CST} {-495043200 -18000 1 CDT} {-481741200 -21600 0 CST} {-463593600 -18000 0 EST} {-386787600 -21600 0 CST} {-368640000 -18000 0 EST} {-31518000 -18000 0 EST} {-21488400 -14400 1 EDT} {-5767200 -18000 0 EST} {9961200 -14400 1 EDT} {25682400 -18000 0 EST} {31554000 -18000 0 EST} {1136091600 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} {1173596400 -14400 1 EDT} {1194156000 -18000 0 EST} {1205046000 -14400 1 EDT} {1225605600 -18000 0 EST} {1236495600 -14400 1 EDT} {1257055200 -18000 0 EST} {1268550000 -14400 1 EDT} {1289109600 -18000 0 EST} {1299999600 -14400 1 EDT} {1320559200 -18000 0 EST} {1331449200 -14400 1 EDT} {1352008800 -18000 0 EST} {1362898800 -14400 1 EDT} {1383458400 -18000 0 EST} {1394348400 -14400 1 EDT} {1414908000 -18000 0 EST} {1425798000 -14400 1 EDT} {1446357600 -18000 0 EST} {1457852400 -14400 1 EDT} {1478412000 -18000 0 EST} {1489302000 -14400 1 EDT} {1509861600 -18000 0 EST} {1520751600 -14400 1 EDT} {1541311200 -18000 0 EST} {1552201200 -14400 1 EDT} {1572760800 -18000 0 EST} {1583650800 -14400 1 EDT} {1604210400 -18000 0 EST} {1615705200 -14400 1 EDT} {1636264800 -18000 0 EST} {1647154800 -14400 1 EDT} {1667714400 -18000 0 EST} {1678604400 -14400 1 EDT} {1699164000 -18000 0 EST} {1710054000 -14400 1 EDT} {1730613600 -18000 0 EST} {1741503600 -14400 1 EDT} {1762063200 -18000 0 EST} {1772953200 -14400 1 EDT} {1793512800 -18000 0 EST} {1805007600 -14400 1 EDT} {1825567200 -18000 0 EST} {1836457200 -14400 1 EDT} {1857016800 -18000 0 EST} {1867906800 -14400 1 EDT} {1888466400 -18000 0 EST} {1899356400 -14400 1 EDT} {1919916000 -18000 0 EST} {1930806000 -14400 1 EDT} {1951365600 -18000 0 EST} {1962860400 -14400 1 EDT} {1983420000 -18000 0 EST} {1994310000 -14400 1 EDT} {2014869600 -18000 0 EST} {2025759600 -14400 1 EDT} {2046319200 -18000 0 EST} {2057209200 -14400 1 EDT} {2077768800 -18000 0 EST} {2088658800 -14400 1 EDT} {2109218400 -18000 0 EST} {2120108400 -14400 1 EDT} {2140668000 -18000 0 EST} {2152162800 -14400 1 EDT} {2172722400 -18000 0 EST} {2183612400 -14400 1 EDT} {2204172000 -18000 0 EST} {2215062000 -14400 1 EDT} {2235621600 -18000 0 EST} {2246511600 -14400 1 EDT} {2267071200 -18000 0 EST} {2277961200 -14400 1 EDT} {2298520800 -18000 0 EST} {2309410800 -14400 1 EDT} {2329970400 -18000 0 EST} {2341465200 -14400 1 EDT} {2362024800 -18000 0 EST} {2372914800 -14400 1 EDT} {2393474400 -18000 0 EST} {2404364400 -14400 1 EDT} {2424924000 -18000 0 EST} {2435814000 -14400 1 EDT} {2456373600 -18000 0 EST} {2467263600 -14400 1 EDT} {2487823200 -18000 0 EST} {2499318000 -14400 1 EDT} {2519877600 -18000 0 EST} {2530767600 -14400 1 EDT} {2551327200 -18000 0 EST} {2562217200 -14400 1 EDT} {2582776800 -18000 0 EST} {2593666800 -14400 1 EDT} {2614226400 -18000 0 EST} {2625116400 -14400 1 EDT} {2645676000 -18000 0 EST} {2656566000 -14400 1 EDT} {2677125600 -18000 0 EST} {2688620400 -14400 1 EDT} {2709180000 -18000 0 EST} {2720070000 -14400 1 EDT} {2740629600 -18000 0 EST} {2751519600 -14400 1 EDT} {2772079200 -18000 0 EST} {2782969200 -14400 1 EDT} {2803528800 -18000 0 EST} {2814418800 -14400 1 EDT} {2834978400 -18000 0 EST} {2846473200 -14400 1 EDT} {2867032800 -18000 0 EST} {2877922800 -14400 1 EDT} {2898482400 -18000 0 EST} {2909372400 -14400 1 EDT} {2929932000 -18000 0 EST} {2940822000 -14400 1 EDT} {2961381600 -18000 0 EST} {2972271600 -14400 1 EDT} {2992831200 -18000 0 EST} {3003721200 -14400 1 EDT} {3024280800 -18000 0 EST} {3035775600 -14400 1 EDT} {3056335200 -18000 0 EST} {3067225200 -14400 1 EDT} {3087784800 -18000 0 EST} {3098674800 -14400 1 EDT} {3119234400 -18000 0 EST} {3130124400 -14400 1 EDT} {3150684000 -18000 0 EST} {3161574000 -14400 1 EDT} {3182133600 -18000 0 EST} {3193023600 -14400 1 EDT} {3213583200 -18000 0 EST} {3225078000 -14400 1 EDT} {3245637600 -18000 0 EST} {3256527600 -14400 1 EDT} {3277087200 -18000 0 EST} {3287977200 -14400 1 EDT} {3308536800 -18000 0 EST} {3319426800 -14400 1 EDT} {3339986400 -18000 0 EST} {3350876400 -14400 1 EDT} {3371436000 -18000 0 EST} {3382930800 -14400 1 EDT} {3403490400 -18000 0 EST} {3414380400 -14400 1 EDT} {3434940000 -18000 0 EST} {3445830000 -14400 1 EDT} {3466389600 -18000 0 EST} {3477279600 -14400 1 EDT} {3497839200 -18000 0 EST} {3508729200 -14400 1 EDT} {3529288800 -18000 0 EST} {3540178800 -14400 1 EDT} {3560738400 -18000 0 EST} {3572233200 -14400 1 EDT} {3592792800 -18000 0 EST} {3603682800 -14400 1 EDT} {3624242400 -18000 0 EST} {3635132400 -14400 1 EDT} {3655692000 -18000 0 EST} {3666582000 -14400 1 EDT} {3687141600 -18000 0 EST} {3698031600 -14400 1 EDT} {3718591200 -18000 0 EST} {3730086000 -14400 1 EDT} {3750645600 -18000 0 EST} {3761535600 -14400 1 EDT} {3782095200 -18000 0 EST} {3792985200 -14400 1 EDT} {3813544800 -18000 0 EST} {3824434800 -14400 1 EDT} {3844994400 -18000 0 EST} {3855884400 -14400 1 EDT} {3876444000 -18000 0 EST} {3887334000 -14400 1 EDT} {3907893600 -18000 0 EST} {3919388400 -14400 1 EDT} {3939948000 -18000 0 EST} {3950838000 -14400 1 EDT} {3971397600 -18000 0 EST} {3982287600 -14400 1 EDT} {4002847200 -18000 0 EST} {4013737200 -14400 1 EDT} {4034296800 -18000 0 EST} {4045186800 -14400 1 EDT} {4065746400 -18000 0 EST} {4076636400 -14400 1 EDT} {4097196000 -18000 0 EST} } |
Changes to library/tzdata/America/Indiana/Knox.
1 2 3 4 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Indiana/Knox) { {-9223372036854775808 -20790 0 LMT} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Indiana/Knox) { {-9223372036854775808 -20790 0 LMT} {-2717647200 -21600 0 CST} {-1633276800 -18000 1 CDT} {-1615136400 -21600 0 CST} {-1601827200 -18000 1 CDT} {-1583686800 -21600 0 CST} {-880214400 -18000 1 CWT} {-769395600 -18000 1 CPT} {-765392400 -21600 0 CST} |
︙ | ︙ | |||
89 90 91 92 93 94 95 96 | {594198000 -21600 0 CST} {607507200 -18000 1 CDT} {625647600 -21600 0 CST} {638956800 -18000 1 CDT} {657097200 -21600 0 CST} {671011200 -18000 1 CDT} {688550400 -18000 0 EST} } | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | {594198000 -21600 0 CST} {607507200 -18000 1 CDT} {625647600 -21600 0 CST} {638956800 -18000 1 CDT} {657097200 -21600 0 CST} {671011200 -18000 1 CDT} {688550400 -18000 0 EST} {1136091600 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} {1173596400 -14400 1 EDT} {1194156000 -18000 0 EST} {1205046000 -14400 1 EDT} {1225605600 -18000 0 EST} {1236495600 -14400 1 EDT} {1257055200 -18000 0 EST} {1268550000 -14400 1 EDT} {1289109600 -18000 0 EST} {1299999600 -14400 1 EDT} {1320559200 -18000 0 EST} {1331449200 -14400 1 EDT} {1352008800 -18000 0 EST} {1362898800 -14400 1 EDT} {1383458400 -18000 0 EST} {1394348400 -14400 1 EDT} {1414908000 -18000 0 EST} {1425798000 -14400 1 EDT} {1446357600 -18000 0 EST} {1457852400 -14400 1 EDT} {1478412000 -18000 0 EST} {1489302000 -14400 1 EDT} {1509861600 -18000 0 EST} {1520751600 -14400 1 EDT} {1541311200 -18000 0 EST} {1552201200 -14400 1 EDT} {1572760800 -18000 0 EST} {1583650800 -14400 1 EDT} {1604210400 -18000 0 EST} {1615705200 -14400 1 EDT} {1636264800 -18000 0 EST} {1647154800 -14400 1 EDT} {1667714400 -18000 0 EST} {1678604400 -14400 1 EDT} {1699164000 -18000 0 EST} {1710054000 -14400 1 EDT} {1730613600 -18000 0 EST} {1741503600 -14400 1 EDT} {1762063200 -18000 0 EST} {1772953200 -14400 1 EDT} {1793512800 -18000 0 EST} {1805007600 -14400 1 EDT} {1825567200 -18000 0 EST} {1836457200 -14400 1 EDT} {1857016800 -18000 0 EST} {1867906800 -14400 1 EDT} {1888466400 -18000 0 EST} {1899356400 -14400 1 EDT} {1919916000 -18000 0 EST} {1930806000 -14400 1 EDT} {1951365600 -18000 0 EST} {1962860400 -14400 1 EDT} {1983420000 -18000 0 EST} {1994310000 -14400 1 EDT} {2014869600 -18000 0 EST} {2025759600 -14400 1 EDT} {2046319200 -18000 0 EST} {2057209200 -14400 1 EDT} {2077768800 -18000 0 EST} {2088658800 -14400 1 EDT} {2109218400 -18000 0 EST} {2120108400 -14400 1 EDT} {2140668000 -18000 0 EST} {2152162800 -14400 1 EDT} {2172722400 -18000 0 EST} {2183612400 -14400 1 EDT} {2204172000 -18000 0 EST} {2215062000 -14400 1 EDT} {2235621600 -18000 0 EST} {2246511600 -14400 1 EDT} {2267071200 -18000 0 EST} {2277961200 -14400 1 EDT} {2298520800 -18000 0 EST} {2309410800 -14400 1 EDT} {2329970400 -18000 0 EST} {2341465200 -14400 1 EDT} {2362024800 -18000 0 EST} {2372914800 -14400 1 EDT} {2393474400 -18000 0 EST} {2404364400 -14400 1 EDT} {2424924000 -18000 0 EST} {2435814000 -14400 1 EDT} {2456373600 -18000 0 EST} {2467263600 -14400 1 EDT} {2487823200 -18000 0 EST} {2499318000 -14400 1 EDT} {2519877600 -18000 0 EST} {2530767600 -14400 1 EDT} {2551327200 -18000 0 EST} {2562217200 -14400 1 EDT} {2582776800 -18000 0 EST} {2593666800 -14400 1 EDT} {2614226400 -18000 0 EST} {2625116400 -14400 1 EDT} {2645676000 -18000 0 EST} {2656566000 -14400 1 EDT} {2677125600 -18000 0 EST} {2688620400 -14400 1 EDT} {2709180000 -18000 0 EST} {2720070000 -14400 1 EDT} {2740629600 -18000 0 EST} {2751519600 -14400 1 EDT} {2772079200 -18000 0 EST} {2782969200 -14400 1 EDT} {2803528800 -18000 0 EST} {2814418800 -14400 1 EDT} {2834978400 -18000 0 EST} {2846473200 -14400 1 EDT} {2867032800 -18000 0 EST} {2877922800 -14400 1 EDT} {2898482400 -18000 0 EST} {2909372400 -14400 1 EDT} {2929932000 -18000 0 EST} {2940822000 -14400 1 EDT} {2961381600 -18000 0 EST} {2972271600 -14400 1 EDT} {2992831200 -18000 0 EST} {3003721200 -14400 1 EDT} {3024280800 -18000 0 EST} {3035775600 -14400 1 EDT} {3056335200 -18000 0 EST} {3067225200 -14400 1 EDT} {3087784800 -18000 0 EST} {3098674800 -14400 1 EDT} {3119234400 -18000 0 EST} {3130124400 -14400 1 EDT} {3150684000 -18000 0 EST} {3161574000 -14400 1 EDT} {3182133600 -18000 0 EST} {3193023600 -14400 1 EDT} {3213583200 -18000 0 EST} {3225078000 -14400 1 EDT} {3245637600 -18000 0 EST} {3256527600 -14400 1 EDT} {3277087200 -18000 0 EST} {3287977200 -14400 1 EDT} {3308536800 -18000 0 EST} {3319426800 -14400 1 EDT} {3339986400 -18000 0 EST} {3350876400 -14400 1 EDT} {3371436000 -18000 0 EST} {3382930800 -14400 1 EDT} {3403490400 -18000 0 EST} {3414380400 -14400 1 EDT} {3434940000 -18000 0 EST} {3445830000 -14400 1 EDT} {3466389600 -18000 0 EST} {3477279600 -14400 1 EDT} {3497839200 -18000 0 EST} {3508729200 -14400 1 EDT} {3529288800 -18000 0 EST} {3540178800 -14400 1 EDT} {3560738400 -18000 0 EST} {3572233200 -14400 1 EDT} {3592792800 -18000 0 EST} {3603682800 -14400 1 EDT} {3624242400 -18000 0 EST} {3635132400 -14400 1 EDT} {3655692000 -18000 0 EST} {3666582000 -14400 1 EDT} {3687141600 -18000 0 EST} {3698031600 -14400 1 EDT} {3718591200 -18000 0 EST} {3730086000 -14400 1 EDT} {3750645600 -18000 0 EST} {3761535600 -14400 1 EDT} {3782095200 -18000 0 EST} {3792985200 -14400 1 EDT} {3813544800 -18000 0 EST} {3824434800 -14400 1 EDT} {3844994400 -18000 0 EST} {3855884400 -14400 1 EDT} {3876444000 -18000 0 EST} {3887334000 -14400 1 EDT} {3907893600 -18000 0 EST} {3919388400 -14400 1 EDT} {3939948000 -18000 0 EST} {3950838000 -14400 1 EDT} {3971397600 -18000 0 EST} {3982287600 -14400 1 EDT} {4002847200 -18000 0 EST} {4013737200 -14400 1 EDT} {4034296800 -18000 0 EST} {4045186800 -14400 1 EDT} {4065746400 -18000 0 EST} {4076636400 -14400 1 EDT} {4097196000 -18000 0 EST} } |
Changes to library/tzdata/America/Indiana/Marengo.
1 2 3 4 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Indiana/Marengo) { {-9223372036854775808 -20723 0 LMT} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Indiana/Marengo) { {-9223372036854775808 -20723 0 LMT} {-2717647200 -21600 0 CST} {-1633276800 -18000 1 CDT} {-1615136400 -21600 0 CST} {-1601827200 -18000 1 CDT} {-1583686800 -21600 0 CST} {-880214400 -18000 1 CWT} {-769395600 -18000 1 CPT} {-765392400 -21600 0 CST} |
︙ | ︙ | |||
40 41 42 43 44 45 46 47 | {104914800 -14400 1 EDT} {120636000 -18000 0 EST} {126687600 -18000 1 CDT} {152089200 -18000 0 EST} {162370800 -14400 1 EDT} {183535200 -18000 0 EST} {189320400 -18000 0 EST} } | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | {104914800 -14400 1 EDT} {120636000 -18000 0 EST} {126687600 -18000 1 CDT} {152089200 -18000 0 EST} {162370800 -14400 1 EDT} {183535200 -18000 0 EST} {189320400 -18000 0 EST} {1136091600 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} {1173596400 -14400 1 EDT} {1194156000 -18000 0 EST} {1205046000 -14400 1 EDT} {1225605600 -18000 0 EST} {1236495600 -14400 1 EDT} {1257055200 -18000 0 EST} {1268550000 -14400 1 EDT} {1289109600 -18000 0 EST} {1299999600 -14400 1 EDT} {1320559200 -18000 0 EST} {1331449200 -14400 1 EDT} {1352008800 -18000 0 EST} {1362898800 -14400 1 EDT} {1383458400 -18000 0 EST} {1394348400 -14400 1 EDT} {1414908000 -18000 0 EST} {1425798000 -14400 1 EDT} {1446357600 -18000 0 EST} {1457852400 -14400 1 EDT} {1478412000 -18000 0 EST} {1489302000 -14400 1 EDT} {1509861600 -18000 0 EST} {1520751600 -14400 1 EDT} {1541311200 -18000 0 EST} {1552201200 -14400 1 EDT} {1572760800 -18000 0 EST} {1583650800 -14400 1 EDT} {1604210400 -18000 0 EST} {1615705200 -14400 1 EDT} {1636264800 -18000 0 EST} {1647154800 -14400 1 EDT} {1667714400 -18000 0 EST} {1678604400 -14400 1 EDT} {1699164000 -18000 0 EST} {1710054000 -14400 1 EDT} {1730613600 -18000 0 EST} {1741503600 -14400 1 EDT} {1762063200 -18000 0 EST} {1772953200 -14400 1 EDT} {1793512800 -18000 0 EST} {1805007600 -14400 1 EDT} {1825567200 -18000 0 EST} {1836457200 -14400 1 EDT} {1857016800 -18000 0 EST} {1867906800 -14400 1 EDT} {1888466400 -18000 0 EST} {1899356400 -14400 1 EDT} {1919916000 -18000 0 EST} {1930806000 -14400 1 EDT} {1951365600 -18000 0 EST} {1962860400 -14400 1 EDT} {1983420000 -18000 0 EST} {1994310000 -14400 1 EDT} {2014869600 -18000 0 EST} {2025759600 -14400 1 EDT} {2046319200 -18000 0 EST} {2057209200 -14400 1 EDT} {2077768800 -18000 0 EST} {2088658800 -14400 1 EDT} {2109218400 -18000 0 EST} {2120108400 -14400 1 EDT} {2140668000 -18000 0 EST} {2152162800 -14400 1 EDT} {2172722400 -18000 0 EST} {2183612400 -14400 1 EDT} {2204172000 -18000 0 EST} {2215062000 -14400 1 EDT} {2235621600 -18000 0 EST} {2246511600 -14400 1 EDT} {2267071200 -18000 0 EST} {2277961200 -14400 1 EDT} {2298520800 -18000 0 EST} {2309410800 -14400 1 EDT} {2329970400 -18000 0 EST} {2341465200 -14400 1 EDT} {2362024800 -18000 0 EST} {2372914800 -14400 1 EDT} {2393474400 -18000 0 EST} {2404364400 -14400 1 EDT} {2424924000 -18000 0 EST} {2435814000 -14400 1 EDT} {2456373600 -18000 0 EST} {2467263600 -14400 1 EDT} {2487823200 -18000 0 EST} {2499318000 -14400 1 EDT} {2519877600 -18000 0 EST} {2530767600 -14400 1 EDT} {2551327200 -18000 0 EST} {2562217200 -14400 1 EDT} {2582776800 -18000 0 EST} {2593666800 -14400 1 EDT} {2614226400 -18000 0 EST} {2625116400 -14400 1 EDT} {2645676000 -18000 0 EST} {2656566000 -14400 1 EDT} {2677125600 -18000 0 EST} {2688620400 -14400 1 EDT} {2709180000 -18000 0 EST} {2720070000 -14400 1 EDT} {2740629600 -18000 0 EST} {2751519600 -14400 1 EDT} {2772079200 -18000 0 EST} {2782969200 -14400 1 EDT} {2803528800 -18000 0 EST} {2814418800 -14400 1 EDT} {2834978400 -18000 0 EST} {2846473200 -14400 1 EDT} {2867032800 -18000 0 EST} {2877922800 -14400 1 EDT} {2898482400 -18000 0 EST} {2909372400 -14400 1 EDT} {2929932000 -18000 0 EST} {2940822000 -14400 1 EDT} {2961381600 -18000 0 EST} {2972271600 -14400 1 EDT} {2992831200 -18000 0 EST} {3003721200 -14400 1 EDT} {3024280800 -18000 0 EST} {3035775600 -14400 1 EDT} {3056335200 -18000 0 EST} {3067225200 -14400 1 EDT} {3087784800 -18000 0 EST} {3098674800 -14400 1 EDT} {3119234400 -18000 0 EST} {3130124400 -14400 1 EDT} {3150684000 -18000 0 EST} {3161574000 -14400 1 EDT} {3182133600 -18000 0 EST} {3193023600 -14400 1 EDT} {3213583200 -18000 0 EST} {3225078000 -14400 1 EDT} {3245637600 -18000 0 EST} {3256527600 -14400 1 EDT} {3277087200 -18000 0 EST} {3287977200 -14400 1 EDT} {3308536800 -18000 0 EST} {3319426800 -14400 1 EDT} {3339986400 -18000 0 EST} {3350876400 -14400 1 EDT} {3371436000 -18000 0 EST} {3382930800 -14400 1 EDT} {3403490400 -18000 0 EST} {3414380400 -14400 1 EDT} {3434940000 -18000 0 EST} {3445830000 -14400 1 EDT} {3466389600 -18000 0 EST} {3477279600 -14400 1 EDT} {3497839200 -18000 0 EST} {3508729200 -14400 1 EDT} {3529288800 -18000 0 EST} {3540178800 -14400 1 EDT} {3560738400 -18000 0 EST} {3572233200 -14400 1 EDT} {3592792800 -18000 0 EST} {3603682800 -14400 1 EDT} {3624242400 -18000 0 EST} {3635132400 -14400 1 EDT} {3655692000 -18000 0 EST} {3666582000 -14400 1 EDT} {3687141600 -18000 0 EST} {3698031600 -14400 1 EDT} {3718591200 -18000 0 EST} {3730086000 -14400 1 EDT} {3750645600 -18000 0 EST} {3761535600 -14400 1 EDT} {3782095200 -18000 0 EST} {3792985200 -14400 1 EDT} {3813544800 -18000 0 EST} {3824434800 -14400 1 EDT} {3844994400 -18000 0 EST} {3855884400 -14400 1 EDT} {3876444000 -18000 0 EST} {3887334000 -14400 1 EDT} {3907893600 -18000 0 EST} {3919388400 -14400 1 EDT} {3939948000 -18000 0 EST} {3950838000 -14400 1 EDT} {3971397600 -18000 0 EST} {3982287600 -14400 1 EDT} {4002847200 -18000 0 EST} {4013737200 -14400 1 EDT} {4034296800 -18000 0 EST} {4045186800 -14400 1 EDT} {4065746400 -18000 0 EST} {4076636400 -14400 1 EDT} {4097196000 -18000 0 EST} } |
Changes to library/tzdata/America/Indiana/Vevay.
1 2 3 4 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Indiana/Vevay) { {-9223372036854775808 -20416 0 LMT} | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Indiana/Vevay) { {-9223372036854775808 -20416 0 LMT} {-2717647200 -21600 0 CST} {-1633276800 -18000 1 CDT} {-1615136400 -21600 0 CST} {-1601827200 -18000 1 CDT} {-1583686800 -21600 0 CST} {-880214400 -18000 1 CWT} {-769395600 -18000 1 CPT} {-765392400 -21600 0 CST} {-495043200 -18000 0 EST} {-31518000 -18000 0 EST} {-21488400 -14400 1 EDT} {-5767200 -18000 0 EST} {9961200 -14400 1 EDT} {25682400 -18000 0 EST} {41410800 -14400 1 EDT} {57736800 -18000 0 EST} {73465200 -14400 1 EDT} {89186400 -18000 0 EST} {94712400 -18000 0 EST} {1136091600 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} {1173596400 -14400 1 EDT} {1194156000 -18000 0 EST} {1205046000 -14400 1 EDT} {1225605600 -18000 0 EST} {1236495600 -14400 1 EDT} {1257055200 -18000 0 EST} {1268550000 -14400 1 EDT} {1289109600 -18000 0 EST} {1299999600 -14400 1 EDT} {1320559200 -18000 0 EST} {1331449200 -14400 1 EDT} {1352008800 -18000 0 EST} {1362898800 -14400 1 EDT} {1383458400 -18000 0 EST} {1394348400 -14400 1 EDT} {1414908000 -18000 0 EST} {1425798000 -14400 1 EDT} {1446357600 -18000 0 EST} {1457852400 -14400 1 EDT} {1478412000 -18000 0 EST} {1489302000 -14400 1 EDT} {1509861600 -18000 0 EST} {1520751600 -14400 1 EDT} {1541311200 -18000 0 EST} {1552201200 -14400 1 EDT} {1572760800 -18000 0 EST} {1583650800 -14400 1 EDT} {1604210400 -18000 0 EST} {1615705200 -14400 1 EDT} {1636264800 -18000 0 EST} {1647154800 -14400 1 EDT} {1667714400 -18000 0 EST} {1678604400 -14400 1 EDT} {1699164000 -18000 0 EST} {1710054000 -14400 1 EDT} {1730613600 -18000 0 EST} {1741503600 -14400 1 EDT} {1762063200 -18000 0 EST} {1772953200 -14400 1 EDT} {1793512800 -18000 0 EST} {1805007600 -14400 1 EDT} {1825567200 -18000 0 EST} {1836457200 -14400 1 EDT} {1857016800 -18000 0 EST} {1867906800 -14400 1 EDT} {1888466400 -18000 0 EST} {1899356400 -14400 1 EDT} {1919916000 -18000 0 EST} {1930806000 -14400 1 EDT} {1951365600 -18000 0 EST} {1962860400 -14400 1 EDT} {1983420000 -18000 0 EST} {1994310000 -14400 1 EDT} {2014869600 -18000 0 EST} {2025759600 -14400 1 EDT} {2046319200 -18000 0 EST} {2057209200 -14400 1 EDT} {2077768800 -18000 0 EST} {2088658800 -14400 1 EDT} {2109218400 -18000 0 EST} {2120108400 -14400 1 EDT} {2140668000 -18000 0 EST} {2152162800 -14400 1 EDT} {2172722400 -18000 0 EST} {2183612400 -14400 1 EDT} {2204172000 -18000 0 EST} {2215062000 -14400 1 EDT} {2235621600 -18000 0 EST} {2246511600 -14400 1 EDT} {2267071200 -18000 0 EST} {2277961200 -14400 1 EDT} {2298520800 -18000 0 EST} {2309410800 -14400 1 EDT} {2329970400 -18000 0 EST} {2341465200 -14400 1 EDT} {2362024800 -18000 0 EST} {2372914800 -14400 1 EDT} {2393474400 -18000 0 EST} {2404364400 -14400 1 EDT} {2424924000 -18000 0 EST} {2435814000 -14400 1 EDT} {2456373600 -18000 0 EST} {2467263600 -14400 1 EDT} {2487823200 -18000 0 EST} {2499318000 -14400 1 EDT} {2519877600 -18000 0 EST} {2530767600 -14400 1 EDT} {2551327200 -18000 0 EST} {2562217200 -14400 1 EDT} {2582776800 -18000 0 EST} {2593666800 -14400 1 EDT} {2614226400 -18000 0 EST} {2625116400 -14400 1 EDT} {2645676000 -18000 0 EST} {2656566000 -14400 1 EDT} {2677125600 -18000 0 EST} {2688620400 -14400 1 EDT} {2709180000 -18000 0 EST} {2720070000 -14400 1 EDT} {2740629600 -18000 0 EST} {2751519600 -14400 1 EDT} {2772079200 -18000 0 EST} {2782969200 -14400 1 EDT} {2803528800 -18000 0 EST} {2814418800 -14400 1 EDT} {2834978400 -18000 0 EST} {2846473200 -14400 1 EDT} {2867032800 -18000 0 EST} {2877922800 -14400 1 EDT} {2898482400 -18000 0 EST} {2909372400 -14400 1 EDT} {2929932000 -18000 0 EST} {2940822000 -14400 1 EDT} {2961381600 -18000 0 EST} {2972271600 -14400 1 EDT} {2992831200 -18000 0 EST} {3003721200 -14400 1 EDT} {3024280800 -18000 0 EST} {3035775600 -14400 1 EDT} {3056335200 -18000 0 EST} {3067225200 -14400 1 EDT} {3087784800 -18000 0 EST} {3098674800 -14400 1 EDT} {3119234400 -18000 0 EST} {3130124400 -14400 1 EDT} {3150684000 -18000 0 EST} {3161574000 -14400 1 EDT} {3182133600 -18000 0 EST} {3193023600 -14400 1 EDT} {3213583200 -18000 0 EST} {3225078000 -14400 1 EDT} {3245637600 -18000 0 EST} {3256527600 -14400 1 EDT} {3277087200 -18000 0 EST} {3287977200 -14400 1 EDT} {3308536800 -18000 0 EST} {3319426800 -14400 1 EDT} {3339986400 -18000 0 EST} {3350876400 -14400 1 EDT} {3371436000 -18000 0 EST} {3382930800 -14400 1 EDT} {3403490400 -18000 0 EST} {3414380400 -14400 1 EDT} {3434940000 -18000 0 EST} {3445830000 -14400 1 EDT} {3466389600 -18000 0 EST} {3477279600 -14400 1 EDT} {3497839200 -18000 0 EST} {3508729200 -14400 1 EDT} {3529288800 -18000 0 EST} {3540178800 -14400 1 EDT} {3560738400 -18000 0 EST} {3572233200 -14400 1 EDT} {3592792800 -18000 0 EST} {3603682800 -14400 1 EDT} {3624242400 -18000 0 EST} {3635132400 -14400 1 EDT} {3655692000 -18000 0 EST} {3666582000 -14400 1 EDT} {3687141600 -18000 0 EST} {3698031600 -14400 1 EDT} {3718591200 -18000 0 EST} {3730086000 -14400 1 EDT} {3750645600 -18000 0 EST} {3761535600 -14400 1 EDT} {3782095200 -18000 0 EST} {3792985200 -14400 1 EDT} {3813544800 -18000 0 EST} {3824434800 -14400 1 EDT} {3844994400 -18000 0 EST} {3855884400 -14400 1 EDT} {3876444000 -18000 0 EST} {3887334000 -14400 1 EDT} {3907893600 -18000 0 EST} {3919388400 -14400 1 EDT} {3939948000 -18000 0 EST} {3950838000 -14400 1 EDT} {3971397600 -18000 0 EST} {3982287600 -14400 1 EDT} {4002847200 -18000 0 EST} {4013737200 -14400 1 EDT} {4034296800 -18000 0 EST} {4045186800 -14400 1 EDT} {4065746400 -18000 0 EST} {4076636400 -14400 1 EDT} {4097196000 -18000 0 EST} } |
Changes to library/tzdata/America/Indianapolis.
1 | # created by ../tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(America/Indiana/Indianapolis)]} { LoadTimeZoneFile America/Indiana/Indianapolis } set TZData(:America/Indianapolis) $TZData(:America/Indiana/Indianapolis) |
Changes to library/tzdata/America/Juneau.
︙ | ︙ | |||
82 83 84 85 86 87 88 | {1067162400 -32400 0 AKST} {1081076400 -28800 1 AKDT} {1099216800 -32400 0 AKST} {1112526000 -28800 1 AKDT} {1130666400 -32400 0 AKST} {1143975600 -28800 1 AKDT} {1162116000 -32400 0 AKST} | | | | | | | | < < | | | | | | | | | | | | < < | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | > > | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | 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 | {1067162400 -32400 0 AKST} {1081076400 -28800 1 AKDT} {1099216800 -32400 0 AKST} {1112526000 -28800 1 AKDT} {1130666400 -32400 0 AKST} {1143975600 -28800 1 AKDT} {1162116000 -32400 0 AKST} {1173610800 -28800 1 AKDT} {1194170400 -32400 0 AKST} {1205060400 -28800 1 AKDT} {1225620000 -32400 0 AKST} {1236510000 -28800 1 AKDT} {1257069600 -32400 0 AKST} {1268564400 -28800 1 AKDT} {1289124000 -32400 0 AKST} {1300014000 -28800 1 AKDT} {1320573600 -32400 0 AKST} {1331463600 -28800 1 AKDT} {1352023200 -32400 0 AKST} {1362913200 -28800 1 AKDT} {1383472800 -32400 0 AKST} {1394362800 -28800 1 AKDT} {1414922400 -32400 0 AKST} {1425812400 -28800 1 AKDT} {1446372000 -32400 0 AKST} {1457866800 -28800 1 AKDT} {1478426400 -32400 0 AKST} {1489316400 -28800 1 AKDT} {1509876000 -32400 0 AKST} {1520766000 -28800 1 AKDT} {1541325600 -32400 0 AKST} {1552215600 -28800 1 AKDT} {1572775200 -32400 0 AKST} {1583665200 -28800 1 AKDT} {1604224800 -32400 0 AKST} {1615719600 -28800 1 AKDT} {1636279200 -32400 0 AKST} {1647169200 -28800 1 AKDT} {1667728800 -32400 0 AKST} {1678618800 -28800 1 AKDT} {1699178400 -32400 0 AKST} {1710068400 -28800 1 AKDT} {1730628000 -32400 0 AKST} {1741518000 -28800 1 AKDT} {1762077600 -32400 0 AKST} {1772967600 -28800 1 AKDT} {1793527200 -32400 0 AKST} {1805022000 -28800 1 AKDT} {1825581600 -32400 0 AKST} {1836471600 -28800 1 AKDT} {1857031200 -32400 0 AKST} {1867921200 -28800 1 AKDT} {1888480800 -32400 0 AKST} {1899370800 -28800 1 AKDT} {1919930400 -32400 0 AKST} {1930820400 -28800 1 AKDT} {1951380000 -32400 0 AKST} {1962874800 -28800 1 AKDT} {1983434400 -32400 0 AKST} {1994324400 -28800 1 AKDT} {2014884000 -32400 0 AKST} {2025774000 -28800 1 AKDT} {2046333600 -32400 0 AKST} {2057223600 -28800 1 AKDT} {2077783200 -32400 0 AKST} {2088673200 -28800 1 AKDT} {2109232800 -32400 0 AKST} {2120122800 -28800 1 AKDT} {2140682400 -32400 0 AKST} {2152177200 -28800 1 AKDT} {2172736800 -32400 0 AKST} {2183626800 -28800 1 AKDT} {2204186400 -32400 0 AKST} {2215076400 -28800 1 AKDT} {2235636000 -32400 0 AKST} {2246526000 -28800 1 AKDT} {2267085600 -32400 0 AKST} {2277975600 -28800 1 AKDT} {2298535200 -32400 0 AKST} {2309425200 -28800 1 AKDT} {2329984800 -32400 0 AKST} {2341479600 -28800 1 AKDT} {2362039200 -32400 0 AKST} {2372929200 -28800 1 AKDT} {2393488800 -32400 0 AKST} {2404378800 -28800 1 AKDT} {2424938400 -32400 0 AKST} {2435828400 -28800 1 AKDT} {2456388000 -32400 0 AKST} {2467278000 -28800 1 AKDT} {2487837600 -32400 0 AKST} {2499332400 -28800 1 AKDT} {2519892000 -32400 0 AKST} {2530782000 -28800 1 AKDT} {2551341600 -32400 0 AKST} {2562231600 -28800 1 AKDT} {2582791200 -32400 0 AKST} {2593681200 -28800 1 AKDT} {2614240800 -32400 0 AKST} {2625130800 -28800 1 AKDT} {2645690400 -32400 0 AKST} {2656580400 -28800 1 AKDT} {2677140000 -32400 0 AKST} {2688634800 -28800 1 AKDT} {2709194400 -32400 0 AKST} {2720084400 -28800 1 AKDT} {2740644000 -32400 0 AKST} {2751534000 -28800 1 AKDT} {2772093600 -32400 0 AKST} {2782983600 -28800 1 AKDT} {2803543200 -32400 0 AKST} {2814433200 -28800 1 AKDT} {2834992800 -32400 0 AKST} {2846487600 -28800 1 AKDT} {2867047200 -32400 0 AKST} {2877937200 -28800 1 AKDT} {2898496800 -32400 0 AKST} {2909386800 -28800 1 AKDT} {2929946400 -32400 0 AKST} {2940836400 -28800 1 AKDT} {2961396000 -32400 0 AKST} {2972286000 -28800 1 AKDT} {2992845600 -32400 0 AKST} {3003735600 -28800 1 AKDT} {3024295200 -32400 0 AKST} {3035790000 -28800 1 AKDT} {3056349600 -32400 0 AKST} {3067239600 -28800 1 AKDT} {3087799200 -32400 0 AKST} {3098689200 -28800 1 AKDT} {3119248800 -32400 0 AKST} {3130138800 -28800 1 AKDT} {3150698400 -32400 0 AKST} {3161588400 -28800 1 AKDT} {3182148000 -32400 0 AKST} {3193038000 -28800 1 AKDT} {3213597600 -32400 0 AKST} {3225092400 -28800 1 AKDT} {3245652000 -32400 0 AKST} {3256542000 -28800 1 AKDT} {3277101600 -32400 0 AKST} {3287991600 -28800 1 AKDT} {3308551200 -32400 0 AKST} {3319441200 -28800 1 AKDT} {3340000800 -32400 0 AKST} {3350890800 -28800 1 AKDT} {3371450400 -32400 0 AKST} {3382945200 -28800 1 AKDT} {3403504800 -32400 0 AKST} {3414394800 -28800 1 AKDT} {3434954400 -32400 0 AKST} {3445844400 -28800 1 AKDT} {3466404000 -32400 0 AKST} {3477294000 -28800 1 AKDT} {3497853600 -32400 0 AKST} {3508743600 -28800 1 AKDT} {3529303200 -32400 0 AKST} {3540193200 -28800 1 AKDT} {3560752800 -32400 0 AKST} {3572247600 -28800 1 AKDT} {3592807200 -32400 0 AKST} {3603697200 -28800 1 AKDT} {3624256800 -32400 0 AKST} {3635146800 -28800 1 AKDT} {3655706400 -32400 0 AKST} {3666596400 -28800 1 AKDT} {3687156000 -32400 0 AKST} {3698046000 -28800 1 AKDT} {3718605600 -32400 0 AKST} {3730100400 -28800 1 AKDT} {3750660000 -32400 0 AKST} {3761550000 -28800 1 AKDT} {3782109600 -32400 0 AKST} {3792999600 -28800 1 AKDT} {3813559200 -32400 0 AKST} {3824449200 -28800 1 AKDT} {3845008800 -32400 0 AKST} {3855898800 -28800 1 AKDT} {3876458400 -32400 0 AKST} {3887348400 -28800 1 AKDT} {3907908000 -32400 0 AKST} {3919402800 -28800 1 AKDT} {3939962400 -32400 0 AKST} {3950852400 -28800 1 AKDT} {3971412000 -32400 0 AKST} {3982302000 -28800 1 AKDT} {4002861600 -32400 0 AKST} {4013751600 -28800 1 AKDT} {4034311200 -32400 0 AKST} {4045201200 -28800 1 AKDT} {4065760800 -32400 0 AKST} {4076650800 -28800 1 AKDT} {4097210400 -32400 0 AKST} } |
Changes to library/tzdata/America/Kentucky/Louisville.
1 | # created by ../tools/tclZIC.tcl - do not edit | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | 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 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Kentucky/Louisville) { {-9223372036854775808 -20582 0 LMT} {-2717647200 -21600 0 CST} {-1633276800 -18000 1 CDT} {-1615136400 -21600 0 CST} {-1601827200 -18000 1 CDT} {-1583686800 -21600 0 CST} {-1546279200 -21600 0 CST} {-1535904000 -18000 1 CDT} {-1525280400 -21600 0 CST} {-905097600 -18000 1 CDT} {-891795600 -21600 0 CST} {-883591200 -21600 0 CST} {-880214400 -18000 1 CWT} {-769395600 -18000 1 CPT} {-765392400 -21600 0 CST} {-757360800 -21600 0 CST} {-747244800 -18000 1 CDT} {-744224400 -21600 0 CST} {-715795200 -18000 1 CDT} {-684349200 -18000 1 CDT} {-652899600 -18000 1 CDT} {-620845200 -18000 1 CDT} {-608144400 -21600 0 CST} {-589392000 -18000 1 CDT} {-576090000 -21600 0 CST} {-557942400 -18000 1 CDT} {-544640400 -21600 0 CST} {-526492800 -18000 1 CDT} {-513190800 -21600 0 CST} {-495043200 -18000 1 CDT} {-481741200 -21600 0 CST} {-463593600 -18000 1 CDT} {-450291600 -21600 0 CST} {-431539200 -18000 1 CDT} {-415818000 -21600 0 CST} {-400089600 -18000 1 CDT} {-384368400 -21600 0 CST} {-368640000 -18000 1 CDT} {-352918800 -21600 0 CST} {-337190400 -18000 1 CDT} {-321469200 -21600 0 CST} {-305740800 -18000 1 CDT} {-289414800 -21600 0 CST} {-273686400 -18000 1 CDT} {-266432400 -18000 0 EST} {-63140400 -18000 0 EST} {-52938000 -14400 1 EDT} {-37216800 -18000 0 EST} {-21488400 -14400 1 EDT} {-5767200 -18000 0 EST} {9961200 -14400 1 EDT} {25682400 -18000 0 EST} {41410800 -14400 1 EDT} {57736800 -18000 0 EST} {73465200 -14400 1 EDT} {89186400 -18000 0 EST} {104914800 -14400 1 EDT} {120636000 -18000 0 EST} {126687600 -18000 1 CDT} {152089200 -18000 0 EST} {162370800 -14400 1 EDT} {183535200 -18000 0 EST} {199263600 -14400 1 EDT} {215589600 -18000 0 EST} {230713200 -14400 1 EDT} {247039200 -18000 0 EST} {262767600 -14400 1 EDT} {278488800 -18000 0 EST} {294217200 -14400 1 EDT} {309938400 -18000 0 EST} {325666800 -14400 1 EDT} {341388000 -18000 0 EST} {357116400 -14400 1 EDT} {372837600 -18000 0 EST} {388566000 -14400 1 EDT} {404892000 -18000 0 EST} {420015600 -14400 1 EDT} {436341600 -18000 0 EST} {452070000 -14400 1 EDT} {467791200 -18000 0 EST} {483519600 -14400 1 EDT} {499240800 -18000 0 EST} {514969200 -14400 1 EDT} {530690400 -18000 0 EST} {544604400 -14400 1 EDT} {562140000 -18000 0 EST} {576054000 -14400 1 EDT} {594194400 -18000 0 EST} {607503600 -14400 1 EDT} {625644000 -18000 0 EST} {638953200 -14400 1 EDT} {657093600 -18000 0 EST} {671007600 -14400 1 EDT} {688543200 -18000 0 EST} {702457200 -14400 1 EDT} {719992800 -18000 0 EST} {733906800 -14400 1 EDT} {752047200 -18000 0 EST} {765356400 -14400 1 EDT} {783496800 -18000 0 EST} {796806000 -14400 1 EDT} {814946400 -18000 0 EST} {828860400 -14400 1 EDT} {846396000 -18000 0 EST} {860310000 -14400 1 EDT} {877845600 -18000 0 EST} {891759600 -14400 1 EDT} {909295200 -18000 0 EST} {923209200 -14400 1 EDT} {941349600 -18000 0 EST} {954658800 -14400 1 EDT} {972799200 -18000 0 EST} {986108400 -14400 1 EDT} {1004248800 -18000 0 EST} {1018162800 -14400 1 EDT} {1035698400 -18000 0 EST} {1049612400 -14400 1 EDT} {1067148000 -18000 0 EST} {1081062000 -14400 1 EDT} {1099202400 -18000 0 EST} {1112511600 -14400 1 EDT} {1130652000 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} {1173596400 -14400 1 EDT} {1194156000 -18000 0 EST} {1205046000 -14400 1 EDT} {1225605600 -18000 0 EST} {1236495600 -14400 1 EDT} {1257055200 -18000 0 EST} {1268550000 -14400 1 EDT} {1289109600 -18000 0 EST} {1299999600 -14400 1 EDT} {1320559200 -18000 0 EST} {1331449200 -14400 1 EDT} {1352008800 -18000 0 EST} {1362898800 -14400 1 EDT} {1383458400 -18000 0 EST} {1394348400 -14400 1 EDT} {1414908000 -18000 0 EST} {1425798000 -14400 1 EDT} {1446357600 -18000 0 EST} {1457852400 -14400 1 EDT} {1478412000 -18000 0 EST} {1489302000 -14400 1 EDT} {1509861600 -18000 0 EST} {1520751600 -14400 1 EDT} {1541311200 -18000 0 EST} {1552201200 -14400 1 EDT} {1572760800 -18000 0 EST} {1583650800 -14400 1 EDT} {1604210400 -18000 0 EST} {1615705200 -14400 1 EDT} {1636264800 -18000 0 EST} {1647154800 -14400 1 EDT} {1667714400 -18000 0 EST} {1678604400 -14400 1 EDT} {1699164000 -18000 0 EST} {1710054000 -14400 1 EDT} {1730613600 -18000 0 EST} {1741503600 -14400 1 EDT} {1762063200 -18000 0 EST} {1772953200 -14400 1 EDT} {1793512800 -18000 0 EST} {1805007600 -14400 1 EDT} {1825567200 -18000 0 EST} {1836457200 -14400 1 EDT} {1857016800 -18000 0 EST} {1867906800 -14400 1 EDT} {1888466400 -18000 0 EST} {1899356400 -14400 1 EDT} {1919916000 -18000 0 EST} {1930806000 -14400 1 EDT} {1951365600 -18000 0 EST} {1962860400 -14400 1 EDT} {1983420000 -18000 0 EST} {1994310000 -14400 1 EDT} {2014869600 -18000 0 EST} {2025759600 -14400 1 EDT} {2046319200 -18000 0 EST} {2057209200 -14400 1 EDT} {2077768800 -18000 0 EST} {2088658800 -14400 1 EDT} {2109218400 -18000 0 EST} {2120108400 -14400 1 EDT} {2140668000 -18000 0 EST} {2152162800 -14400 1 EDT} {2172722400 -18000 0 EST} {2183612400 -14400 1 EDT} {2204172000 -18000 0 EST} {2215062000 -14400 1 EDT} {2235621600 -18000 0 EST} {2246511600 -14400 1 EDT} {2267071200 -18000 0 EST} {2277961200 -14400 1 EDT} {2298520800 -18000 0 EST} {2309410800 -14400 1 EDT} {2329970400 -18000 0 EST} {2341465200 -14400 1 EDT} {2362024800 -18000 0 EST} {2372914800 -14400 1 EDT} {2393474400 -18000 0 EST} {2404364400 -14400 1 EDT} {2424924000 -18000 0 EST} {2435814000 -14400 1 EDT} {2456373600 -18000 0 EST} {2467263600 -14400 1 EDT} {2487823200 -18000 0 EST} {2499318000 -14400 1 EDT} {2519877600 -18000 0 EST} {2530767600 -14400 1 EDT} {2551327200 -18000 0 EST} {2562217200 -14400 1 EDT} {2582776800 -18000 0 EST} {2593666800 -14400 1 EDT} {2614226400 -18000 0 EST} {2625116400 -14400 1 EDT} {2645676000 -18000 0 EST} {2656566000 -14400 1 EDT} {2677125600 -18000 0 EST} {2688620400 -14400 1 EDT} {2709180000 -18000 0 EST} {2720070000 -14400 1 EDT} {2740629600 -18000 0 EST} {2751519600 -14400 1 EDT} {2772079200 -18000 0 EST} {2782969200 -14400 1 EDT} {2803528800 -18000 0 EST} {2814418800 -14400 1 EDT} {2834978400 -18000 0 EST} {2846473200 -14400 1 EDT} {2867032800 -18000 0 EST} {2877922800 -14400 1 EDT} {2898482400 -18000 0 EST} {2909372400 -14400 1 EDT} {2929932000 -18000 0 EST} {2940822000 -14400 1 EDT} {2961381600 -18000 0 EST} {2972271600 -14400 1 EDT} {2992831200 -18000 0 EST} {3003721200 -14400 1 EDT} {3024280800 -18000 0 EST} {3035775600 -14400 1 EDT} {3056335200 -18000 0 EST} {3067225200 -14400 1 EDT} {3087784800 -18000 0 EST} {3098674800 -14400 1 EDT} {3119234400 -18000 0 EST} {3130124400 -14400 1 EDT} {3150684000 -18000 0 EST} {3161574000 -14400 1 EDT} {3182133600 -18000 0 EST} {3193023600 -14400 1 EDT} {3213583200 -18000 0 EST} {3225078000 -14400 1 EDT} {3245637600 -18000 0 EST} {3256527600 -14400 1 EDT} {3277087200 -18000 0 EST} {3287977200 -14400 1 EDT} {3308536800 -18000 0 EST} {3319426800 -14400 1 EDT} {3339986400 -18000 0 EST} {3350876400 -14400 1 EDT} {3371436000 -18000 0 EST} {3382930800 -14400 1 EDT} {3403490400 -18000 0 EST} {3414380400 -14400 1 EDT} {3434940000 -18000 0 EST} {3445830000 -14400 1 EDT} {3466389600 -18000 0 EST} {3477279600 -14400 1 EDT} {3497839200 -18000 0 EST} {3508729200 -14400 1 EDT} {3529288800 -18000 0 EST} {3540178800 -14400 1 EDT} {3560738400 -18000 0 EST} {3572233200 -14400 1 EDT} {3592792800 -18000 0 EST} {3603682800 -14400 1 EDT} {3624242400 -18000 0 EST} {3635132400 -14400 1 EDT} {3655692000 -18000 0 EST} {3666582000 -14400 1 EDT} {3687141600 -18000 0 EST} {3698031600 -14400 1 EDT} {3718591200 -18000 0 EST} {3730086000 -14400 1 EDT} {3750645600 -18000 0 EST} {3761535600 -14400 1 EDT} {3782095200 -18000 0 EST} {3792985200 -14400 1 EDT} {3813544800 -18000 0 EST} {3824434800 -14400 1 EDT} {3844994400 -18000 0 EST} {3855884400 -14400 1 EDT} {3876444000 -18000 0 EST} {3887334000 -14400 1 EDT} {3907893600 -18000 0 EST} {3919388400 -14400 1 EDT} {3939948000 -18000 0 EST} {3950838000 -14400 1 EDT} {3971397600 -18000 0 EST} {3982287600 -14400 1 EDT} {4002847200 -18000 0 EST} {4013737200 -14400 1 EDT} {4034296800 -18000 0 EST} {4045186800 -14400 1 EDT} {4065746400 -18000 0 EST} {4076636400 -14400 1 EDT} {4097196000 -18000 0 EST} } |
Changes to library/tzdata/America/Kentucky/Monticello.
1 2 3 4 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Kentucky/Monticello) { {-9223372036854775808 -20364 0 LMT} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Kentucky/Monticello) { {-9223372036854775808 -20364 0 LMT} {-2717647200 -21600 0 CST} {-1633276800 -18000 1 CDT} {-1615136400 -21600 0 CST} {-1601827200 -18000 1 CDT} {-1583686800 -21600 0 CST} {-880214400 -18000 1 CWT} {-769395600 -18000 1 CPT} {-765392400 -21600 0 CST} |
︙ | ︙ | |||
86 87 88 89 90 91 92 | {1067148000 -18000 0 EST} {1081062000 -14400 1 EDT} {1099202400 -18000 0 EST} {1112511600 -14400 1 EDT} {1130652000 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} | | | > > | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | > > | | | | | | | | | | > > | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | {1067148000 -18000 0 EST} {1081062000 -14400 1 EDT} {1099202400 -18000 0 EST} {1112511600 -14400 1 EDT} {1130652000 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} {1173596400 -14400 1 EDT} {1194156000 -18000 0 EST} {1205046000 -14400 1 EDT} {1225605600 -18000 0 EST} {1236495600 -14400 1 EDT} {1257055200 -18000 0 EST} {1268550000 -14400 1 EDT} {1289109600 -18000 0 EST} {1299999600 -14400 1 EDT} {1320559200 -18000 0 EST} {1331449200 -14400 1 EDT} {1352008800 -18000 0 EST} {1362898800 -14400 1 EDT} {1383458400 -18000 0 EST} {1394348400 -14400 1 EDT} {1414908000 -18000 0 EST} {1425798000 -14400 1 EDT} {1446357600 -18000 0 EST} {1457852400 -14400 1 EDT} {1478412000 -18000 0 EST} {1489302000 -14400 1 EDT} {1509861600 -18000 0 EST} {1520751600 -14400 1 EDT} {1541311200 -18000 0 EST} {1552201200 -14400 1 EDT} {1572760800 -18000 0 EST} {1583650800 -14400 1 EDT} {1604210400 -18000 0 EST} {1615705200 -14400 1 EDT} {1636264800 -18000 0 EST} {1647154800 -14400 1 EDT} {1667714400 -18000 0 EST} {1678604400 -14400 1 EDT} {1699164000 -18000 0 EST} {1710054000 -14400 1 EDT} {1730613600 -18000 0 EST} {1741503600 -14400 1 EDT} {1762063200 -18000 0 EST} {1772953200 -14400 1 EDT} {1793512800 -18000 0 EST} {1805007600 -14400 1 EDT} {1825567200 -18000 0 EST} {1836457200 -14400 1 EDT} {1857016800 -18000 0 EST} {1867906800 -14400 1 EDT} {1888466400 -18000 0 EST} {1899356400 -14400 1 EDT} {1919916000 -18000 0 EST} {1930806000 -14400 1 EDT} {1951365600 -18000 0 EST} {1962860400 -14400 1 EDT} {1983420000 -18000 0 EST} {1994310000 -14400 1 EDT} {2014869600 -18000 0 EST} {2025759600 -14400 1 EDT} {2046319200 -18000 0 EST} {2057209200 -14400 1 EDT} {2077768800 -18000 0 EST} {2088658800 -14400 1 EDT} {2109218400 -18000 0 EST} {2120108400 -14400 1 EDT} {2140668000 -18000 0 EST} {2152162800 -14400 1 EDT} {2172722400 -18000 0 EST} {2183612400 -14400 1 EDT} {2204172000 -18000 0 EST} {2215062000 -14400 1 EDT} {2235621600 -18000 0 EST} {2246511600 -14400 1 EDT} {2267071200 -18000 0 EST} {2277961200 -14400 1 EDT} {2298520800 -18000 0 EST} {2309410800 -14400 1 EDT} {2329970400 -18000 0 EST} {2341465200 -14400 1 EDT} {2362024800 -18000 0 EST} {2372914800 -14400 1 EDT} {2393474400 -18000 0 EST} {2404364400 -14400 1 EDT} {2424924000 -18000 0 EST} {2435814000 -14400 1 EDT} {2456373600 -18000 0 EST} {2467263600 -14400 1 EDT} {2487823200 -18000 0 EST} {2499318000 -14400 1 EDT} {2519877600 -18000 0 EST} {2530767600 -14400 1 EDT} {2551327200 -18000 0 EST} {2562217200 -14400 1 EDT} {2582776800 -18000 0 EST} {2593666800 -14400 1 EDT} {2614226400 -18000 0 EST} {2625116400 -14400 1 EDT} {2645676000 -18000 0 EST} {2656566000 -14400 1 EDT} {2677125600 -18000 0 EST} {2688620400 -14400 1 EDT} {2709180000 -18000 0 EST} {2720070000 -14400 1 EDT} {2740629600 -18000 0 EST} {2751519600 -14400 1 EDT} {2772079200 -18000 0 EST} {2782969200 -14400 1 EDT} {2803528800 -18000 0 EST} {2814418800 -14400 1 EDT} {2834978400 -18000 0 EST} {2846473200 -14400 1 EDT} {2867032800 -18000 0 EST} {2877922800 -14400 1 EDT} {2898482400 -18000 0 EST} {2909372400 -14400 1 EDT} {2929932000 -18000 0 EST} {2940822000 -14400 1 EDT} {2961381600 -18000 0 EST} {2972271600 -14400 1 EDT} {2992831200 -18000 0 EST} {3003721200 -14400 1 EDT} {3024280800 -18000 0 EST} {3035775600 -14400 1 EDT} {3056335200 -18000 0 EST} {3067225200 -14400 1 EDT} {3087784800 -18000 0 EST} {3098674800 -14400 1 EDT} {3119234400 -18000 0 EST} {3130124400 -14400 1 EDT} {3150684000 -18000 0 EST} {3161574000 -14400 1 EDT} {3182133600 -18000 0 EST} {3193023600 -14400 1 EDT} {3213583200 -18000 0 EST} {3225078000 -14400 1 EDT} {3245637600 -18000 0 EST} {3256527600 -14400 1 EDT} {3277087200 -18000 0 EST} {3287977200 -14400 1 EDT} {3308536800 -18000 0 EST} {3319426800 -14400 1 EDT} {3339986400 -18000 0 EST} {3350876400 -14400 1 EDT} {3371436000 -18000 0 EST} {3382930800 -14400 1 EDT} {3403490400 -18000 0 EST} {3414380400 -14400 1 EDT} {3434940000 -18000 0 EST} {3445830000 -14400 1 EDT} {3466389600 -18000 0 EST} {3477279600 -14400 1 EDT} {3497839200 -18000 0 EST} {3508729200 -14400 1 EDT} {3529288800 -18000 0 EST} {3540178800 -14400 1 EDT} {3560738400 -18000 0 EST} {3572233200 -14400 1 EDT} {3592792800 -18000 0 EST} {3603682800 -14400 1 EDT} {3624242400 -18000 0 EST} {3635132400 -14400 1 EDT} {3655692000 -18000 0 EST} {3666582000 -14400 1 EDT} {3687141600 -18000 0 EST} {3698031600 -14400 1 EDT} {3718591200 -18000 0 EST} {3730086000 -14400 1 EDT} {3750645600 -18000 0 EST} {3761535600 -14400 1 EDT} {3782095200 -18000 0 EST} {3792985200 -14400 1 EDT} {3813544800 -18000 0 EST} {3824434800 -14400 1 EDT} {3844994400 -18000 0 EST} {3855884400 -14400 1 EDT} {3876444000 -18000 0 EST} {3887334000 -14400 1 EDT} {3907893600 -18000 0 EST} {3919388400 -14400 1 EDT} {3939948000 -18000 0 EST} {3950838000 -14400 1 EDT} {3971397600 -18000 0 EST} {3982287600 -14400 1 EDT} {4002847200 -18000 0 EST} {4013737200 -14400 1 EDT} {4034296800 -18000 0 EST} {4045186800 -14400 1 EDT} {4065746400 -18000 0 EST} {4076636400 -14400 1 EDT} {4097196000 -18000 0 EST} } |
Changes to library/tzdata/America/Los_Angeles.
1 2 3 4 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Los_Angeles) { {-9223372036854775808 -28378 0 LMT} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Los_Angeles) { {-9223372036854775808 -28378 0 LMT} {-2717640000 -28800 0 PST} {-1633269600 -25200 1 PDT} {-1615129200 -28800 0 PST} {-1601820000 -25200 1 PDT} {-1583679600 -28800 0 PST} {-880207200 -25200 1 PWT} {-769395600 -25200 1 PPT} {-765385200 -28800 0 PST} |
︙ | ︙ | |||
124 125 126 127 128 129 130 | {1067158800 -28800 0 PST} {1081072800 -25200 1 PDT} {1099213200 -28800 0 PST} {1112522400 -25200 1 PDT} {1130662800 -28800 0 PST} {1143972000 -25200 1 PDT} {1162112400 -28800 0 PST} | | | | | | | | > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | 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 | {1067158800 -28800 0 PST} {1081072800 -25200 1 PDT} {1099213200 -28800 0 PST} {1112522400 -25200 1 PDT} {1130662800 -28800 0 PST} {1143972000 -25200 1 PDT} {1162112400 -28800 0 PST} {1173607200 -25200 1 PDT} {1194166800 -28800 0 PST} {1205056800 -25200 1 PDT} {1225616400 -28800 0 PST} {1236506400 -25200 1 PDT} {1257066000 -28800 0 PST} {1268560800 -25200 1 PDT} {1289120400 -28800 0 PST} {1300010400 -25200 1 PDT} {1320570000 -28800 0 PST} {1331460000 -25200 1 PDT} {1352019600 -28800 0 PST} {1362909600 -25200 1 PDT} {1383469200 -28800 0 PST} {1394359200 -25200 1 PDT} {1414918800 -28800 0 PST} {1425808800 -25200 1 PDT} {1446368400 -28800 0 PST} {1457863200 -25200 1 PDT} {1478422800 -28800 0 PST} {1489312800 -25200 1 PDT} {1509872400 -28800 0 PST} {1520762400 -25200 1 PDT} {1541322000 -28800 0 PST} {1552212000 -25200 1 PDT} {1572771600 -28800 0 PST} {1583661600 -25200 1 PDT} {1604221200 -28800 0 PST} {1615716000 -25200 1 PDT} {1636275600 -28800 0 PST} {1647165600 -25200 1 PDT} {1667725200 -28800 0 PST} {1678615200 -25200 1 PDT} {1699174800 -28800 0 PST} {1710064800 -25200 1 PDT} {1730624400 -28800 0 PST} {1741514400 -25200 1 PDT} {1762074000 -28800 0 PST} {1772964000 -25200 1 PDT} {1793523600 -28800 0 PST} {1805018400 -25200 1 PDT} {1825578000 -28800 0 PST} {1836468000 -25200 1 PDT} {1857027600 -28800 0 PST} {1867917600 -25200 1 PDT} {1888477200 -28800 0 PST} {1899367200 -25200 1 PDT} {1919926800 -28800 0 PST} {1930816800 -25200 1 PDT} {1951376400 -28800 0 PST} {1962871200 -25200 1 PDT} {1983430800 -28800 0 PST} {1994320800 -25200 1 PDT} {2014880400 -28800 0 PST} {2025770400 -25200 1 PDT} {2046330000 -28800 0 PST} {2057220000 -25200 1 PDT} {2077779600 -28800 0 PST} {2088669600 -25200 1 PDT} {2109229200 -28800 0 PST} {2120119200 -25200 1 PDT} {2140678800 -28800 0 PST} {2152173600 -25200 1 PDT} {2172733200 -28800 0 PST} {2183623200 -25200 1 PDT} {2204182800 -28800 0 PST} {2215072800 -25200 1 PDT} {2235632400 -28800 0 PST} {2246522400 -25200 1 PDT} {2267082000 -28800 0 PST} {2277972000 -25200 1 PDT} {2298531600 -28800 0 PST} {2309421600 -25200 1 PDT} {2329981200 -28800 0 PST} {2341476000 -25200 1 PDT} {2362035600 -28800 0 PST} {2372925600 -25200 1 PDT} {2393485200 -28800 0 PST} {2404375200 -25200 1 PDT} {2424934800 -28800 0 PST} {2435824800 -25200 1 PDT} {2456384400 -28800 0 PST} {2467274400 -25200 1 PDT} {2487834000 -28800 0 PST} {2499328800 -25200 1 PDT} {2519888400 -28800 0 PST} {2530778400 -25200 1 PDT} {2551338000 -28800 0 PST} {2562228000 -25200 1 PDT} {2582787600 -28800 0 PST} {2593677600 -25200 1 PDT} {2614237200 -28800 0 PST} {2625127200 -25200 1 PDT} {2645686800 -28800 0 PST} {2656576800 -25200 1 PDT} {2677136400 -28800 0 PST} {2688631200 -25200 1 PDT} {2709190800 -28800 0 PST} {2720080800 -25200 1 PDT} {2740640400 -28800 0 PST} {2751530400 -25200 1 PDT} {2772090000 -28800 0 PST} {2782980000 -25200 1 PDT} {2803539600 -28800 0 PST} {2814429600 -25200 1 PDT} {2834989200 -28800 0 PST} {2846484000 -25200 1 PDT} {2867043600 -28800 0 PST} {2877933600 -25200 1 PDT} {2898493200 -28800 0 PST} {2909383200 -25200 1 PDT} {2929942800 -28800 0 PST} {2940832800 -25200 1 PDT} {2961392400 -28800 0 PST} {2972282400 -25200 1 PDT} {2992842000 -28800 0 PST} {3003732000 -25200 1 PDT} {3024291600 -28800 0 PST} {3035786400 -25200 1 PDT} {3056346000 -28800 0 PST} {3067236000 -25200 1 PDT} {3087795600 -28800 0 PST} {3098685600 -25200 1 PDT} {3119245200 -28800 0 PST} {3130135200 -25200 1 PDT} {3150694800 -28800 0 PST} {3161584800 -25200 1 PDT} {3182144400 -28800 0 PST} {3193034400 -25200 1 PDT} {3213594000 -28800 0 PST} {3225088800 -25200 1 PDT} {3245648400 -28800 0 PST} {3256538400 -25200 1 PDT} {3277098000 -28800 0 PST} {3287988000 -25200 1 PDT} {3308547600 -28800 0 PST} {3319437600 -25200 1 PDT} {3339997200 -28800 0 PST} {3350887200 -25200 1 PDT} {3371446800 -28800 0 PST} {3382941600 -25200 1 PDT} {3403501200 -28800 0 PST} {3414391200 -25200 1 PDT} {3434950800 -28800 0 PST} {3445840800 -25200 1 PDT} {3466400400 -28800 0 PST} {3477290400 -25200 1 PDT} {3497850000 -28800 0 PST} {3508740000 -25200 1 PDT} {3529299600 -28800 0 PST} {3540189600 -25200 1 PDT} {3560749200 -28800 0 PST} {3572244000 -25200 1 PDT} {3592803600 -28800 0 PST} {3603693600 -25200 1 PDT} {3624253200 -28800 0 PST} {3635143200 -25200 1 PDT} {3655702800 -28800 0 PST} {3666592800 -25200 1 PDT} {3687152400 -28800 0 PST} {3698042400 -25200 1 PDT} {3718602000 -28800 0 PST} {3730096800 -25200 1 PDT} {3750656400 -28800 0 PST} {3761546400 -25200 1 PDT} {3782106000 -28800 0 PST} {3792996000 -25200 1 PDT} {3813555600 -28800 0 PST} {3824445600 -25200 1 PDT} {3845005200 -28800 0 PST} {3855895200 -25200 1 PDT} {3876454800 -28800 0 PST} {3887344800 -25200 1 PDT} {3907904400 -28800 0 PST} {3919399200 -25200 1 PDT} {3939958800 -28800 0 PST} {3950848800 -25200 1 PDT} {3971408400 -28800 0 PST} {3982298400 -25200 1 PDT} {4002858000 -28800 0 PST} {4013748000 -25200 1 PDT} {4034307600 -28800 0 PST} {4045197600 -25200 1 PDT} {4065757200 -28800 0 PST} {4076647200 -25200 1 PDT} {4097206800 -28800 0 PST} } |
Changes to library/tzdata/America/Louisville.
1 | # created by ../tools/tclZIC.tcl - do not edit | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(America/Kentucky/Louisville)]} { LoadTimeZoneFile America/Kentucky/Louisville } set TZData(:America/Louisville) $TZData(:America/Kentucky/Louisville) |
Changes to library/tzdata/America/Managua.
︙ | ︙ | |||
10 11 12 13 14 15 16 17 | {299134800 -21600 0 CST} {322034400 -18000 1 CDT} {330584400 -21600 0 CST} {694260000 -18000 1 CDT} {717310800 -21600 0 CST} {725882400 -18000 0 EST} {912488400 -21600 0 CST} } | > > | 10 11 12 13 14 15 16 17 18 19 | {299134800 -21600 0 CST} {322034400 -18000 1 CDT} {330584400 -21600 0 CST} {694260000 -18000 1 CDT} {717310800 -21600 0 CST} {725882400 -18000 0 EST} {912488400 -21600 0 CST} {1113112800 -18000 1 CDT} {1127019600 -21600 0 CST} } |
Changes to library/tzdata/America/Menominee.
︙ | ︙ | |||
81 82 83 84 85 86 87 | {1067151600 -21600 0 CST} {1081065600 -18000 1 CDT} {1099206000 -21600 0 CST} {1112515200 -18000 1 CDT} {1130655600 -21600 0 CST} {1143964800 -18000 1 CDT} {1162105200 -21600 0 CST} | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | {1067151600 -21600 0 CST} {1081065600 -18000 1 CDT} {1099206000 -21600 0 CST} {1112515200 -18000 1 CDT} {1130655600 -21600 0 CST} {1143964800 -18000 1 CDT} {1162105200 -21600 0 CST} {1173600000 -18000 1 CDT} {1194159600 -21600 0 CST} {1205049600 -18000 1 CDT} {1225609200 -21600 0 CST} {1236499200 -18000 1 CDT} {1257058800 -21600 0 CST} {1268553600 -18000 1 CDT} {1289113200 -21600 0 CST} {1300003200 -18000 1 CDT} {1320562800 -21600 0 CST} {1331452800 -18000 1 CDT} {1352012400 -21600 0 CST} {1362902400 -18000 1 CDT} {1383462000 -21600 0 CST} {1394352000 -18000 1 CDT} {1414911600 -21600 0 CST} {1425801600 -18000 1 CDT} {1446361200 -21600 0 CST} {1457856000 -18000 1 CDT} {1478415600 -21600 0 CST} {1489305600 -18000 1 CDT} {1509865200 -21600 0 CST} {1520755200 -18000 1 CDT} {1541314800 -21600 0 CST} {1552204800 -18000 1 CDT} {1572764400 -21600 0 CST} {1583654400 -18000 1 CDT} {1604214000 -21600 0 CST} {1615708800 -18000 1 CDT} {1636268400 -21600 0 CST} {1647158400 -18000 1 CDT} {1667718000 -21600 0 CST} {1678608000 -18000 1 CDT} {1699167600 -21600 0 CST} {1710057600 -18000 1 CDT} {1730617200 -21600 0 CST} {1741507200 -18000 1 CDT} {1762066800 -21600 0 CST} {1772956800 -18000 1 CDT} {1793516400 -21600 0 CST} {1805011200 -18000 1 CDT} {1825570800 -21600 0 CST} {1836460800 -18000 1 CDT} {1857020400 -21600 0 CST} {1867910400 -18000 1 CDT} {1888470000 -21600 0 CST} {1899360000 -18000 1 CDT} {1919919600 -21600 0 CST} {1930809600 -18000 1 CDT} {1951369200 -21600 0 CST} {1962864000 -18000 1 CDT} {1983423600 -21600 0 CST} {1994313600 -18000 1 CDT} {2014873200 -21600 0 CST} {2025763200 -18000 1 CDT} {2046322800 -21600 0 CST} {2057212800 -18000 1 CDT} {2077772400 -21600 0 CST} {2088662400 -18000 1 CDT} {2109222000 -21600 0 CST} {2120112000 -18000 1 CDT} {2140671600 -21600 0 CST} {2152166400 -18000 1 CDT} {2172726000 -21600 0 CST} {2183616000 -18000 1 CDT} {2204175600 -21600 0 CST} {2215065600 -18000 1 CDT} {2235625200 -21600 0 CST} {2246515200 -18000 1 CDT} {2267074800 -21600 0 CST} {2277964800 -18000 1 CDT} {2298524400 -21600 0 CST} {2309414400 -18000 1 CDT} {2329974000 -21600 0 CST} {2341468800 -18000 1 CDT} {2362028400 -21600 0 CST} {2372918400 -18000 1 CDT} {2393478000 -21600 0 CST} {2404368000 -18000 1 CDT} {2424927600 -21600 0 CST} {2435817600 -18000 1 CDT} {2456377200 -21600 0 CST} {2467267200 -18000 1 CDT} {2487826800 -21600 0 CST} {2499321600 -18000 1 CDT} {2519881200 -21600 0 CST} {2530771200 -18000 1 CDT} {2551330800 -21600 0 CST} {2562220800 -18000 1 CDT} {2582780400 -21600 0 CST} {2593670400 -18000 1 CDT} {2614230000 -21600 0 CST} {2625120000 -18000 1 CDT} {2645679600 -21600 0 CST} {2656569600 -18000 1 CDT} {2677129200 -21600 0 CST} {2688624000 -18000 1 CDT} {2709183600 -21600 0 CST} {2720073600 -18000 1 CDT} {2740633200 -21600 0 CST} {2751523200 -18000 1 CDT} {2772082800 -21600 0 CST} {2782972800 -18000 1 CDT} {2803532400 -21600 0 CST} {2814422400 -18000 1 CDT} {2834982000 -21600 0 CST} {2846476800 -18000 1 CDT} {2867036400 -21600 0 CST} {2877926400 -18000 1 CDT} {2898486000 -21600 0 CST} {2909376000 -18000 1 CDT} {2929935600 -21600 0 CST} {2940825600 -18000 1 CDT} {2961385200 -21600 0 CST} {2972275200 -18000 1 CDT} {2992834800 -21600 0 CST} {3003724800 -18000 1 CDT} {3024284400 -21600 0 CST} {3035779200 -18000 1 CDT} {3056338800 -21600 0 CST} {3067228800 -18000 1 CDT} {3087788400 -21600 0 CST} {3098678400 -18000 1 CDT} {3119238000 -21600 0 CST} {3130128000 -18000 1 CDT} {3150687600 -21600 0 CST} {3161577600 -18000 1 CDT} {3182137200 -21600 0 CST} {3193027200 -18000 1 CDT} {3213586800 -21600 0 CST} {3225081600 -18000 1 CDT} {3245641200 -21600 0 CST} {3256531200 -18000 1 CDT} {3277090800 -21600 0 CST} {3287980800 -18000 1 CDT} {3308540400 -21600 0 CST} {3319430400 -18000 1 CDT} {3339990000 -21600 0 CST} {3350880000 -18000 1 CDT} {3371439600 -21600 0 CST} {3382934400 -18000 1 CDT} {3403494000 -21600 0 CST} {3414384000 -18000 1 CDT} {3434943600 -21600 0 CST} {3445833600 -18000 1 CDT} {3466393200 -21600 0 CST} {3477283200 -18000 1 CDT} {3497842800 -21600 0 CST} {3508732800 -18000 1 CDT} {3529292400 -21600 0 CST} {3540182400 -18000 1 CDT} {3560742000 -21600 0 CST} {3572236800 -18000 1 CDT} {3592796400 -21600 0 CST} {3603686400 -18000 1 CDT} {3624246000 -21600 0 CST} {3635136000 -18000 1 CDT} {3655695600 -21600 0 CST} {3666585600 -18000 1 CDT} {3687145200 -21600 0 CST} {3698035200 -18000 1 CDT} {3718594800 -21600 0 CST} {3730089600 -18000 1 CDT} {3750649200 -21600 0 CST} {3761539200 -18000 1 CDT} {3782098800 -21600 0 CST} {3792988800 -18000 1 CDT} {3813548400 -21600 0 CST} {3824438400 -18000 1 CDT} {3844998000 -21600 0 CST} {3855888000 -18000 1 CDT} {3876447600 -21600 0 CST} {3887337600 -18000 1 CDT} {3907897200 -21600 0 CST} {3919392000 -18000 1 CDT} {3939951600 -21600 0 CST} {3950841600 -18000 1 CDT} {3971401200 -21600 0 CST} {3982291200 -18000 1 CDT} {4002850800 -21600 0 CST} {4013740800 -18000 1 CDT} {4034300400 -21600 0 CST} {4045190400 -18000 1 CDT} {4065750000 -21600 0 CST} {4076640000 -18000 1 CDT} {4097199600 -21600 0 CST} } |
Changes to library/tzdata/America/Montevideo.
︙ | ︙ | |||
63 64 65 66 67 68 69 | {656478000 -7200 1 UYST} {667965600 -10800 0 UYT} {688532400 -7200 1 UYST} {699415200 -10800 0 UYT} {719377200 -7200 1 UYST} {730864800 -10800 0 UYT} {1095562800 -7200 1 UYST} | | > > | 63 64 65 66 67 68 69 70 71 72 73 | {656478000 -7200 1 UYST} {667965600 -10800 0 UYT} {688532400 -7200 1 UYST} {699415200 -10800 0 UYT} {719377200 -7200 1 UYST} {730864800 -10800 0 UYT} {1095562800 -7200 1 UYST} {1111896000 -10800 0 UYT} {1128834000 -7200 1 UYST} {1142136000 -10800 0 UYT} } |
Changes to library/tzdata/America/New_York.
1 2 3 4 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/New_York) { {-9223372036854775808 -17762 0 LMT} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/New_York) { {-9223372036854775808 -17762 0 LMT} {-2717650800 -18000 0 EST} {-1633280400 -14400 1 EDT} {-1615140000 -18000 0 EST} {-1601830800 -14400 1 EDT} {-1583690400 -18000 0 EST} {-1577905200 -18000 0 EST} {-1570381200 -14400 1 EDT} {-1551636000 -18000 0 EST} |
︙ | ︙ | |||
176 177 178 179 180 181 182 | {1067148000 -18000 0 EST} {1081062000 -14400 1 EDT} {1099202400 -18000 0 EST} {1112511600 -14400 1 EDT} {1130652000 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} | | | > > | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | > > | | | | | | | | | | > > | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | {1067148000 -18000 0 EST} {1081062000 -14400 1 EDT} {1099202400 -18000 0 EST} {1112511600 -14400 1 EDT} {1130652000 -18000 0 EST} {1143961200 -14400 1 EDT} {1162101600 -18000 0 EST} {1173596400 -14400 1 EDT} {1194156000 -18000 0 EST} {1205046000 -14400 1 EDT} {1225605600 -18000 0 EST} {1236495600 -14400 1 EDT} {1257055200 -18000 0 EST} {1268550000 -14400 1 EDT} {1289109600 -18000 0 EST} {1299999600 -14400 1 EDT} {1320559200 -18000 0 EST} {1331449200 -14400 1 EDT} {1352008800 -18000 0 EST} {1362898800 -14400 1 EDT} {1383458400 -18000 0 EST} {1394348400 -14400 1 EDT} {1414908000 -18000 0 EST} {1425798000 -14400 1 EDT} {1446357600 -18000 0 EST} {1457852400 -14400 1 EDT} {1478412000 -18000 0 EST} {1489302000 -14400 1 EDT} {1509861600 -18000 0 EST} {1520751600 -14400 1 EDT} {1541311200 -18000 0 EST} {1552201200 -14400 1 EDT} {1572760800 -18000 0 EST} {1583650800 -14400 1 EDT} {1604210400 -18000 0 EST} {1615705200 -14400 1 EDT} {1636264800 -18000 0 EST} {1647154800 -14400 1 EDT} {1667714400 -18000 0 EST} {1678604400 -14400 1 EDT} {1699164000 -18000 0 EST} {1710054000 -14400 1 EDT} {1730613600 -18000 0 EST} {1741503600 -14400 1 EDT} {1762063200 -18000 0 EST} {1772953200 -14400 1 EDT} {1793512800 -18000 0 EST} {1805007600 -14400 1 EDT} {1825567200 -18000 0 EST} {1836457200 -14400 1 EDT} {1857016800 -18000 0 EST} {1867906800 -14400 1 EDT} {1888466400 -18000 0 EST} {1899356400 -14400 1 EDT} {1919916000 -18000 0 EST} {1930806000 -14400 1 EDT} {1951365600 -18000 0 EST} {1962860400 -14400 1 EDT} {1983420000 -18000 0 EST} {1994310000 -14400 1 EDT} {2014869600 -18000 0 EST} {2025759600 -14400 1 EDT} {2046319200 -18000 0 EST} {2057209200 -14400 1 EDT} {2077768800 -18000 0 EST} {2088658800 -14400 1 EDT} {2109218400 -18000 0 EST} {2120108400 -14400 1 EDT} {2140668000 -18000 0 EST} {2152162800 -14400 1 EDT} {2172722400 -18000 0 EST} {2183612400 -14400 1 EDT} {2204172000 -18000 0 EST} {2215062000 -14400 1 EDT} {2235621600 -18000 0 EST} {2246511600 -14400 1 EDT} {2267071200 -18000 0 EST} {2277961200 -14400 1 EDT} {2298520800 -18000 0 EST} {2309410800 -14400 1 EDT} {2329970400 -18000 0 EST} {2341465200 -14400 1 EDT} {2362024800 -18000 0 EST} {2372914800 -14400 1 EDT} {2393474400 -18000 0 EST} {2404364400 -14400 1 EDT} {2424924000 -18000 0 EST} {2435814000 -14400 1 EDT} {2456373600 -18000 0 EST} {2467263600 -14400 1 EDT} {2487823200 -18000 0 EST} {2499318000 -14400 1 EDT} {2519877600 -18000 0 EST} {2530767600 -14400 1 EDT} {2551327200 -18000 0 EST} {2562217200 -14400 1 EDT} {2582776800 -18000 0 EST} {2593666800 -14400 1 EDT} {2614226400 -18000 0 EST} {2625116400 -14400 1 EDT} {2645676000 -18000 0 EST} {2656566000 -14400 1 EDT} {2677125600 -18000 0 EST} {2688620400 -14400 1 EDT} {2709180000 -18000 0 EST} {2720070000 -14400 1 EDT} {2740629600 -18000 0 EST} {2751519600 -14400 1 EDT} {2772079200 -18000 0 EST} {2782969200 -14400 1 EDT} {2803528800 -18000 0 EST} {2814418800 -14400 1 EDT} {2834978400 -18000 0 EST} {2846473200 -14400 1 EDT} {2867032800 -18000 0 EST} {2877922800 -14400 1 EDT} {2898482400 -18000 0 EST} {2909372400 -14400 1 EDT} {2929932000 -18000 0 EST} {2940822000 -14400 1 EDT} {2961381600 -18000 0 EST} {2972271600 -14400 1 EDT} {2992831200 -18000 0 EST} {3003721200 -14400 1 EDT} {3024280800 -18000 0 EST} {3035775600 -14400 1 EDT} {3056335200 -18000 0 EST} {3067225200 -14400 1 EDT} {3087784800 -18000 0 EST} {3098674800 -14400 1 EDT} {3119234400 -18000 0 EST} {3130124400 -14400 1 EDT} {3150684000 -18000 0 EST} {3161574000 -14400 1 EDT} {3182133600 -18000 0 EST} {3193023600 -14400 1 EDT} {3213583200 -18000 0 EST} {3225078000 -14400 1 EDT} {3245637600 -18000 0 EST} {3256527600 -14400 1 EDT} {3277087200 -18000 0 EST} {3287977200 -14400 1 EDT} {3308536800 -18000 0 EST} {3319426800 -14400 1 EDT} {3339986400 -18000 0 EST} {3350876400 -14400 1 EDT} {3371436000 -18000 0 EST} {3382930800 -14400 1 EDT} {3403490400 -18000 0 EST} {3414380400 -14400 1 EDT} {3434940000 -18000 0 EST} {3445830000 -14400 1 EDT} {3466389600 -18000 0 EST} {3477279600 -14400 1 EDT} {3497839200 -18000 0 EST} {3508729200 -14400 1 EDT} {3529288800 -18000 0 EST} {3540178800 -14400 1 EDT} {3560738400 -18000 0 EST} {3572233200 -14400 1 EDT} {3592792800 -18000 0 EST} {3603682800 -14400 1 EDT} {3624242400 -18000 0 EST} {3635132400 -14400 1 EDT} {3655692000 -18000 0 EST} {3666582000 -14400 1 EDT} {3687141600 -18000 0 EST} {3698031600 -14400 1 EDT} {3718591200 -18000 0 EST} {3730086000 -14400 1 EDT} {3750645600 -18000 0 EST} {3761535600 -14400 1 EDT} {3782095200 -18000 0 EST} {3792985200 -14400 1 EDT} {3813544800 -18000 0 EST} {3824434800 -14400 1 EDT} {3844994400 -18000 0 EST} {3855884400 -14400 1 EDT} {3876444000 -18000 0 EST} {3887334000 -14400 1 EDT} {3907893600 -18000 0 EST} {3919388400 -14400 1 EDT} {3939948000 -18000 0 EST} {3950838000 -14400 1 EDT} {3971397600 -18000 0 EST} {3982287600 -14400 1 EDT} {4002847200 -18000 0 EST} {4013737200 -14400 1 EDT} {4034296800 -18000 0 EST} {4045186800 -14400 1 EDT} {4065746400 -18000 0 EST} {4076636400 -14400 1 EDT} {4097196000 -18000 0 EST} } |
Changes to library/tzdata/America/Nome.
︙ | ︙ | |||
83 84 85 86 87 88 89 | {1067162400 -32400 0 AKST} {1081076400 -28800 1 AKDT} {1099216800 -32400 0 AKST} {1112526000 -28800 1 AKDT} {1130666400 -32400 0 AKST} {1143975600 -28800 1 AKDT} {1162116000 -32400 0 AKST} | | | | | | | | < < | | | | | | | | | | | | < < | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | > > | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | 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 | {1067162400 -32400 0 AKST} {1081076400 -28800 1 AKDT} {1099216800 -32400 0 AKST} {1112526000 -28800 1 AKDT} {1130666400 -32400 0 AKST} {1143975600 -28800 1 AKDT} {1162116000 -32400 0 AKST} {1173610800 -28800 1 AKDT} {1194170400 -32400 0 AKST} {1205060400 -28800 1 AKDT} {1225620000 -32400 0 AKST} {1236510000 -28800 1 AKDT} {1257069600 -32400 0 AKST} {1268564400 -28800 1 AKDT} {1289124000 -32400 0 AKST} {1300014000 -28800 1 AKDT} {1320573600 -32400 0 AKST} {1331463600 -28800 1 AKDT} {1352023200 -32400 0 AKST} {1362913200 -28800 1 AKDT} {1383472800 -32400 0 AKST} {1394362800 -28800 1 AKDT} {1414922400 -32400 0 AKST} {1425812400 -28800 1 AKDT} {1446372000 -32400 0 AKST} {1457866800 -28800 1 AKDT} {1478426400 -32400 0 AKST} {1489316400 -28800 1 AKDT} {1509876000 -32400 0 AKST} {1520766000 -28800 1 AKDT} {1541325600 -32400 0 AKST} {1552215600 -28800 1 AKDT} {1572775200 -32400 0 AKST} {1583665200 -28800 1 AKDT} {1604224800 -32400 0 AKST} {1615719600 -28800 1 AKDT} {1636279200 -32400 0 AKST} {1647169200 -28800 1 AKDT} {1667728800 -32400 0 AKST} {1678618800 -28800 1 AKDT} {1699178400 -32400 0 AKST} {1710068400 -28800 1 AKDT} {1730628000 -32400 0 AKST} {1741518000 -28800 1 AKDT} {1762077600 -32400 0 AKST} {1772967600 -28800 1 AKDT} {1793527200 -32400 0 AKST} {1805022000 -28800 1 AKDT} {1825581600 -32400 0 AKST} {1836471600 -28800 1 AKDT} {1857031200 -32400 0 AKST} {1867921200 -28800 1 AKDT} {1888480800 -32400 0 AKST} {1899370800 -28800 1 AKDT} {1919930400 -32400 0 AKST} {1930820400 -28800 1 AKDT} {1951380000 -32400 0 AKST} {1962874800 -28800 1 AKDT} {1983434400 -32400 0 AKST} {1994324400 -28800 1 AKDT} {2014884000 -32400 0 AKST} {2025774000 -28800 1 AKDT} {2046333600 -32400 0 AKST} {2057223600 -28800 1 AKDT} {2077783200 -32400 0 AKST} {2088673200 -28800 1 AKDT} {2109232800 -32400 0 AKST} {2120122800 -28800 1 AKDT} {2140682400 -32400 0 AKST} {2152177200 -28800 1 AKDT} {2172736800 -32400 0 AKST} {2183626800 -28800 1 AKDT} {2204186400 -32400 0 AKST} {2215076400 -28800 1 AKDT} {2235636000 -32400 0 AKST} {2246526000 -28800 1 AKDT} {2267085600 -32400 0 AKST} {2277975600 -28800 1 AKDT} {2298535200 -32400 0 AKST} {2309425200 -28800 1 AKDT} {2329984800 -32400 0 AKST} {2341479600 -28800 1 AKDT} {2362039200 -32400 0 AKST} {2372929200 -28800 1 AKDT} {2393488800 -32400 0 AKST} {2404378800 -28800 1 AKDT} {2424938400 -32400 0 AKST} {2435828400 -28800 1 AKDT} {2456388000 -32400 0 AKST} {2467278000 -28800 1 AKDT} {2487837600 -32400 0 AKST} {2499332400 -28800 1 AKDT} {2519892000 -32400 0 AKST} {2530782000 -28800 1 AKDT} {2551341600 -32400 0 AKST} {2562231600 -28800 1 AKDT} {2582791200 -32400 0 AKST} {2593681200 -28800 1 AKDT} {2614240800 -32400 0 AKST} {2625130800 -28800 1 AKDT} {2645690400 -32400 0 AKST} {2656580400 -28800 1 AKDT} {2677140000 -32400 0 AKST} {2688634800 -28800 1 AKDT} {2709194400 -32400 0 AKST} {2720084400 -28800 1 AKDT} {2740644000 -32400 0 AKST} {2751534000 -28800 1 AKDT} {2772093600 -32400 0 AKST} {2782983600 -28800 1 AKDT} {2803543200 -32400 0 AKST} {2814433200 -28800 1 AKDT} {2834992800 -32400 0 AKST} {2846487600 -28800 1 AKDT} {2867047200 -32400 0 AKST} {2877937200 -28800 1 AKDT} {2898496800 -32400 0 AKST} {2909386800 -28800 1 AKDT} {2929946400 -32400 0 AKST} {2940836400 -28800 1 AKDT} {2961396000 -32400 0 AKST} {2972286000 -28800 1 AKDT} {2992845600 -32400 0 AKST} {3003735600 -28800 1 AKDT} {3024295200 -32400 0 AKST} {3035790000 -28800 1 AKDT} {3056349600 -32400 0 AKST} {3067239600 -28800 1 AKDT} {3087799200 -32400 0 AKST} {3098689200 -28800 1 AKDT} {3119248800 -32400 0 AKST} {3130138800 -28800 1 AKDT} {3150698400 -32400 0 AKST} {3161588400 -28800 1 AKDT} {3182148000 -32400 0 AKST} {3193038000 -28800 1 AKDT} {3213597600 -32400 0 AKST} {3225092400 -28800 1 AKDT} {3245652000 -32400 0 AKST} {3256542000 -28800 1 AKDT} {3277101600 -32400 0 AKST} {3287991600 -28800 1 AKDT} {3308551200 -32400 0 AKST} {3319441200 -28800 1 AKDT} {3340000800 -32400 0 AKST} {3350890800 -28800 1 AKDT} {3371450400 -32400 0 AKST} {3382945200 -28800 1 AKDT} {3403504800 -32400 0 AKST} {3414394800 -28800 1 AKDT} {3434954400 -32400 0 AKST} {3445844400 -28800 1 AKDT} {3466404000 -32400 0 AKST} {3477294000 -28800 1 AKDT} {3497853600 -32400 0 AKST} {3508743600 -28800 1 AKDT} {3529303200 -32400 0 AKST} {3540193200 -28800 1 AKDT} {3560752800 -32400 0 AKST} {3572247600 -28800 1 AKDT} {3592807200 -32400 0 AKST} {3603697200 -28800 1 AKDT} {3624256800 -32400 0 AKST} {3635146800 -28800 1 AKDT} {3655706400 -32400 0 AKST} {3666596400 -28800 1 AKDT} {3687156000 -32400 0 AKST} {3698046000 -28800 1 AKDT} {3718605600 -32400 0 AKST} {3730100400 -28800 1 AKDT} {3750660000 -32400 0 AKST} {3761550000 -28800 1 AKDT} {3782109600 -32400 0 AKST} {3792999600 -28800 1 AKDT} {3813559200 -32400 0 AKST} {3824449200 -28800 1 AKDT} {3845008800 -32400 0 AKST} {3855898800 -28800 1 AKDT} {3876458400 -32400 0 AKST} {3887348400 -28800 1 AKDT} {3907908000 -32400 0 AKST} {3919402800 -28800 1 AKDT} {3939962400 -32400 0 AKST} {3950852400 -28800 1 AKDT} {3971412000 -32400 0 AKST} {3982302000 -28800 1 AKDT} {4002861600 -32400 0 AKST} {4013751600 -28800 1 AKDT} {4034311200 -32400 0 AKST} {4045201200 -28800 1 AKDT} {4065760800 -32400 0 AKST} {4076650800 -28800 1 AKDT} {4097210400 -32400 0 AKST} } |
Changes to library/tzdata/America/North_Dakota/Center.
1 2 3 4 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/North_Dakota/Center) { {-9223372036854775808 -24312 0 LMT} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/North_Dakota/Center) { {-9223372036854775808 -24312 0 LMT} {-2717643600 -25200 0 MST} {-1633273200 -21600 1 MDT} {-1615132800 -25200 0 MST} {-1601823600 -21600 1 MDT} {-1583683200 -25200 0 MST} {-880210800 -21600 1 MWT} {-769395600 -21600 1 MPT} {-765388800 -25200 0 MST} |
︙ | ︙ | |||
86 87 88 89 90 91 92 | {1067151600 -21600 0 CST} {1081065600 -18000 1 CDT} {1099206000 -21600 0 CST} {1112515200 -18000 1 CDT} {1130655600 -21600 0 CST} {1143964800 -18000 1 CDT} {1162105200 -21600 0 CST} | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | {1067151600 -21600 0 CST} {1081065600 -18000 1 CDT} {1099206000 -21600 0 CST} {1112515200 -18000 1 CDT} {1130655600 -21600 0 CST} {1143964800 -18000 1 CDT} {1162105200 -21600 0 CST} {1173600000 -18000 1 CDT} {1194159600 -21600 0 CST} {1205049600 -18000 1 CDT} {1225609200 -21600 0 CST} {1236499200 -18000 1 CDT} {1257058800 -21600 0 CST} {1268553600 -18000 1 CDT} {1289113200 -21600 0 CST} {1300003200 -18000 1 CDT} {1320562800 -21600 0 CST} {1331452800 -18000 1 CDT} {1352012400 -21600 0 CST} {1362902400 -18000 1 CDT} {1383462000 -21600 0 CST} {1394352000 -18000 1 CDT} {1414911600 -21600 0 CST} {1425801600 -18000 1 CDT} {1446361200 -21600 0 CST} {1457856000 -18000 1 CDT} {1478415600 -21600 0 CST} {1489305600 -18000 1 CDT} {1509865200 -21600 0 CST} {1520755200 -18000 1 CDT} {1541314800 -21600 0 CST} {1552204800 -18000 1 CDT} {1572764400 -21600 0 CST} {1583654400 -18000 1 CDT} {1604214000 -21600 0 CST} {1615708800 -18000 1 CDT} {1636268400 -21600 0 CST} {1647158400 -18000 1 CDT} {1667718000 -21600 0 CST} {1678608000 -18000 1 CDT} {1699167600 -21600 0 CST} {1710057600 -18000 1 CDT} {1730617200 -21600 0 CST} {1741507200 -18000 1 CDT} {1762066800 -21600 0 CST} {1772956800 -18000 1 CDT} {1793516400 -21600 0 CST} {1805011200 -18000 1 CDT} {1825570800 -21600 0 CST} {1836460800 -18000 1 CDT} {1857020400 -21600 0 CST} {1867910400 -18000 1 CDT} {1888470000 -21600 0 CST} {1899360000 -18000 1 CDT} {1919919600 -21600 0 CST} {1930809600 -18000 1 CDT} {1951369200 -21600 0 CST} {1962864000 -18000 1 CDT} {1983423600 -21600 0 CST} {1994313600 -18000 1 CDT} {2014873200 -21600 0 CST} {2025763200 -18000 1 CDT} {2046322800 -21600 0 CST} {2057212800 -18000 1 CDT} {2077772400 -21600 0 CST} {2088662400 -18000 1 CDT} {2109222000 -21600 0 CST} {2120112000 -18000 1 CDT} {2140671600 -21600 0 CST} {2152166400 -18000 1 CDT} {2172726000 -21600 0 CST} {2183616000 -18000 1 CDT} {2204175600 -21600 0 CST} {2215065600 -18000 1 CDT} {2235625200 -21600 0 CST} {2246515200 -18000 1 CDT} {2267074800 -21600 0 CST} {2277964800 -18000 1 CDT} {2298524400 -21600 0 CST} {2309414400 -18000 1 CDT} {2329974000 -21600 0 CST} {2341468800 -18000 1 CDT} {2362028400 -21600 0 CST} {2372918400 -18000 1 CDT} {2393478000 -21600 0 CST} {2404368000 -18000 1 CDT} {2424927600 -21600 0 CST} {2435817600 -18000 1 CDT} {2456377200 -21600 0 CST} {2467267200 -18000 1 CDT} {2487826800 -21600 0 CST} {2499321600 -18000 1 CDT} {2519881200 -21600 0 CST} {2530771200 -18000 1 CDT} {2551330800 -21600 0 CST} {2562220800 -18000 1 CDT} {2582780400 -21600 0 CST} {2593670400 -18000 1 CDT} {2614230000 -21600 0 CST} {2625120000 -18000 1 CDT} {2645679600 -21600 0 CST} {2656569600 -18000 1 CDT} {2677129200 -21600 0 CST} {2688624000 -18000 1 CDT} {2709183600 -21600 0 CST} {2720073600 -18000 1 CDT} {2740633200 -21600 0 CST} {2751523200 -18000 1 CDT} {2772082800 -21600 0 CST} {2782972800 -18000 1 CDT} {2803532400 -21600 0 CST} {2814422400 -18000 1 CDT} {2834982000 -21600 0 CST} {2846476800 -18000 1 CDT} {2867036400 -21600 0 CST} {2877926400 -18000 1 CDT} {2898486000 -21600 0 CST} {2909376000 -18000 1 CDT} {2929935600 -21600 0 CST} {2940825600 -18000 1 CDT} {2961385200 -21600 0 CST} {2972275200 -18000 1 CDT} {2992834800 -21600 0 CST} {3003724800 -18000 1 CDT} {3024284400 -21600 0 CST} {3035779200 -18000 1 CDT} {3056338800 -21600 0 CST} {3067228800 -18000 1 CDT} {3087788400 -21600 0 CST} {3098678400 -18000 1 CDT} {3119238000 -21600 0 CST} {3130128000 -18000 1 CDT} {3150687600 -21600 0 CST} {3161577600 -18000 1 CDT} {3182137200 -21600 0 CST} {3193027200 -18000 1 CDT} {3213586800 -21600 0 CST} {3225081600 -18000 1 CDT} {3245641200 -21600 0 CST} {3256531200 -18000 1 CDT} {3277090800 -21600 0 CST} {3287980800 -18000 1 CDT} {3308540400 -21600 0 CST} {3319430400 -18000 1 CDT} {3339990000 -21600 0 CST} {3350880000 -18000 1 CDT} {3371439600 -21600 0 CST} {3382934400 -18000 1 CDT} {3403494000 -21600 0 CST} {3414384000 -18000 1 CDT} {3434943600 -21600 0 CST} {3445833600 -18000 1 CDT} {3466393200 -21600 0 CST} {3477283200 -18000 1 CDT} {3497842800 -21600 0 CST} {3508732800 -18000 1 CDT} {3529292400 -21600 0 CST} {3540182400 -18000 1 CDT} {3560742000 -21600 0 CST} {3572236800 -18000 1 CDT} {3592796400 -21600 0 CST} {3603686400 -18000 1 CDT} {3624246000 -21600 0 CST} {3635136000 -18000 1 CDT} {3655695600 -21600 0 CST} {3666585600 -18000 1 CDT} {3687145200 -21600 0 CST} {3698035200 -18000 1 CDT} {3718594800 -21600 0 CST} {3730089600 -18000 1 CDT} {3750649200 -21600 0 CST} {3761539200 -18000 1 CDT} {3782098800 -21600 0 CST} {3792988800 -18000 1 CDT} {3813548400 -21600 0 CST} {3824438400 -18000 1 CDT} {3844998000 -21600 0 CST} {3855888000 -18000 1 CDT} {3876447600 -21600 0 CST} {3887337600 -18000 1 CDT} {3907897200 -21600 0 CST} {3919392000 -18000 1 CDT} {3939951600 -21600 0 CST} {3950841600 -18000 1 CDT} {3971401200 -21600 0 CST} {3982291200 -18000 1 CDT} {4002850800 -21600 0 CST} {4013740800 -18000 1 CDT} {4034300400 -21600 0 CST} {4045190400 -18000 1 CDT} {4065750000 -21600 0 CST} {4076640000 -18000 1 CDT} {4097199600 -21600 0 CST} } |
Changes to library/tzdata/America/Phoenix.
1 2 3 4 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Phoenix) { {-9223372036854775808 -26898 0 LMT} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:America/Phoenix) { {-9223372036854775808 -26898 0 LMT} {-2717643600 -25200 0 MST} {-1633273200 -21600 1 MDT} {-1615132800 -25200 0 MST} {-1601823600 -21600 1 MDT} {-1583683200 -25200 0 MST} {-880210800 -21600 1 MWT} {-820519140 -25200 0 MST} {-796841940 -25200 0 MST} |
︙ | ︙ |
Changes to library/tzdata/America/Port-au-Prince.
︙ | ︙ | |||
30 31 32 33 34 35 36 37 | {783478800 -18000 0 EST} {796784400 -14400 1 EDT} {814928400 -18000 0 EST} {828838800 -14400 1 EDT} {846378000 -18000 0 EST} {860288400 -14400 1 EDT} {877827600 -18000 0 EST} } | > > | 30 31 32 33 34 35 36 37 38 39 | {783478800 -18000 0 EST} {796784400 -14400 1 EDT} {814928400 -18000 0 EST} {828838800 -14400 1 EDT} {846378000 -18000 0 EST} {860288400 -14400 1 EDT} {877827600 -18000 0 EST} {1112504400 -14400 1 EDT} {1130644800 -18000 0 EST} } |
Changes to library/tzdata/America/Rosario.
1 | # created by ../tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(America/Argentina/Cordoba)]} { LoadTimeZoneFile America/Argentina/Cordoba } set TZData(:America/Rosario) $TZData(:America/Argentina/Cordoba) |
Changes to library/tzdata/America/Yakutat.
︙ | ︙ | |||
83 84 85 86 87 88 89 | {1067162400 -32400 0 AKST} {1081076400 -28800 1 AKDT} {1099216800 -32400 0 AKST} {1112526000 -28800 1 AKDT} {1130666400 -32400 0 AKST} {1143975600 -28800 1 AKDT} {1162116000 -32400 0 AKST} | | | | | | | | < < | | | | | | | | | | | | < < | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | > > | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | 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 | {1067162400 -32400 0 AKST} {1081076400 -28800 1 AKDT} {1099216800 -32400 0 AKST} {1112526000 -28800 1 AKDT} {1130666400 -32400 0 AKST} {1143975600 -28800 1 AKDT} {1162116000 -32400 0 AKST} {1173610800 -28800 1 AKDT} {1194170400 -32400 0 AKST} {1205060400 -28800 1 AKDT} {1225620000 -32400 0 AKST} {1236510000 -28800 1 AKDT} {1257069600 -32400 0 AKST} {1268564400 -28800 1 AKDT} {1289124000 -32400 0 AKST} {1300014000 -28800 1 AKDT} {1320573600 -32400 0 AKST} {1331463600 -28800 1 AKDT} {1352023200 -32400 0 AKST} {1362913200 -28800 1 AKDT} {1383472800 -32400 0 AKST} {1394362800 -28800 1 AKDT} {1414922400 -32400 0 AKST} {1425812400 -28800 1 AKDT} {1446372000 -32400 0 AKST} {1457866800 -28800 1 AKDT} {1478426400 -32400 0 AKST} {1489316400 -28800 1 AKDT} {1509876000 -32400 0 AKST} {1520766000 -28800 1 AKDT} {1541325600 -32400 0 AKST} {1552215600 -28800 1 AKDT} {1572775200 -32400 0 AKST} {1583665200 -28800 1 AKDT} {1604224800 -32400 0 AKST} {1615719600 -28800 1 AKDT} {1636279200 -32400 0 AKST} {1647169200 -28800 1 AKDT} {1667728800 -32400 0 AKST} {1678618800 -28800 1 AKDT} {1699178400 -32400 0 AKST} {1710068400 -28800 1 AKDT} {1730628000 -32400 0 AKST} {1741518000 -28800 1 AKDT} {1762077600 -32400 0 AKST} {1772967600 -28800 1 AKDT} {1793527200 -32400 0 AKST} {1805022000 -28800 1 AKDT} {1825581600 -32400 0 AKST} {1836471600 -28800 1 AKDT} {1857031200 -32400 0 AKST} {1867921200 -28800 1 AKDT} {1888480800 -32400 0 AKST} {1899370800 -28800 1 AKDT} {1919930400 -32400 0 AKST} {1930820400 -28800 1 AKDT} {1951380000 -32400 0 AKST} {1962874800 -28800 1 AKDT} {1983434400 -32400 0 AKST} {1994324400 -28800 1 AKDT} {2014884000 -32400 0 AKST} {2025774000 -28800 1 AKDT} {2046333600 -32400 0 AKST} {2057223600 -28800 1 AKDT} {2077783200 -32400 0 AKST} {2088673200 -28800 1 AKDT} {2109232800 -32400 0 AKST} {2120122800 -28800 1 AKDT} {2140682400 -32400 0 AKST} {2152177200 -28800 1 AKDT} {2172736800 -32400 0 AKST} {2183626800 -28800 1 AKDT} {2204186400 -32400 0 AKST} {2215076400 -28800 1 AKDT} {2235636000 -32400 0 AKST} {2246526000 -28800 1 AKDT} {2267085600 -32400 0 AKST} {2277975600 -28800 1 AKDT} {2298535200 -32400 0 AKST} {2309425200 -28800 1 AKDT} {2329984800 -32400 0 AKST} {2341479600 -28800 1 AKDT} {2362039200 -32400 0 AKST} {2372929200 -28800 1 AKDT} {2393488800 -32400 0 AKST} {2404378800 -28800 1 AKDT} {2424938400 -32400 0 AKST} {2435828400 -28800 1 AKDT} {2456388000 -32400 0 AKST} {2467278000 -28800 1 AKDT} {2487837600 -32400 0 AKST} {2499332400 -28800 1 AKDT} {2519892000 -32400 0 AKST} {2530782000 -28800 1 AKDT} {2551341600 -32400 0 AKST} {2562231600 -28800 1 AKDT} {2582791200 -32400 0 AKST} {2593681200 -28800 1 AKDT} {2614240800 -32400 0 AKST} {2625130800 -28800 1 AKDT} {2645690400 -32400 0 AKST} {2656580400 -28800 1 AKDT} {2677140000 -32400 0 AKST} {2688634800 -28800 1 AKDT} {2709194400 -32400 0 AKST} {2720084400 -28800 1 AKDT} {2740644000 -32400 0 AKST} {2751534000 -28800 1 AKDT} {2772093600 -32400 0 AKST} {2782983600 -28800 1 AKDT} {2803543200 -32400 0 AKST} {2814433200 -28800 1 AKDT} {2834992800 -32400 0 AKST} {2846487600 -28800 1 AKDT} {2867047200 -32400 0 AKST} {2877937200 -28800 1 AKDT} {2898496800 -32400 0 AKST} {2909386800 -28800 1 AKDT} {2929946400 -32400 0 AKST} {2940836400 -28800 1 AKDT} {2961396000 -32400 0 AKST} {2972286000 -28800 1 AKDT} {2992845600 -32400 0 AKST} {3003735600 -28800 1 AKDT} {3024295200 -32400 0 AKST} {3035790000 -28800 1 AKDT} {3056349600 -32400 0 AKST} {3067239600 -28800 1 AKDT} {3087799200 -32400 0 AKST} {3098689200 -28800 1 AKDT} {3119248800 -32400 0 AKST} {3130138800 -28800 1 AKDT} {3150698400 -32400 0 AKST} {3161588400 -28800 1 AKDT} {3182148000 -32400 0 AKST} {3193038000 -28800 1 AKDT} {3213597600 -32400 0 AKST} {3225092400 -28800 1 AKDT} {3245652000 -32400 0 AKST} {3256542000 -28800 1 AKDT} {3277101600 -32400 0 AKST} {3287991600 -28800 1 AKDT} {3308551200 -32400 0 AKST} {3319441200 -28800 1 AKDT} {3340000800 -32400 0 AKST} {3350890800 -28800 1 AKDT} {3371450400 -32400 0 AKST} {3382945200 -28800 1 AKDT} {3403504800 -32400 0 AKST} {3414394800 -28800 1 AKDT} {3434954400 -32400 0 AKST} {3445844400 -28800 1 AKDT} {3466404000 -32400 0 AKST} {3477294000 -28800 1 AKDT} {3497853600 -32400 0 AKST} {3508743600 -28800 1 AKDT} {3529303200 -32400 0 AKST} {3540193200 -28800 1 AKDT} {3560752800 -32400 0 AKST} {3572247600 -28800 1 AKDT} {3592807200 -32400 0 AKST} {3603697200 -28800 1 AKDT} {3624256800 -32400 0 AKST} {3635146800 -28800 1 AKDT} {3655706400 -32400 0 AKST} {3666596400 -28800 1 AKDT} {3687156000 -32400 0 AKST} {3698046000 -28800 1 AKDT} {3718605600 -32400 0 AKST} {3730100400 -28800 1 AKDT} {3750660000 -32400 0 AKST} {3761550000 -28800 1 AKDT} {3782109600 -32400 0 AKST} {3792999600 -28800 1 AKDT} {3813559200 -32400 0 AKST} {3824449200 -28800 1 AKDT} {3845008800 -32400 0 AKST} {3855898800 -28800 1 AKDT} {3876458400 -32400 0 AKST} {3887348400 -28800 1 AKDT} {3907908000 -32400 0 AKST} {3919402800 -28800 1 AKDT} {3939962400 -32400 0 AKST} {3950852400 -28800 1 AKDT} {3971412000 -32400 0 AKST} {3982302000 -28800 1 AKDT} {4002861600 -32400 0 AKST} {4013751600 -28800 1 AKDT} {4034311200 -32400 0 AKST} {4045201200 -28800 1 AKDT} {4065760800 -32400 0 AKST} {4076650800 -28800 1 AKDT} {4097210400 -32400 0 AKST} } |
Changes to library/tzdata/Asia/Almaty.
︙ | ︙ | |||
48 49 50 51 52 53 54 | {1004234400 21600 0 ALMT} {1017540000 25200 1 ALMST} {1035684000 21600 0 ALMT} {1048989600 25200 1 ALMST} {1067133600 21600 0 ALMT} {1080439200 25200 1 ALMST} {1099188000 21600 0 ALMT} | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 48 49 50 51 52 53 54 55 56 | {1004234400 21600 0 ALMT} {1017540000 25200 1 ALMST} {1035684000 21600 0 ALMT} {1048989600 25200 1 ALMST} {1067133600 21600 0 ALMT} {1080439200 25200 1 ALMST} {1099188000 21600 0 ALMT} {1110823200 21600 0 ALMT} } |
Changes to library/tzdata/Asia/Aqtau.
︙ | ︙ | |||
50 51 52 53 54 55 56 | {1004234400 14400 0 AQTT} {1017540000 18000 1 AQTST} {1035684000 14400 0 AQTT} {1048989600 18000 1 AQTST} {1067133600 14400 0 AQTT} {1080439200 18000 1 AQTST} {1099188000 14400 0 AQTT} | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < | 50 51 52 53 54 55 56 57 58 | {1004234400 14400 0 AQTT} {1017540000 18000 1 AQTST} {1035684000 14400 0 AQTT} {1048989600 18000 1 AQTST} {1067133600 14400 0 AQTT} {1080439200 18000 1 AQTST} {1099188000 14400 0 AQTT} {1110830400 18000 0 AQTT} } |
Changes to library/tzdata/Asia/Aqtobe.
︙ | ︙ | |||
49 50 51 52 53 54 55 | {1004234400 18000 0 AQTT} {1017540000 21600 1 AQTST} {1035684000 18000 0 AQTT} {1048989600 21600 1 AQTST} {1067133600 18000 0 AQTT} {1080439200 21600 1 AQTST} {1099188000 18000 0 AQTT} | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 49 50 51 52 53 54 55 56 57 | {1004234400 18000 0 AQTT} {1017540000 21600 1 AQTST} {1035684000 18000 0 AQTT} {1048989600 21600 1 AQTST} {1067133600 18000 0 AQTT} {1080439200 21600 1 AQTST} {1099188000 18000 0 AQTT} {1110826800 18000 0 AQTT} } |
Changes to library/tzdata/Asia/Baku.
︙ | ︙ | |||
24 25 26 27 28 29 30 | {622605600 14400 0 BAKT} {638330400 18000 1 BAKST} {654660000 14400 0 BAKT} {670384800 14400 1 BAKST} {683496000 14400 0 AZST} {686109600 10800 0 AZT} {701812800 14400 1 AZST} | < | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | {622605600 14400 0 BAKT} {638330400 18000 1 BAKST} {654660000 14400 0 BAKT} {670384800 14400 1 BAKST} {683496000 14400 0 AZST} {686109600 10800 0 AZT} {701812800 14400 1 AZST} {717537600 14400 0 AZT} {820440000 14400 0 AZT} {828234000 18000 1 AZST} {846378000 14400 0 AZT} {852062400 14400 0 AZT} {859669200 18000 1 AZST} {877809600 14400 0 AZT} {891118800 18000 1 AZST} |
︙ | ︙ |
Changes to library/tzdata/Asia/Bishkek.
︙ | ︙ | |||
49 50 51 52 53 54 55 | {1017523800 21600 1 KGST} {1035664200 18000 0 KGT} {1048973400 21600 1 KGST} {1067113800 18000 0 KGT} {1080423000 21600 1 KGST} {1099168200 18000 0 KGT} {1111872600 21600 1 KGST} | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 49 50 51 52 53 54 55 56 57 | {1017523800 21600 1 KGST} {1035664200 18000 0 KGT} {1048973400 21600 1 KGST} {1067113800 18000 0 KGT} {1080423000 21600 1 KGST} {1099168200 18000 0 KGT} {1111872600 21600 1 KGST} {1123783200 21600 0 KGT} } |
Changes to library/tzdata/Asia/Dili.
1 2 3 4 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:Asia/Dili) { {-9223372036854775808 30140 0 LMT} | | | | | 1 2 3 4 5 6 7 8 9 10 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:Asia/Dili) { {-9223372036854775808 30140 0 LMT} {-1830414140 28800 0 TLT} {-879152400 32400 0 JST} {-770634000 32400 0 TLT} {199897200 28800 0 CIT} {969120000 32400 0 TLT} } |
Changes to library/tzdata/Asia/Jerusalem.
︙ | ︙ | |||
75 76 77 78 79 80 81 | {1001282400 7200 0 IST} {1017356400 10800 1 IDT} {1033941600 7200 0 IST} {1048806000 10800 1 IDT} {1065132000 7200 0 IST} {1081292400 10800 1 IDT} {1095804000 7200 0 IST} | | | | | | | | | < < < < | | | < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < < < < < < < < | | | | | | | | < < | < < < < < < | | | | < < < < < < < < < < < < | < < < < < < < < < < < < | < < | | | | | | < < | < < < < < < | | | | | | < < < < < < < < < < < < < < < < | | < < < < | | | < < | | | | | | | | < < < < < < < < | | | | < < | < < < < | | | | | 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 | {1001282400 7200 0 IST} {1017356400 10800 1 IDT} {1033941600 7200 0 IST} {1048806000 10800 1 IDT} {1065132000 7200 0 IST} {1081292400 10800 1 IDT} {1095804000 7200 0 IST} {1112313600 10800 1 IDT} {1128812400 7200 0 IST} {1143763200 10800 1 IDT} {1159657200 7200 0 IST} {1175212800 10800 1 IDT} {1189897200 7200 0 IST} {1206662400 10800 1 IDT} {1223161200 7200 0 IST} {1238112000 10800 1 IDT} {1254006000 7200 0 IST} {1269561600 10800 1 IDT} {1284246000 7200 0 IST} {1301616000 10800 1 IDT} {1317510000 7200 0 IST} {1333065600 10800 1 IDT} {1348354800 7200 0 IST} {1364515200 10800 1 IDT} {1378594800 7200 0 IST} {1395964800 10800 1 IDT} {1411858800 7200 0 IST} {1427414400 10800 1 IDT} {1442703600 7200 0 IST} {1459468800 10800 1 IDT} {1475967600 7200 0 IST} {1490918400 10800 1 IDT} {1506207600 7200 0 IST} {1522368000 10800 1 IDT} {1537052400 7200 0 IST} {1553817600 10800 1 IDT} {1570316400 7200 0 IST} {1585267200 10800 1 IDT} {1601161200 7200 0 IST} {1616716800 10800 1 IDT} {1631401200 7200 0 IST} {1648771200 10800 1 IDT} {1664665200 7200 0 IST} {1680220800 10800 1 IDT} {1695510000 7200 0 IST} {1711670400 10800 1 IDT} {1728169200 7200 0 IST} {1743120000 10800 1 IDT} {1759014000 7200 0 IST} {1774569600 10800 1 IDT} {1789858800 7200 0 IST} {1806019200 10800 1 IDT} {1823122800 7200 0 IST} {1838073600 10800 1 IDT} {1853362800 7200 0 IST} {1869523200 10800 1 IDT} {1884207600 7200 0 IST} {1900972800 10800 1 IDT} {1917471600 7200 0 IST} {1932422400 10800 1 IDT} {1947711600 7200 0 IST} {1963872000 10800 1 IDT} {1978556400 7200 0 IST} {1995926400 10800 1 IDT} {2011820400 7200 0 IST} {2027376000 10800 1 IDT} {2042060400 7200 0 IST} {2058825600 10800 1 IDT} {2075324400 7200 0 IST} {2090275200 10800 1 IDT} {2106169200 7200 0 IST} {2121724800 10800 1 IDT} {2136409200 7200 0 IST} } |
Changes to library/tzdata/Asia/Oral.
︙ | ︙ | |||
50 51 52 53 54 55 56 | {1004234400 14400 0 ORAT} {1017540000 18000 1 ORAST} {1035684000 14400 0 ORAT} {1048989600 18000 1 ORAST} {1067133600 14400 0 ORAT} {1080439200 18000 1 ORAST} {1099188000 14400 0 ORAT} | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < | 50 51 52 53 54 55 56 57 58 | {1004234400 14400 0 ORAT} {1017540000 18000 1 ORAST} {1035684000 14400 0 ORAT} {1048989600 18000 1 ORAST} {1067133600 14400 0 ORAT} {1080439200 18000 1 ORAST} {1099188000 14400 0 ORAT} {1110830400 18000 0 ORAT} } |
Changes to library/tzdata/Asia/Qyzylorda.
︙ | ︙ | |||
50 51 52 53 54 55 56 | {1004234400 21600 0 QYZT} {1017540000 25200 1 QYZST} {1035684000 21600 0 QYZT} {1048989600 25200 1 QYZST} {1067133600 21600 0 QYZT} {1080439200 25200 1 QYZST} {1099188000 21600 0 QYZT} | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 50 51 52 53 54 55 56 57 58 | {1004234400 21600 0 QYZT} {1017540000 25200 1 QYZST} {1035684000 21600 0 QYZT} {1048989600 25200 1 QYZST} {1067133600 21600 0 QYZT} {1080439200 25200 1 QYZST} {1099188000 21600 0 QYZT} {1110823200 21600 0 QYZT} } |
Changes to library/tzdata/Asia/Tehran.
︙ | ︙ | |||
76 77 78 79 80 81 82 | {1632252600 12600 0 IRST} {1647894600 16200 1 IRDT} {1663788600 12600 0 IRST} {1679430600 16200 1 IRDT} {1695324600 12600 0 IRST} {1710966600 16200 1 IRDT} {1726860600 12600 0 IRST} | | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | {1632252600 12600 0 IRST} {1647894600 16200 1 IRDT} {1663788600 12600 0 IRST} {1679430600 16200 1 IRDT} {1695324600 12600 0 IRST} {1710966600 16200 1 IRDT} {1726860600 12600 0 IRST} {1742589000 16200 1 IRDT} {1758483000 12600 0 IRST} {1774125000 16200 1 IRDT} {1790019000 12600 0 IRST} {1805661000 16200 1 IRDT} {1821555000 12600 0 IRST} {1837197000 16200 1 IRDT} {1853091000 12600 0 IRST} {1868733000 16200 1 IRDT} |
︙ | ︙ |
Changes to library/tzdata/Asia/Tokyo.
1 2 3 4 5 6 7 8 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:Asia/Tokyo) { {-9223372036854775808 33539 0 LMT} {-2587712400 32400 0 JST} {-2335251600 32400 0 CJT} {-1009875600 32400 0 JST} } | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:Asia/Tokyo) { {-9223372036854775808 33539 0 LMT} {-2587712400 32400 0 JST} {-2335251600 32400 0 CJT} {-1009875600 32400 0 JST} {-683794800 36000 1 JDT} {-672393600 32400 0 JST} {-654764400 36000 1 JDT} {-640944000 32400 0 JST} {-620290800 36000 1 JDT} {-609494400 32400 0 JST} {-588841200 36000 1 JDT} {-578044800 32400 0 JST} } |
Changes to library/tzdata/Australia/Adelaide.
︙ | ︙ | |||
78 79 80 81 82 83 84 | {1035684000 37800 1 CST} {1048989600 34200 0 CST} {1067133600 37800 1 CST} {1080439200 34200 0 CST} {1099188000 37800 1 CST} {1111888800 34200 0 CST} {1130637600 37800 1 CST} | | | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | {1035684000 37800 1 CST} {1048989600 34200 0 CST} {1067133600 37800 1 CST} {1080439200 34200 0 CST} {1099188000 37800 1 CST} {1111888800 34200 0 CST} {1130637600 37800 1 CST} {1143943200 34200 0 CST} {1162087200 37800 1 CST} {1174788000 34200 0 CST} {1193536800 37800 1 CST} {1206842400 34200 0 CST} {1224986400 37800 1 CST} {1238292000 34200 0 CST} {1256436000 37800 1 CST} |
︙ | ︙ |
Changes to library/tzdata/Australia/Broken_Hill.
︙ | ︙ | |||
80 81 82 83 84 85 86 | {1035684000 37800 1 CST} {1048989600 34200 0 CST} {1067133600 37800 1 CST} {1080439200 34200 0 CST} {1099188000 37800 1 CST} {1111888800 34200 0 CST} {1130637600 37800 1 CST} | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | {1035684000 37800 1 CST} {1048989600 34200 0 CST} {1067133600 37800 1 CST} {1080439200 34200 0 CST} {1099188000 37800 1 CST} {1111888800 34200 0 CST} {1130637600 37800 1 CST} {1143943200 34200 0 CST} {1162087200 37800 1 CST} {1174788000 34200 0 CST} {1193536800 37800 1 CST} {1206842400 34200 0 CST} {1224986400 37800 1 CST} {1238292000 34200 0 CST} {1256436000 37800 1 CST} |
︙ | ︙ |
Added library/tzdata/Australia/Currie.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:Australia/Currie) { {-9223372036854775808 34528 0 LMT} {-2345794528 36000 0 EST} {-1680508800 39600 1 EST} {-1669892400 39600 0 EST} {-1665392400 36000 0 EST} {-883641600 39600 1 EST} {-876128400 36000 0 EST} {-860400000 39600 1 EST} {-844678800 36000 0 EST} {-828345600 39600 1 EST} {-813229200 36000 0 EST} {47138400 36000 0 EST} {57722400 39600 1 EST} {68004000 36000 0 EST} {89172000 39600 1 EST} {100058400 36000 0 EST} {120621600 39600 1 EST} {131508000 36000 0 EST} {152071200 39600 1 EST} {162957600 36000 0 EST} {183520800 39600 1 EST} {195012000 36000 0 EST} {215575200 39600 1 EST} {226461600 36000 0 EST} {247024800 39600 1 EST} {257911200 36000 0 EST} {278474400 39600 1 EST} {289360800 36000 0 EST} {309924000 39600 1 EST} {320810400 36000 0 EST} {341373600 39600 1 EST} {352260000 36000 0 EST} {372823200 39600 1 EST} {386128800 36000 0 EST} {404877600 39600 1 EST} {417578400 36000 0 EST} {436327200 39600 1 EST} {447213600 36000 0 EST} {467776800 39600 1 EST} {478663200 36000 0 EST} {499226400 39600 1 EST} {510112800 36000 0 EST} {530071200 39600 1 EST} {542772000 36000 0 EST} {562125600 39600 1 EST} {574826400 36000 0 EST} {594180000 39600 1 EST} {606276000 36000 0 EST} {625629600 39600 1 EST} {637725600 36000 0 EST} {657079200 39600 1 EST} {670384800 36000 0 EST} {686714400 39600 1 EST} {701834400 36000 0 EST} {718164000 39600 1 EST} {733284000 36000 0 EST} {749613600 39600 1 EST} {764733600 36000 0 EST} {781063200 39600 1 EST} {796183200 36000 0 EST} {812512800 39600 1 EST} {828237600 36000 0 EST} {844567200 39600 1 EST} {859687200 36000 0 EST} {876016800 39600 1 EST} {891136800 36000 0 EST} {907466400 39600 1 EST} {922586400 36000 0 EST} {938916000 39600 1 EST} {954036000 36000 0 EST} {967341600 39600 1 EST} {985485600 36000 0 EST} {1002420000 39600 1 EST} {1017540000 36000 0 EST} {1033869600 39600 1 EST} {1048989600 36000 0 EST} {1065319200 39600 1 EST} {1080439200 36000 0 EST} {1096768800 39600 1 EST} {1111888800 36000 0 EST} {1128218400 39600 1 EST} {1143943200 36000 0 EST} {1159668000 39600 1 EST} {1174788000 36000 0 EST} {1191722400 39600 1 EST} {1206842400 36000 0 EST} {1223172000 39600 1 EST} {1238292000 36000 0 EST} {1254621600 39600 1 EST} {1269741600 36000 0 EST} {1286071200 39600 1 EST} {1301191200 36000 0 EST} {1317520800 39600 1 EST} {1332640800 36000 0 EST} {1349575200 39600 1 EST} {1364695200 36000 0 EST} {1381024800 39600 1 EST} {1396144800 36000 0 EST} {1412474400 39600 1 EST} {1427594400 36000 0 EST} {1443924000 39600 1 EST} {1459044000 36000 0 EST} {1475373600 39600 1 EST} {1490493600 36000 0 EST} {1506823200 39600 1 EST} {1521943200 36000 0 EST} {1538877600 39600 1 EST} {1553997600 36000 0 EST} {1570327200 39600 1 EST} {1585447200 36000 0 EST} {1601776800 39600 1 EST} {1616896800 36000 0 EST} {1633226400 39600 1 EST} {1648346400 36000 0 EST} {1664676000 39600 1 EST} {1679796000 36000 0 EST} {1696125600 39600 1 EST} {1711850400 36000 0 EST} {1728180000 39600 1 EST} {1743300000 36000 0 EST} {1759629600 39600 1 EST} {1774749600 36000 0 EST} {1791079200 39600 1 EST} {1806199200 36000 0 EST} {1822528800 39600 1 EST} {1837648800 36000 0 EST} {1853978400 39600 1 EST} {1869098400 36000 0 EST} {1886032800 39600 1 EST} {1901152800 36000 0 EST} {1917482400 39600 1 EST} {1932602400 36000 0 EST} {1948932000 39600 1 EST} {1964052000 36000 0 EST} {1980381600 39600 1 EST} {1995501600 36000 0 EST} {2011831200 39600 1 EST} {2026951200 36000 0 EST} {2043280800 39600 1 EST} {2058400800 36000 0 EST} {2075335200 39600 1 EST} {2090455200 36000 0 EST} {2106784800 39600 1 EST} {2121904800 36000 0 EST} {2138234400 39600 1 EST} {2153354400 36000 0 EST} {2169684000 39600 1 EST} {2184804000 36000 0 EST} {2201133600 39600 1 EST} {2216253600 36000 0 EST} {2233188000 39600 1 EST} {2248308000 36000 0 EST} {2264637600 39600 1 EST} {2279757600 36000 0 EST} {2296087200 39600 1 EST} {2311207200 36000 0 EST} {2327536800 39600 1 EST} {2342656800 36000 0 EST} {2358986400 39600 1 EST} {2374106400 36000 0 EST} {2390436000 39600 1 EST} {2405556000 36000 0 EST} {2422490400 39600 1 EST} {2437610400 36000 0 EST} {2453940000 39600 1 EST} {2469060000 36000 0 EST} {2485389600 39600 1 EST} {2500509600 36000 0 EST} {2516839200 39600 1 EST} {2531959200 36000 0 EST} {2548288800 39600 1 EST} {2563408800 36000 0 EST} {2579738400 39600 1 EST} {2595463200 36000 0 EST} {2611792800 39600 1 EST} {2626912800 36000 0 EST} {2643242400 39600 1 EST} {2658362400 36000 0 EST} {2674692000 39600 1 EST} {2689812000 36000 0 EST} {2706141600 39600 1 EST} {2721261600 36000 0 EST} {2737591200 39600 1 EST} {2752711200 36000 0 EST} {2769645600 39600 1 EST} {2784765600 36000 0 EST} {2801095200 39600 1 EST} {2816215200 36000 0 EST} {2832544800 39600 1 EST} {2847664800 36000 0 EST} {2863994400 39600 1 EST} {2879114400 36000 0 EST} {2895444000 39600 1 EST} {2910564000 36000 0 EST} {2926893600 39600 1 EST} {2942013600 36000 0 EST} {2958948000 39600 1 EST} {2974068000 36000 0 EST} {2990397600 39600 1 EST} {3005517600 36000 0 EST} {3021847200 39600 1 EST} {3036967200 36000 0 EST} {3053296800 39600 1 EST} {3068416800 36000 0 EST} {3084746400 39600 1 EST} {3099866400 36000 0 EST} {3116800800 39600 1 EST} {3131920800 36000 0 EST} {3148250400 39600 1 EST} {3163370400 36000 0 EST} {3179700000 39600 1 EST} {3194820000 36000 0 EST} {3211149600 39600 1 EST} {3226269600 36000 0 EST} {3242599200 39600 1 EST} {3257719200 36000 0 EST} {3274048800 39600 1 EST} {3289168800 36000 0 EST} {3306103200 39600 1 EST} {3321223200 36000 0 EST} {3337552800 39600 1 EST} {3352672800 36000 0 EST} {3369002400 39600 1 EST} {3384122400 36000 0 EST} {3400452000 39600 1 EST} {3415572000 36000 0 EST} {3431901600 39600 1 EST} {3447021600 36000 0 EST} {3463351200 39600 1 EST} {3479076000 36000 0 EST} {3495405600 39600 1 EST} {3510525600 36000 0 EST} {3526855200 39600 1 EST} {3541975200 36000 0 EST} {3558304800 39600 1 EST} {3573424800 36000 0 EST} {3589754400 39600 1 EST} {3604874400 36000 0 EST} {3621204000 39600 1 EST} {3636324000 36000 0 EST} {3653258400 39600 1 EST} {3668378400 36000 0 EST} {3684708000 39600 1 EST} {3699828000 36000 0 EST} {3716157600 39600 1 EST} {3731277600 36000 0 EST} {3747607200 39600 1 EST} {3762727200 36000 0 EST} {3779056800 39600 1 EST} {3794176800 36000 0 EST} {3810506400 39600 1 EST} {3825626400 36000 0 EST} {3842560800 39600 1 EST} {3857680800 36000 0 EST} {3874010400 39600 1 EST} {3889130400 36000 0 EST} {3905460000 39600 1 EST} {3920580000 36000 0 EST} {3936909600 39600 1 EST} {3952029600 36000 0 EST} {3968359200 39600 1 EST} {3983479200 36000 0 EST} {4000413600 39600 1 EST} {4015533600 36000 0 EST} {4031863200 39600 1 EST} {4046983200 36000 0 EST} {4063312800 39600 1 EST} {4078432800 36000 0 EST} {4094762400 39600 1 EST} } |
Changes to library/tzdata/Australia/Hobart.
︙ | ︙ | |||
86 87 88 89 90 91 92 | {1033869600 39600 1 EST} {1048989600 36000 0 EST} {1065319200 39600 1 EST} {1080439200 36000 0 EST} {1096768800 39600 1 EST} {1111888800 36000 0 EST} {1128218400 39600 1 EST} | | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | {1033869600 39600 1 EST} {1048989600 36000 0 EST} {1065319200 39600 1 EST} {1080439200 36000 0 EST} {1096768800 39600 1 EST} {1111888800 36000 0 EST} {1128218400 39600 1 EST} {1143943200 36000 0 EST} {1159668000 39600 1 EST} {1174788000 36000 0 EST} {1191722400 39600 1 EST} {1206842400 36000 0 EST} {1223172000 39600 1 EST} {1238292000 36000 0 EST} {1254621600 39600 1 EST} |
︙ | ︙ |
Changes to library/tzdata/Australia/Lord_Howe.
︙ | ︙ | |||
49 50 51 52 53 54 55 | {1035646200 39600 1 LHST} {1048950000 37800 0 LHST} {1067095800 39600 1 LHST} {1080399600 37800 0 LHST} {1099150200 39600 1 LHST} {1111849200 37800 0 LHST} {1130599800 39600 1 LHST} | | | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | {1035646200 39600 1 LHST} {1048950000 37800 0 LHST} {1067095800 39600 1 LHST} {1080399600 37800 0 LHST} {1099150200 39600 1 LHST} {1111849200 37800 0 LHST} {1130599800 39600 1 LHST} {1143903600 37800 0 LHST} {1162049400 39600 1 LHST} {1174748400 37800 0 LHST} {1193499000 39600 1 LHST} {1206802800 37800 0 LHST} {1224948600 39600 1 LHST} {1238252400 37800 0 LHST} {1256398200 39600 1 LHST} |
︙ | ︙ |
Changes to library/tzdata/Australia/Melbourne.
︙ | ︙ | |||
77 78 79 80 81 82 83 | {1035684000 39600 1 EST} {1048989600 36000 0 EST} {1067133600 39600 1 EST} {1080439200 36000 0 EST} {1099188000 39600 1 EST} {1111888800 36000 0 EST} {1130637600 39600 1 EST} | | | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | {1035684000 39600 1 EST} {1048989600 36000 0 EST} {1067133600 39600 1 EST} {1080439200 36000 0 EST} {1099188000 39600 1 EST} {1111888800 36000 0 EST} {1130637600 39600 1 EST} {1143943200 36000 0 EST} {1162087200 39600 1 EST} {1174788000 36000 0 EST} {1193536800 39600 1 EST} {1206842400 36000 0 EST} {1224986400 39600 1 EST} {1238292000 36000 0 EST} {1256436000 39600 1 EST} |
︙ | ︙ |
Changes to library/tzdata/Australia/Sydney.
︙ | ︙ | |||
77 78 79 80 81 82 83 | {1035684000 39600 1 EST} {1048989600 36000 0 EST} {1067133600 39600 1 EST} {1080439200 36000 0 EST} {1099188000 39600 1 EST} {1111888800 36000 0 EST} {1130637600 39600 1 EST} | | | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | {1035684000 39600 1 EST} {1048989600 36000 0 EST} {1067133600 39600 1 EST} {1080439200 36000 0 EST} {1099188000 39600 1 EST} {1111888800 36000 0 EST} {1130637600 39600 1 EST} {1143943200 36000 0 EST} {1162087200 39600 1 EST} {1174788000 36000 0 EST} {1193536800 39600 1 EST} {1206842400 36000 0 EST} {1224986400 39600 1 EST} {1238292000 36000 0 EST} {1256436000 39600 1 EST} |
︙ | ︙ |
Changes to library/tzdata/Brazil/Acre.
1 | # created by ../tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(America/Rio_Branco)]} { LoadTimeZoneFile America/Rio_Branco } set TZData(:Brazil/Acre) $TZData(:America/Rio_Branco) |
Changes to library/tzdata/EST.
1 | # created by ../tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(America/Panama)]} { LoadTimeZoneFile America/Panama } set TZData(:EST) $TZData(:America/Panama) |
Changes to library/tzdata/Europe/Belfast.
1 | # created by ../tools/tclZIC.tcl - do not edit | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(Europe/London)]} { LoadTimeZoneFile Europe/London } set TZData(:Europe/Belfast) $TZData(:Europe/London) |
Changes to library/tzdata/Europe/Copenhagen.
1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:Europe/Copenhagen) { {-9223372036854775808 3020 0 LMT} {-2524524620 3020 0 CMT} | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:Europe/Copenhagen) { {-9223372036854775808 3020 0 LMT} {-2524524620 3020 0 CMT} {-2398294220 3600 0 CET} {-1692496800 7200 1 CEST} {-1680490800 3600 0 CET} {-935110800 7200 1 CEST} {-857253600 3600 0 CET} {-844552800 7200 1 CEST} {-828223200 3600 0 CET} {-812498400 7200 1 CEST} |
︙ | ︙ |
Changes to library/tzdata/Europe/Warsaw.
︙ | ︙ | |||
17 18 19 20 21 22 23 | {-844552800 7200 1 CEST} {-828223200 3600 0 CET} {-812498400 7200 1 CEST} {-796870800 3600 0 CET} {-796604400 3600 0 CET} {-778726800 7200 1 CEST} {-762660000 3600 0 CET} | | | > > | | | | | | 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 | {-844552800 7200 1 CEST} {-828223200 3600 0 CET} {-812498400 7200 1 CEST} {-796870800 3600 0 CET} {-796604400 3600 0 CET} {-778726800 7200 1 CEST} {-762660000 3600 0 CET} {-748483200 7200 1 CEST} {-733269600 3600 0 CET} {-715212000 7200 1 CEST} {-701906400 3600 0 CET} {-684972000 7200 1 CEST} {-670456800 3600 0 CET} {-654127200 7200 1 CEST} {-639007200 3600 0 CET} {-397090800 7200 1 CEST} {-386809200 3600 0 CET} {-371084400 7200 1 CEST} {-355359600 3600 0 CET} {-334191600 7200 1 CEST} {-323305200 3600 0 CET} {-307580400 7200 1 CEST} {-291855600 3600 0 CET} {-271292400 7200 1 CEST} {-260406000 3600 0 CET} {-239842800 7200 1 CEST} {-228956400 3600 0 CET} {-208393200 7200 1 CEST} {-197506800 3600 0 CET} {-176338800 7200 1 CEST} {-166057200 3600 0 CET} {220921200 3600 0 CET} {228877200 7200 1 CEST} {243997200 3600 0 CET} {260326800 7200 1 CEST} {276051600 3600 0 CET} {291776400 7200 1 CEST} {307501200 3600 0 CET} {323830800 7200 1 CEST} |
︙ | ︙ | |||
62 63 64 65 66 67 68 69 70 71 72 73 74 75 | {465354000 3600 0 CET} {481078800 7200 1 CEST} {496803600 3600 0 CET} {512528400 7200 1 CEST} {528253200 3600 0 CET} {543978000 7200 1 CEST} {559702800 3600 0 CET} {575427600 7200 1 CEST} {591152400 3600 0 CET} {606877200 7200 1 CEST} {622602000 3600 0 CET} {638326800 7200 1 CEST} {654656400 3600 0 CET} {670381200 7200 1 CEST} | > | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | {465354000 3600 0 CET} {481078800 7200 1 CEST} {496803600 3600 0 CET} {512528400 7200 1 CEST} {528253200 3600 0 CET} {543978000 7200 1 CEST} {559702800 3600 0 CET} {567990000 3600 0 CET} {575427600 7200 1 CEST} {591152400 3600 0 CET} {606877200 7200 1 CEST} {622602000 3600 0 CET} {638326800 7200 1 CEST} {654656400 3600 0 CET} {670381200 7200 1 CEST} |
︙ | ︙ | |||
84 85 86 87 88 89 90 | {811904400 3600 0 CET} {828234000 7200 1 CEST} {846378000 3600 0 CET} {859683600 7200 1 CEST} {877827600 3600 0 CET} {891133200 7200 1 CEST} {909277200 3600 0 CET} | < | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | {811904400 3600 0 CET} {828234000 7200 1 CEST} {846378000 3600 0 CET} {859683600 7200 1 CEST} {877827600 3600 0 CET} {891133200 7200 1 CEST} {909277200 3600 0 CET} {922582800 7200 1 CEST} {941331600 3600 0 CET} {954032400 7200 1 CEST} {972781200 3600 0 CET} {985482000 7200 1 CEST} {1004230800 3600 0 CET} {1017536400 7200 1 CEST} |
︙ | ︙ |
Changes to library/tzdata/GMT+0.
1 | # created by ../tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(Etc/GMT)]} { LoadTimeZoneFile Etc/GMT } set TZData(:GMT+0) $TZData(:Etc/GMT) |
Changes to library/tzdata/GMT-0.
1 | # created by ../tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(Etc/GMT)]} { LoadTimeZoneFile Etc/GMT } set TZData(:GMT-0) $TZData(:Etc/GMT) |
Changes to library/tzdata/GMT0.
1 | # created by ../tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(Etc/GMT)]} { LoadTimeZoneFile Etc/GMT } set TZData(:GMT0) $TZData(:Etc/GMT) |
Changes to library/tzdata/Greenwich.
1 | # created by ../tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(Etc/GMT)]} { LoadTimeZoneFile Etc/GMT } set TZData(:Greenwich) $TZData(:Etc/GMT) |
Changes to library/tzdata/Indian/Chagos.
1 2 3 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:Indian/Chagos) { | | > | 1 2 3 4 5 6 7 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:Indian/Chagos) { {-9223372036854775808 17380 0 LMT} {-1988167780 18000 0 IOT} {820436400 21600 0 IOT} } |
Changes to library/tzdata/Indian/Cocos.
1 2 3 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:Indian/Cocos) { | | > | 1 2 3 4 5 6 | # created by ../tools/tclZIC.tcl - do not edit set TZData(:Indian/Cocos) { {-9223372036854775808 23260 0 LMT} {-2209012060 23400 0 CCT} } |
Changes to library/tzdata/Navajo.
1 | # created by ../tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(America/Denver)]} { LoadTimeZoneFile America/Denver } set TZData(:Navajo) $TZData(:America/Denver) |
Changes to library/tzdata/Pacific/Yap.
1 | # created by ../tools/tclZIC.tcl - do not edit | > > | | < < < < | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(Pacific/Truk)]} { LoadTimeZoneFile Pacific/Truk } set TZData(:Pacific/Yap) $TZData(:Pacific/Truk) |
Changes to library/tzdata/US/East-Indiana.
1 | # created by ../tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(America/Indiana/Indianapolis)]} { LoadTimeZoneFile America/Indiana/Indianapolis } set TZData(:US/East-Indiana) $TZData(:America/Indiana/Indianapolis) |
Changes to library/tzdata/Universal.
1 | # created by ../tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(Etc/UTC)]} { LoadTimeZoneFile Etc/UTC } set TZData(:Universal) $TZData(:Etc/UTC) |
Changes to library/tzdata/Zulu.
1 | # created by ../tools/tclZIC.tcl - do not edit | | | | | 1 2 3 4 5 | # created by ../tools/tclZIC.tcl - do not edit if {![info exists TZData(Etc/UTC)]} { LoadTimeZoneFile Etc/UTC } set TZData(:Zulu) $TZData(:Etc/UTC) |
Changes to library/word.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 | # word.tcl -- # # This file defines various procedures for computing word boundaries # in strings. This file is primarily needed so Tk text and entry # widgets behave properly for different platforms. # # Copyright (c) 1996 by Sun Microsystems, Inc. # Copyright (c) 1998 by Scritpics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # word.tcl -- # # This file defines various procedures for computing word boundaries # in strings. This file is primarily needed so Tk text and entry # widgets behave properly for different platforms. # # Copyright (c) 1996 by Sun Microsystems, Inc. # Copyright (c) 1998 by Scritpics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: word.tcl,v 1.7.6.1 2005/08/02 18:16:15 dgp Exp $ # The following variables are used to determine which characters are # interpreted as white space. if {$::tcl_platform(platform) eq "windows"} { # Windows style - any but a unicode space char set tcl_wordchars "\\S" set tcl_nonwordchars "\\s" } else { # Motif style - any unicode word char (number, letter, or underscore) set tcl_wordchars "\\w" set tcl_nonwordchars "\\W" |
︙ | ︙ | |||
54 55 56 57 58 59 60 | # # Arguments: # str - String to search. # start - Index into string specifying starting point. proc tcl_wordBreakBefore {str start} { global tcl_nonwordchars tcl_wordchars | | | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | # # Arguments: # str - String to search. # start - Index into string specifying starting point. proc tcl_wordBreakBefore {str start} { global tcl_nonwordchars tcl_wordchars if {$start eq "end"} { set start [string length $str] } if {[regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result]} { return [lindex $result 1] } return -1 } |
︙ | ︙ | |||
116 117 118 119 120 121 122 | # # Arguments: # str - String to search. # start - Index into string specifying starting point. proc tcl_startOfPreviousWord {str start} { global tcl_nonwordchars tcl_wordchars | | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | # # Arguments: # str - String to search. # start - Index into string specifying starting point. proc tcl_startOfPreviousWord {str start} { global tcl_nonwordchars tcl_wordchars if {$start eq "end"} { set start [string length $str] } if {[regexp -indices \ "$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$" \ [string range $str 0 [expr {$start - 1}]] result word]} { return [lindex $word 0] } return -1 } |
Added libtommath/bn.pdf.
cannot compute difference between binary files
Added libtommath/bn.tex.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentclass[b5paper]{book} \usepackage{hyperref} \usepackage{makeidx} \usepackage{amssymb} \usepackage{color} \usepackage{alltt} \usepackage{graphicx} \usepackage{layout} \def\union{\cup} \def\intersect{\cap} \def\getsrandom{\stackrel{\rm R}{\gets}} \def\cross{\times} \def\cat{\hspace{0.5em} \| \hspace{0.5em}} \def\catn{$\|$} \def\divides{\hspace{0.3em} | \hspace{0.3em}} \def\nequiv{\not\equiv} \def\approx{\raisebox{0.2ex}{\mbox{\small $\sim$}}} \def\lcm{{\rm lcm}} \def\gcd{{\rm gcd}} \def\log{{\rm log}} \def\ord{{\rm ord}} \def\abs{{\mathit abs}} \def\rep{{\mathit rep}} \def\mod{{\mathit\ mod\ }} \renewcommand{\pmod}[1]{\ ({\rm mod\ }{#1})} \newcommand{\floor}[1]{\left\lfloor{#1}\right\rfloor} \newcommand{\ceil}[1]{\left\lceil{#1}\right\rceil} \def\Or{{\rm\ or\ }} \def\And{{\rm\ and\ }} \def\iff{\hspace{1em}\Longleftrightarrow\hspace{1em}} \def\implies{\Rightarrow} \def\undefined{{\rm ``undefined"}} \def\Proof{\vspace{1ex}\noindent {\bf Proof:}\hspace{1em}} \let\oldphi\phi \def\phi{\varphi} \def\Pr{{\rm Pr}} \newcommand{\str}[1]{{\mathbf{#1}}} \def\F{{\mathbb F}} \def\N{{\mathbb N}} \def\Z{{\mathbb Z}} \def\R{{\mathbb R}} \def\C{{\mathbb C}} \def\Q{{\mathbb Q}} \definecolor{DGray}{gray}{0.5} \newcommand{\emailaddr}[1]{\mbox{$<${#1}$>$}} \def\twiddle{\raisebox{0.3ex}{\mbox{\tiny $\sim$}}} \def\gap{\vspace{0.5ex}} \makeindex \begin{document} \frontmatter \pagestyle{empty} \title{LibTomMath User Manual \\ v0.36} \author{Tom St Denis \\ [email protected]} \maketitle This text, the library and the accompanying textbook are all hereby placed in the public domain. This book has been formatted for B5 [176x250] paper using the \LaTeX{} {\em book} macro package. \vspace{10cm} \begin{flushright}Open Source. Open Academia. Open Minds. \mbox{ } Tom St Denis, Ontario, Canada \end{flushright} \tableofcontents \listoffigures \mainmatter \pagestyle{headings} \chapter{Introduction} \section{What is LibTomMath?} LibTomMath is a library of source code which provides a series of efficient and carefully written functions for manipulating large integer numbers. It was written in portable ISO C source code so that it will build on any platform with a conforming C compiler. In a nutshell the library was written from scratch with verbose comments to help instruct computer science students how to implement ``bignum'' math. However, the resulting code has proven to be very useful. It has been used by numerous universities, commercial and open source software developers. It has been used on a variety of platforms ranging from Linux and Windows based x86 to ARM based Gameboys and PPC based MacOS machines. \section{License} As of the v0.25 the library source code has been placed in the public domain with every new release. As of the v0.28 release the textbook ``Implementing Multiple Precision Arithmetic'' has been placed in the public domain with every new release as well. This textbook is meant to compliment the project by providing a more solid walkthrough of the development algorithms used in the library. Since both\footnote{Note that the MPI files under mtest/ are copyrighted by Michael Fromberger. They are not required to use LibTomMath.} are in the public domain everyone is entitled to do with them as they see fit. \section{Building LibTomMath} LibTomMath is meant to be very ``GCC friendly'' as it comes with a makefile well suited for GCC. However, the library will also build in MSVC, Borland C out of the box. For any other ISO C compiler a makefile will have to be made by the end developer. \subsection{Static Libraries} To build as a static library for GCC issue the following \begin{alltt} make \end{alltt} command. This will build the library and archive the object files in ``libtommath.a''. Now you link against that and include ``tommath.h'' within your programs. Alternatively to build with MSVC issue the following \begin{alltt} nmake -f makefile.msvc \end{alltt} This will build the library and archive the object files in ``tommath.lib''. This has been tested with MSVC version 6.00 with service pack 5. \subsection{Shared Libraries} To build as a shared library for GCC issue the following \begin{alltt} make -f makefile.shared \end{alltt} This requires the ``libtool'' package (common on most Linux/BSD systems). It will build LibTomMath as both shared and static then install (by default) into /usr/lib as well as install the header files in /usr/include. The shared library (resource) will be called ``libtommath.la'' while the static library called ``libtommath.a''. Generally you use libtool to link your application against the shared object. There is limited support for making a ``DLL'' in windows via the ``makefile.cygwin\_dll'' makefile. It requires Cygwin to work with since it requires the auto-export/import functionality. The resulting DLL and import library ``libtommath.dll.a'' can be used to link LibTomMath dynamically to any Windows program using Cygwin. \subsection{Testing} To build the library and the test harness type \begin{alltt} make test \end{alltt} This will build the library, ``test'' and ``mtest/mtest''. The ``test'' program will accept test vectors and verify the results. ``mtest/mtest'' will generate test vectors using the MPI library by Michael Fromberger\footnote{A copy of MPI is included in the package}. Simply pipe mtest into test using \begin{alltt} mtest/mtest | test \end{alltt} If you do not have a ``/dev/urandom'' style RNG source you will have to write your own PRNG and simply pipe that into mtest. For example, if your PRNG program is called ``myprng'' simply invoke \begin{alltt} myprng | mtest/mtest | test \end{alltt} This will output a row of numbers that are increasing. Each column is a different test (such as addition, multiplication, etc) that is being performed. The numbers represent how many times the test was invoked. If an error is detected the program will exit with a dump of the relevent numbers it was working with. \section{Build Configuration} LibTomMath can configured at build time in three phases we shall call ``depends'', ``tweaks'' and ``trims''. Each phase changes how the library is built and they are applied one after another respectively. To make the system more powerful you can tweak the build process. Classes are defined in the file ``tommath\_superclass.h''. By default, the symbol ``LTM\_ALL'' shall be defined which simply instructs the system to build all of the functions. This is how LibTomMath used to be packaged. This will give you access to every function LibTomMath offers. However, there are cases where such a build is not optional. For instance, you want to perform RSA operations. You don't need the vast majority of the library to perform these operations. Aside from LTM\_ALL there is another pre--defined class ``SC\_RSA\_1'' which works in conjunction with the RSA from LibTomCrypt. Additional classes can be defined base on the need of the user. \subsection{Build Depends} In the file tommath\_class.h you will see a large list of C ``defines'' followed by a series of ``ifdefs'' which further define symbols. All of the symbols (technically they're macros $\ldots$) represent a given C source file. For instance, BN\_MP\_ADD\_C represents the file ``bn\_mp\_add.c''. When a define has been enabled the function in the respective file will be compiled and linked into the library. Accordingly when the define is absent the file will not be compiled and not contribute any size to the library. You will also note that the header tommath\_class.h is actually recursively included (it includes itself twice). This is to help resolve as many dependencies as possible. In the last pass the symbol LTM\_LAST will be defined. This is useful for ``trims''. \subsection{Build Tweaks} A tweak is an algorithm ``alternative''. For example, to provide tradeoffs (usually between size and space). They can be enabled at any pass of the configuration phase. \begin{small} \begin{center} \begin{tabular}{|l|l|} \hline \textbf{Define} & \textbf{Purpose} \\ \hline BN\_MP\_DIV\_SMALL & Enables a slower, smaller and equally \\ & functional mp\_div() function \\ \hline \end{tabular} \end{center} \end{small} \subsection{Build Trims} A trim is a manner of removing functionality from a function that is not required. For instance, to perform RSA cryptography you only require exponentiation with odd moduli so even moduli support can be safely removed. Build trims are meant to be defined on the last pass of the configuration which means they are to be defined only if LTM\_LAST has been defined. \subsubsection{Moduli Related} \begin{small} \begin{center} \begin{tabular}{|l|l|} \hline \textbf{Restriction} & \textbf{Undefine} \\ \hline Exponentiation with odd moduli only & BN\_S\_MP\_EXPTMOD\_C \\ & BN\_MP\_REDUCE\_C \\ & BN\_MP\_REDUCE\_SETUP\_C \\ & BN\_S\_MP\_MUL\_HIGH\_DIGS\_C \\ & BN\_FAST\_S\_MP\_MUL\_HIGH\_DIGS\_C \\ \hline Exponentiation with random odd moduli & (The above plus the following) \\ & BN\_MP\_REDUCE\_2K\_C \\ & BN\_MP\_REDUCE\_2K\_SETUP\_C \\ & BN\_MP\_REDUCE\_IS\_2K\_C \\ & BN\_MP\_DR\_IS\_MODULUS\_C \\ & BN\_MP\_DR\_REDUCE\_C \\ & BN\_MP\_DR\_SETUP\_C \\ \hline Modular inverse odd moduli only & BN\_MP\_INVMOD\_SLOW\_C \\ \hline Modular inverse (both, smaller/slower) & BN\_FAST\_MP\_INVMOD\_C \\ \hline \end{tabular} \end{center} \end{small} \subsubsection{Operand Size Related} \begin{small} \begin{center} \begin{tabular}{|l|l|} \hline \textbf{Restriction} & \textbf{Undefine} \\ \hline Moduli $\le 2560$ bits & BN\_MP\_MONTGOMERY\_REDUCE\_C \\ & BN\_S\_MP\_MUL\_DIGS\_C \\ & BN\_S\_MP\_MUL\_HIGH\_DIGS\_C \\ & BN\_S\_MP\_SQR\_C \\ \hline Polynomial Schmolynomial & BN\_MP\_KARATSUBA\_MUL\_C \\ & BN\_MP\_KARATSUBA\_SQR\_C \\ & BN\_MP\_TOOM\_MUL\_C \\ & BN\_MP\_TOOM\_SQR\_C \\ \hline \end{tabular} \end{center} \end{small} \section{Purpose of LibTomMath} Unlike GNU MP (GMP) Library, LIP, OpenSSL or various other commercial kits (Miracl), LibTomMath was not written with bleeding edge performance in mind. First and foremost LibTomMath was written to be entirely open. Not only is the source code public domain (unlike various other GPL/etc licensed code), not only is the code freely downloadable but the source code is also accessible for computer science students attempting to learn ``BigNum'' or multiple precision arithmetic techniques. LibTomMath was written to be an instructive collection of source code. This is why there are many comments, only one function per source file and often I use a ``middle-road'' approach where I don't cut corners for an extra 2\% speed increase. Source code alone cannot really teach how the algorithms work which is why I also wrote a textbook that accompanies the library (beat that!). So you may be thinking ``should I use LibTomMath?'' and the answer is a definite maybe. Let me tabulate what I think are the pros and cons of LibTomMath by comparing it to the math routines from GnuPG\footnote{GnuPG v1.2.3 versus LibTomMath v0.28}. \newpage\begin{figure}[here] \begin{small} \begin{center} \begin{tabular}{|l|c|c|l|} \hline \textbf{Criteria} & \textbf{Pro} & \textbf{Con} & \textbf{Notes} \\ \hline Few lines of code per file & X & & GnuPG $ = 300.9$, LibTomMath $ = 71.97$ \\ \hline Commented function prototypes & X && GnuPG function names are cryptic. \\ \hline Speed && X & LibTomMath is slower. \\ \hline Totally free & X & & GPL has unfavourable restrictions.\\ \hline Large function base & X & & GnuPG is barebones. \\ \hline Five modular reduction algorithms & X & & Faster modular exponentiation for a variety of moduli. \\ \hline Portable & X & & GnuPG requires configuration to build. \\ \hline \end{tabular} \end{center} \end{small} \caption{LibTomMath Valuation} \end{figure} It may seem odd to compare LibTomMath to GnuPG since the math in GnuPG is only a small portion of the entire application. However, LibTomMath was written with cryptography in mind. It provides essentially all of the functions a cryptosystem would require when working with large integers. So it may feel tempting to just rip the math code out of GnuPG (or GnuMP where it was taken from originally) in your own application but I think there are reasons not to. While LibTomMath is slower than libraries such as GnuMP it is not normally significantly slower. On x86 machines the difference is normally a factor of two when performing modular exponentiations. It depends largely on the processor, compiler and the moduli being used. Essentially the only time you wouldn't use LibTomMath is when blazing speed is the primary concern. However, on the other side of the coin LibTomMath offers you a totally free (public domain) well structured math library that is very flexible, complete and performs well in resource contrained environments. Fast RSA for example can be performed with as little as 8KB of ram for data (again depending on build options). \chapter{Getting Started with LibTomMath} \section{Building Programs} In order to use LibTomMath you must include ``tommath.h'' and link against the appropriate library file (typically libtommath.a). There is no library initialization required and the entire library is thread safe. \section{Return Codes} There are three possible return codes a function may return. \index{MP\_OKAY}\index{MP\_YES}\index{MP\_NO}\index{MP\_VAL}\index{MP\_MEM} \begin{figure}[here!] \begin{center} \begin{small} \begin{tabular}{|l|l|} \hline \textbf{Code} & \textbf{Meaning} \\ \hline MP\_OKAY & The function succeeded. \\ \hline MP\_VAL & The function input was invalid. \\ \hline MP\_MEM & Heap memory exhausted. \\ \hline &\\ \hline MP\_YES & Response is yes. \\ \hline MP\_NO & Response is no. \\ \hline \end{tabular} \end{small} \end{center} \caption{Return Codes} \end{figure} The last two codes listed are not actually ``return'ed'' by a function. They are placed in an integer (the caller must provide the address of an integer it can store to) which the caller can access. To convert one of the three return codes to a string use the following function. \index{mp\_error\_to\_string} \begin{alltt} char *mp_error_to_string(int code); \end{alltt} This will return a pointer to a string which describes the given error code. It will not work for the return codes MP\_YES and MP\_NO. \section{Data Types} The basic ``multiple precision integer'' type is known as the ``mp\_int'' within LibTomMath. This data type is used to organize all of the data required to manipulate the integer it represents. Within LibTomMath it has been prototyped as the following. \index{mp\_int} \begin{alltt} typedef struct \{ int used, alloc, sign; mp_digit *dp; \} mp_int; \end{alltt} Where ``mp\_digit'' is a data type that represents individual digits of the integer. By default, an mp\_digit is the ISO C ``unsigned long'' data type and each digit is $28-$bits long. The mp\_digit type can be configured to suit other platforms by defining the appropriate macros. All LTM functions that use the mp\_int type will expect a pointer to mp\_int structure. You must allocate memory to hold the structure itself by yourself (whether off stack or heap it doesn't matter). The very first thing that must be done to use an mp\_int is that it must be initialized. \section{Function Organization} The arithmetic functions of the library are all organized to have the same style prototype. That is source operands are passed on the left and the destination is on the right. For instance, \begin{alltt} mp_add(&a, &b, &c); /* c = a + b */ mp_mul(&a, &a, &c); /* c = a * a */ mp_div(&a, &b, &c, &d); /* c = [a/b], d = a mod b */ \end{alltt} Another feature of the way the functions have been implemented is that source operands can be destination operands as well. For instance, \begin{alltt} mp_add(&a, &b, &b); /* b = a + b */ mp_div(&a, &b, &a, &c); /* a = [a/b], c = a mod b */ \end{alltt} This allows operands to be re-used which can make programming simpler. \section{Initialization} \subsection{Single Initialization} A single mp\_int can be initialized with the ``mp\_init'' function. \index{mp\_init} \begin{alltt} int mp_init (mp_int * a); \end{alltt} This function expects a pointer to an mp\_int structure and will initialize the members of the structure so the mp\_int represents the default integer which is zero. If the functions returns MP\_OKAY then the mp\_int is ready to be used by the other LibTomMath functions. \begin{small} \begin{alltt} int main(void) \{ mp_int number; int result; if ((result = mp_init(&number)) != MP_OKAY) \{ printf("Error initializing the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* use the number */ return EXIT_SUCCESS; \} \end{alltt} \end{small} \subsection{Single Free} When you are finished with an mp\_int it is ideal to return the heap it used back to the system. The following function provides this functionality. \index{mp\_clear} \begin{alltt} void mp_clear (mp_int * a); \end{alltt} The function expects a pointer to a previously initialized mp\_int structure and frees the heap it uses. It sets the pointer\footnote{The ``dp'' member.} within the mp\_int to \textbf{NULL} which is used to prevent double free situations. Is is legal to call mp\_clear() twice on the same mp\_int in a row. \begin{small} \begin{alltt} int main(void) \{ mp_int number; int result; if ((result = mp_init(&number)) != MP_OKAY) \{ printf("Error initializing the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* use the number */ /* We're done with it. */ mp_clear(&number); return EXIT_SUCCESS; \} \end{alltt} \end{small} \subsection{Multiple Initializations} Certain algorithms require more than one large integer. In these instances it is ideal to initialize all of the mp\_int variables in an ``all or nothing'' fashion. That is, they are either all initialized successfully or they are all not initialized. The mp\_init\_multi() function provides this functionality. \index{mp\_init\_multi} \index{mp\_clear\_multi} \begin{alltt} int mp_init_multi(mp_int *mp, ...); \end{alltt} It accepts a \textbf{NULL} terminated list of pointers to mp\_int structures. It will attempt to initialize them all at once. If the function returns MP\_OKAY then all of the mp\_int variables are ready to use, otherwise none of them are available for use. A complementary mp\_clear\_multi() function allows multiple mp\_int variables to be free'd from the heap at the same time. \begin{small} \begin{alltt} int main(void) \{ mp_int num1, num2, num3; int result; if ((result = mp_init_multi(&num1, &num2, &num3, NULL)) != MP\_OKAY) \{ printf("Error initializing the numbers. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* use the numbers */ /* We're done with them. */ mp_clear_multi(&num1, &num2, &num3, NULL); return EXIT_SUCCESS; \} \end{alltt} \end{small} \subsection{Other Initializers} To initialized and make a copy of an mp\_int the mp\_init\_copy() function has been provided. \index{mp\_init\_copy} \begin{alltt} int mp_init_copy (mp_int * a, mp_int * b); \end{alltt} This function will initialize $a$ and make it a copy of $b$ if all goes well. \begin{small} \begin{alltt} int main(void) \{ mp_int num1, num2; int result; /* initialize and do work on num1 ... */ /* We want a copy of num1 in num2 now */ if ((result = mp_init_copy(&num2, &num1)) != MP_OKAY) \{ printf("Error initializing the copy. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* now num2 is ready and contains a copy of num1 */ /* We're done with them. */ mp_clear_multi(&num1, &num2, NULL); return EXIT_SUCCESS; \} \end{alltt} \end{small} Another less common initializer is mp\_init\_size() which allows the user to initialize an mp\_int with a given default number of digits. By default, all initializers allocate \textbf{MP\_PREC} digits. This function lets you override this behaviour. \index{mp\_init\_size} \begin{alltt} int mp_init_size (mp_int * a, int size); \end{alltt} The $size$ parameter must be greater than zero. If the function succeeds the mp\_int $a$ will be initialized to have $size$ digits (which are all initially zero). \begin{small} \begin{alltt} int main(void) \{ mp_int number; int result; /* we need a 60-digit number */ if ((result = mp_init_size(&number, 60)) != MP_OKAY) \{ printf("Error initializing the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* use the number */ return EXIT_SUCCESS; \} \end{alltt} \end{small} \section{Maintenance Functions} \subsection{Reducing Memory Usage} When an mp\_int is in a state where it won't be changed again\footnote{A Diffie-Hellman modulus for instance.} excess digits can be removed to return memory to the heap with the mp\_shrink() function. \index{mp\_shrink} \begin{alltt} int mp_shrink (mp_int * a); \end{alltt} This will remove excess digits of the mp\_int $a$. If the operation fails the mp\_int should be intact without the excess digits being removed. Note that you can use a shrunk mp\_int in further computations, however, such operations will require heap operations which can be slow. It is not ideal to shrink mp\_int variables that you will further modify in the system (unless you are seriously low on memory). \begin{small} \begin{alltt} int main(void) \{ mp_int number; int result; if ((result = mp_init(&number)) != MP_OKAY) \{ printf("Error initializing the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* use the number [e.g. pre-computation] */ /* We're done with it for now. */ if ((result = mp_shrink(&number)) != MP_OKAY) \{ printf("Error shrinking the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* use it .... */ /* we're done with it. */ mp_clear(&number); return EXIT_SUCCESS; \} \end{alltt} \end{small} \subsection{Adding additional digits} Within the mp\_int structure are two parameters which control the limitations of the array of digits that represent the integer the mp\_int is meant to equal. The \textit{used} parameter dictates how many digits are significant, that is, contribute to the value of the mp\_int. The \textit{alloc} parameter dictates how many digits are currently available in the array. If you need to perform an operation that requires more digits you will have to mp\_grow() the mp\_int to your desired size. \index{mp\_grow} \begin{alltt} int mp_grow (mp_int * a, int size); \end{alltt} This will grow the array of digits of $a$ to $size$. If the \textit{alloc} parameter is already bigger than $size$ the function will not do anything. \begin{small} \begin{alltt} int main(void) \{ mp_int number; int result; if ((result = mp_init(&number)) != MP_OKAY) \{ printf("Error initializing the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* use the number */ /* We need to add 20 digits to the number */ if ((result = mp_grow(&number, number.alloc + 20)) != MP_OKAY) \{ printf("Error growing the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* use the number */ /* we're done with it. */ mp_clear(&number); return EXIT_SUCCESS; \} \end{alltt} \end{small} \chapter{Basic Operations} \section{Small Constants} Setting mp\_ints to small constants is a relatively common operation. To accomodate these instances there are two small constant assignment functions. The first function is used to set a single digit constant while the second sets an ISO C style ``unsigned long'' constant. The reason for both functions is efficiency. Setting a single digit is quick but the domain of a digit can change (it's always at least $0 \ldots 127$). \subsection{Single Digit} Setting a single digit can be accomplished with the following function. \index{mp\_set} \begin{alltt} void mp_set (mp_int * a, mp_digit b); \end{alltt} This will zero the contents of $a$ and make it represent an integer equal to the value of $b$. Note that this function has a return type of \textbf{void}. It cannot cause an error so it is safe to assume the function succeeded. \begin{small} \begin{alltt} int main(void) \{ mp_int number; int result; if ((result = mp_init(&number)) != MP_OKAY) \{ printf("Error initializing the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* set the number to 5 */ mp_set(&number, 5); /* we're done with it. */ mp_clear(&number); return EXIT_SUCCESS; \} \end{alltt} \end{small} \subsection{Long Constants} To set a constant that is the size of an ISO C ``unsigned long'' and larger than a single digit the following function can be used. \index{mp\_set\_int} \begin{alltt} int mp_set_int (mp_int * a, unsigned long b); \end{alltt} This will assign the value of the 32-bit variable $b$ to the mp\_int $a$. Unlike mp\_set() this function will always accept a 32-bit input regardless of the size of a single digit. However, since the value may span several digits this function can fail if it runs out of heap memory. To get the ``unsigned long'' copy of an mp\_int the following function can be used. \index{mp\_get\_int} \begin{alltt} unsigned long mp_get_int (mp_int * a); \end{alltt} This will return the 32 least significant bits of the mp\_int $a$. \begin{small} \begin{alltt} int main(void) \{ mp_int number; int result; if ((result = mp_init(&number)) != MP_OKAY) \{ printf("Error initializing the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* set the number to 654321 (note this is bigger than 127) */ if ((result = mp_set_int(&number, 654321)) != MP_OKAY) \{ printf("Error setting the value of the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} printf("number == \%lu", mp_get_int(&number)); /* we're done with it. */ mp_clear(&number); return EXIT_SUCCESS; \} \end{alltt} \end{small} This should output the following if the program succeeds. \begin{alltt} number == 654321 \end{alltt} \subsection{Initialize and Setting Constants} To both initialize and set small constants the following two functions are available. \index{mp\_init\_set} \index{mp\_init\_set\_int} \begin{alltt} int mp_init_set (mp_int * a, mp_digit b); int mp_init_set_int (mp_int * a, unsigned long b); \end{alltt} Both functions work like the previous counterparts except they first mp\_init $a$ before setting the values. \begin{alltt} int main(void) \{ mp_int number1, number2; int result; /* initialize and set a single digit */ if ((result = mp_init_set(&number1, 100)) != MP_OKAY) \{ printf("Error setting number1: \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* initialize and set a long */ if ((result = mp_init_set_int(&number2, 1023)) != MP_OKAY) \{ printf("Error setting number2: \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* display */ printf("Number1, Number2 == \%lu, \%lu", mp_get_int(&number1), mp_get_int(&number2)); /* clear */ mp_clear_multi(&number1, &number2, NULL); return EXIT_SUCCESS; \} \end{alltt} If this program succeeds it shall output. \begin{alltt} Number1, Number2 == 100, 1023 \end{alltt} \section{Comparisons} Comparisons in LibTomMath are always performed in a ``left to right'' fashion. There are three possible return codes for any comparison. \index{MP\_GT} \index{MP\_EQ} \index{MP\_LT} \begin{figure}[here] \begin{center} \begin{tabular}{|c|c|} \hline \textbf{Result Code} & \textbf{Meaning} \\ \hline MP\_GT & $a > b$ \\ \hline MP\_EQ & $a = b$ \\ \hline MP\_LT & $a < b$ \\ \hline \end{tabular} \end{center} \caption{Comparison Codes for $a, b$} \label{fig:CMP} \end{figure} In figure \ref{fig:CMP} two integers $a$ and $b$ are being compared. In this case $a$ is said to be ``to the left'' of $b$. \subsection{Unsigned comparison} An unsigned comparison considers only the digits themselves and not the associated \textit{sign} flag of the mp\_int structures. This is analogous to an absolute comparison. The function mp\_cmp\_mag() will compare two mp\_int variables based on their digits only. \index{mp\_cmp\_mag} \begin{alltt} int mp_cmp_mag(mp_int * a, mp_int * b); \end{alltt} This will compare $a$ to $b$ placing $a$ to the left of $b$. This function cannot fail and will return one of the three compare codes listed in figure \ref{fig:CMP}. \begin{small} \begin{alltt} int main(void) \{ mp_int number1, number2; int result; if ((result = mp_init_multi(&number1, &number2, NULL)) != MP_OKAY) \{ printf("Error initializing the numbers. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* set the number1 to 5 */ mp_set(&number1, 5); /* set the number2 to -6 */ mp_set(&number2, 6); if ((result = mp_neg(&number2, &number2)) != MP_OKAY) \{ printf("Error negating number2. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} switch(mp_cmp_mag(&number1, &number2)) \{ case MP_GT: printf("|number1| > |number2|"); break; case MP_EQ: printf("|number1| = |number2|"); break; case MP_LT: printf("|number1| < |number2|"); break; \} /* we're done with it. */ mp_clear_multi(&number1, &number2, NULL); return EXIT_SUCCESS; \} \end{alltt} \end{small} If this program\footnote{This function uses the mp\_neg() function which is discussed in section \ref{sec:NEG}.} completes successfully it should print the following. \begin{alltt} |number1| < |number2| \end{alltt} This is because $\vert -6 \vert = 6$ and obviously $5 < 6$. \subsection{Signed comparison} To compare two mp\_int variables based on their signed value the mp\_cmp() function is provided. \index{mp\_cmp} \begin{alltt} int mp_cmp(mp_int * a, mp_int * b); \end{alltt} This will compare $a$ to the left of $b$. It will first compare the signs of the two mp\_int variables. If they differ it will return immediately based on their signs. If the signs are equal then it will compare the digits individually. This function will return one of the compare conditions codes listed in figure \ref{fig:CMP}. \begin{small} \begin{alltt} int main(void) \{ mp_int number1, number2; int result; if ((result = mp_init_multi(&number1, &number2, NULL)) != MP_OKAY) \{ printf("Error initializing the numbers. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* set the number1 to 5 */ mp_set(&number1, 5); /* set the number2 to -6 */ mp_set(&number2, 6); if ((result = mp_neg(&number2, &number2)) != MP_OKAY) \{ printf("Error negating number2. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} switch(mp_cmp(&number1, &number2)) \{ case MP_GT: printf("number1 > number2"); break; case MP_EQ: printf("number1 = number2"); break; case MP_LT: printf("number1 < number2"); break; \} /* we're done with it. */ mp_clear_multi(&number1, &number2, NULL); return EXIT_SUCCESS; \} \end{alltt} \end{small} If this program\footnote{This function uses the mp\_neg() function which is discussed in section \ref{sec:NEG}.} completes successfully it should print the following. \begin{alltt} number1 > number2 \end{alltt} \subsection{Single Digit} To compare a single digit against an mp\_int the following function has been provided. \index{mp\_cmp\_d} \begin{alltt} int mp_cmp_d(mp_int * a, mp_digit b); \end{alltt} This will compare $a$ to the left of $b$ using a signed comparison. Note that it will always treat $b$ as positive. This function is rather handy when you have to compare against small values such as $1$ (which often comes up in cryptography). The function cannot fail and will return one of the tree compare condition codes listed in figure \ref{fig:CMP}. \begin{small} \begin{alltt} int main(void) \{ mp_int number; int result; if ((result = mp_init(&number)) != MP_OKAY) \{ printf("Error initializing the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* set the number to 5 */ mp_set(&number, 5); switch(mp_cmp_d(&number, 7)) \{ case MP_GT: printf("number > 7"); break; case MP_EQ: printf("number = 7"); break; case MP_LT: printf("number < 7"); break; \} /* we're done with it. */ mp_clear(&number); return EXIT_SUCCESS; \} \end{alltt} \end{small} If this program functions properly it will print out the following. \begin{alltt} number < 7 \end{alltt} \section{Logical Operations} Logical operations are operations that can be performed either with simple shifts or boolean operators such as AND, XOR and OR directly. These operations are very quick. \subsection{Multiplication by two} Multiplications and divisions by any power of two can be performed with quick logical shifts either left or right depending on the operation. When multiplying or dividing by two a special case routine can be used which are as follows. \index{mp\_mul\_2} \index{mp\_div\_2} \begin{alltt} int mp_mul_2(mp_int * a, mp_int * b); int mp_div_2(mp_int * a, mp_int * b); \end{alltt} The former will assign twice $a$ to $b$ while the latter will assign half $a$ to $b$. These functions are fast since the shift counts and maskes are hardcoded into the routines. \begin{small} \begin{alltt} int main(void) \{ mp_int number; int result; if ((result = mp_init(&number)) != MP_OKAY) \{ printf("Error initializing the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* set the number to 5 */ mp_set(&number, 5); /* multiply by two */ if ((result = mp\_mul\_2(&number, &number)) != MP_OKAY) \{ printf("Error multiplying the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} switch(mp_cmp_d(&number, 7)) \{ case MP_GT: printf("2*number > 7"); break; case MP_EQ: printf("2*number = 7"); break; case MP_LT: printf("2*number < 7"); break; \} /* now divide by two */ if ((result = mp\_div\_2(&number, &number)) != MP_OKAY) \{ printf("Error dividing the number. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} switch(mp_cmp_d(&number, 7)) \{ case MP_GT: printf("2*number/2 > 7"); break; case MP_EQ: printf("2*number/2 = 7"); break; case MP_LT: printf("2*number/2 < 7"); break; \} /* we're done with it. */ mp_clear(&number); return EXIT_SUCCESS; \} \end{alltt} \end{small} If this program is successful it will print out the following text. \begin{alltt} 2*number > 7 2*number/2 < 7 \end{alltt} Since $10 > 7$ and $5 < 7$. To multiply by a power of two the following function can be used. \index{mp\_mul\_2d} \begin{alltt} int mp_mul_2d(mp_int * a, int b, mp_int * c); \end{alltt} This will multiply $a$ by $2^b$ and store the result in ``c''. If the value of $b$ is less than or equal to zero the function will copy $a$ to ``c'' without performing any further actions. To divide by a power of two use the following. \index{mp\_div\_2d} \begin{alltt} int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d); \end{alltt} Which will divide $a$ by $2^b$, store the quotient in ``c'' and the remainder in ``d'. If $b \le 0$ then the function simply copies $a$ over to ``c'' and zeroes $d$. The variable $d$ may be passed as a \textbf{NULL} value to signal that the remainder is not desired. \subsection{Polynomial Basis Operations} Strictly speaking the organization of the integers within the mp\_int structures is what is known as a ``polynomial basis''. This simply means a field element is stored by divisions of a radix. For example, if $f(x) = \sum_{i=0}^{k} y_ix^k$ for any vector $\vec y$ then the array of digits in $\vec y$ are said to be the polynomial basis representation of $z$ if $f(\beta) = z$ for a given radix $\beta$. To multiply by the polynomial $g(x) = x$ all you have todo is shift the digits of the basis left one place. The following function provides this operation. \index{mp\_lshd} \begin{alltt} int mp_lshd (mp_int * a, int b); \end{alltt} This will multiply $a$ in place by $x^b$ which is equivalent to shifting the digits left $b$ places and inserting zeroes in the least significant digits. Similarly to divide by a power of $x$ the following function is provided. \index{mp\_rshd} \begin{alltt} void mp_rshd (mp_int * a, int b) \end{alltt} This will divide $a$ in place by $x^b$ and discard the remainder. This function cannot fail as it performs the operations in place and no new digits are required to complete it. \subsection{AND, OR and XOR Operations} While AND, OR and XOR operations are not typical ``bignum functions'' they can be useful in several instances. The three functions are prototyped as follows. \index{mp\_or} \index{mp\_and} \index{mp\_xor} \begin{alltt} int mp_or (mp_int * a, mp_int * b, mp_int * c); int mp_and (mp_int * a, mp_int * b, mp_int * c); int mp_xor (mp_int * a, mp_int * b, mp_int * c); \end{alltt} Which compute $c = a \odot b$ where $\odot$ is one of OR, AND or XOR. \section{Addition and Subtraction} To compute an addition or subtraction the following two functions can be used. \index{mp\_add} \index{mp\_sub} \begin{alltt} int mp_add (mp_int * a, mp_int * b, mp_int * c); int mp_sub (mp_int * a, mp_int * b, mp_int * c) \end{alltt} Which perform $c = a \odot b$ where $\odot$ is one of signed addition or subtraction. The operations are fully sign aware. \section{Sign Manipulation} \subsection{Negation} \label{sec:NEG} Simple integer negation can be performed with the following. \index{mp\_neg} \begin{alltt} int mp_neg (mp_int * a, mp_int * b); \end{alltt} Which assigns $-a$ to $b$. \subsection{Absolute} Simple integer absolutes can be performed with the following. \index{mp\_neg} \begin{alltt} int mp_abs (mp_int * a, mp_int * b); \end{alltt} Which assigns $\vert a \vert$ to $b$. \section{Integer Division and Remainder} To perform a complete and general integer division with remainder use the following function. \index{mp\_div} \begin{alltt} int mp_div (mp_int * a, mp_int * b, mp_int * c, mp_int * d); \end{alltt} This divides $a$ by $b$ and stores the quotient in $c$ and $d$. The signed quotient is computed such that $bc + d = a$. Note that either of $c$ or $d$ can be set to \textbf{NULL} if their value is not required. If $b$ is zero the function returns \textbf{MP\_VAL}. \chapter{Multiplication and Squaring} \section{Multiplication} A full signed integer multiplication can be performed with the following. \index{mp\_mul} \begin{alltt} int mp_mul (mp_int * a, mp_int * b, mp_int * c); \end{alltt} Which assigns the full signed product $ab$ to $c$. This function actually breaks into one of four cases which are specific multiplication routines optimized for given parameters. First there are the Toom-Cook multiplications which should only be used with very large inputs. This is followed by the Karatsuba multiplications which are for moderate sized inputs. Then followed by the Comba and baseline multipliers. Fortunately for the developer you don't really need to know this unless you really want to fine tune the system. mp\_mul() will determine on its own\footnote{Some tweaking may be required.} what routine to use automatically when it is called. \begin{alltt} int main(void) \{ mp_int number1, number2; int result; /* Initialize the numbers */ if ((result = mp_init_multi(&number1, &number2, NULL)) != MP_OKAY) \{ printf("Error initializing the numbers. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* set the terms */ if ((result = mp_set_int(&number, 257)) != MP_OKAY) \{ printf("Error setting number1. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} if ((result = mp_set_int(&number2, 1023)) != MP_OKAY) \{ printf("Error setting number2. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* multiply them */ if ((result = mp_mul(&number1, &number2, &number1)) != MP_OKAY) \{ printf("Error multiplying terms. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* display */ printf("number1 * number2 == \%lu", mp_get_int(&number1)); /* free terms and return */ mp_clear_multi(&number1, &number2, NULL); return EXIT_SUCCESS; \} \end{alltt} If this program succeeds it shall output the following. \begin{alltt} number1 * number2 == 262911 \end{alltt} \section{Squaring} Since squaring can be performed faster than multiplication it is performed it's own function instead of just using mp\_mul(). \index{mp\_sqr} \begin{alltt} int mp_sqr (mp_int * a, mp_int * b); \end{alltt} Will square $a$ and store it in $b$. Like the case of multiplication there are four different squaring algorithms all which can be called from mp\_sqr(). It is ideal to use mp\_sqr over mp\_mul when squaring terms because of the speed difference. \section{Tuning Polynomial Basis Routines} Both of the Toom-Cook and Karatsuba multiplication algorithms are faster than the traditional $O(n^2)$ approach that the Comba and baseline algorithms use. At $O(n^{1.464973})$ and $O(n^{1.584962})$ running times respectively they require considerably less work. For example, a 10000-digit multiplication would take roughly 724,000 single precision multiplications with Toom-Cook or 100,000,000 single precision multiplications with the standard Comba (a factor of 138). So why not always use Karatsuba or Toom-Cook? The simple answer is that they have so much overhead that they're not actually faster than Comba until you hit distinct ``cutoff'' points. For Karatsuba with the default configuration, GCC 3.3.1 and an Athlon XP processor the cutoff point is roughly 110 digits (about 70 for the Intel P4). That is, at 110 digits Karatsuba and Comba multiplications just about break even and for 110+ digits Karatsuba is faster. Toom-Cook has incredible overhead and is probably only useful for very large inputs. So far no known cutoff points exist and for the most part I just set the cutoff points very high to make sure they're not called. A demo program in the ``etc/'' directory of the project called ``tune.c'' can be used to find the cutoff points. This can be built with GCC as follows \begin{alltt} make XXX \end{alltt} Where ``XXX'' is one of the following entries from the table \ref{fig:tuning}. \begin{figure}[here] \begin{center} \begin{small} \begin{tabular}{|l|l|} \hline \textbf{Value of XXX} & \textbf{Meaning} \\ \hline tune & Builds portable tuning application \\ \hline tune86 & Builds x86 (pentium and up) program for COFF \\ \hline tune86c & Builds x86 program for Cygwin \\ \hline tune86l & Builds x86 program for Linux (ELF format) \\ \hline \end{tabular} \end{small} \end{center} \caption{Build Names for Tuning Programs} \label{fig:tuning} \end{figure} When the program is running it will output a series of measurements for different cutoff points. It will first find good Karatsuba squaring and multiplication points. Then it proceeds to find Toom-Cook points. Note that the Toom-Cook tuning takes a very long time as the cutoff points are likely to be very high. \chapter{Modular Reduction} Modular reduction is process of taking the remainder of one quantity divided by another. Expressed as (\ref{eqn:mod}) the modular reduction is equivalent to the remainder of $b$ divided by $c$. \begin{equation} a \equiv b \mbox{ (mod }c\mbox{)} \label{eqn:mod} \end{equation} Of particular interest to cryptography are reductions where $b$ is limited to the range $0 \le b < c^2$ since particularly fast reduction algorithms can be written for the limited range. Note that one of the four optimized reduction algorithms are automatically chosen in the modular exponentiation algorithm mp\_exptmod when an appropriate modulus is detected. \section{Straight Division} In order to effect an arbitrary modular reduction the following algorithm is provided. \index{mp\_mod} \begin{alltt} int mp_mod(mp_int *a, mp_int *b, mp_int *c); \end{alltt} This reduces $a$ modulo $b$ and stores the result in $c$. The sign of $c$ shall agree with the sign of $b$. This algorithm accepts an input $a$ of any range and is not limited by $0 \le a < b^2$. \section{Barrett Reduction} Barrett reduction is a generic optimized reduction algorithm that requires pre--computation to achieve a decent speedup over straight division. First a $\mu$ value must be precomputed with the following function. \index{mp\_reduce\_setup} \begin{alltt} int mp_reduce_setup(mp_int *a, mp_int *b); \end{alltt} Given a modulus in $b$ this produces the required $\mu$ value in $a$. For any given modulus this only has to be computed once. Modular reduction can now be performed with the following. \index{mp\_reduce} \begin{alltt} int mp_reduce(mp_int *a, mp_int *b, mp_int *c); \end{alltt} This will reduce $a$ in place modulo $b$ with the precomputed $\mu$ value in $c$. $a$ must be in the range $0 \le a < b^2$. \begin{alltt} int main(void) \{ mp_int a, b, c, mu; int result; /* initialize a,b to desired values, mp_init mu, * c and set c to 1...we want to compute a^3 mod b */ /* get mu value */ if ((result = mp_reduce_setup(&mu, b)) != MP_OKAY) \{ printf("Error getting mu. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* square a to get c = a^2 */ if ((result = mp_sqr(&a, &c)) != MP_OKAY) \{ printf("Error squaring. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* now reduce `c' modulo b */ if ((result = mp_reduce(&c, &b, &mu)) != MP_OKAY) \{ printf("Error reducing. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* multiply a to get c = a^3 */ if ((result = mp_mul(&a, &c, &c)) != MP_OKAY) \{ printf("Error reducing. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* now reduce `c' modulo b */ if ((result = mp_reduce(&c, &b, &mu)) != MP_OKAY) \{ printf("Error reducing. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* c now equals a^3 mod b */ return EXIT_SUCCESS; \} \end{alltt} This program will calculate $a^3 \mbox{ mod }b$ if all the functions succeed. \section{Montgomery Reduction} Montgomery is a specialized reduction algorithm for any odd moduli. Like Barrett reduction a pre--computation step is required. This is accomplished with the following. \index{mp\_montgomery\_setup} \begin{alltt} int mp_montgomery_setup(mp_int *a, mp_digit *mp); \end{alltt} For the given odd moduli $a$ the precomputation value is placed in $mp$. The reduction is computed with the following. \index{mp\_montgomery\_reduce} \begin{alltt} int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); \end{alltt} This reduces $a$ in place modulo $m$ with the pre--computed value $mp$. $a$ must be in the range $0 \le a < b^2$. Montgomery reduction is faster than Barrett reduction for moduli smaller than the ``comba'' limit. With the default setup for instance, the limit is $127$ digits ($3556$--bits). Note that this function is not limited to $127$ digits just that it falls back to a baseline algorithm after that point. An important observation is that this reduction does not return $a \mbox{ mod }m$ but $aR^{-1} \mbox{ mod }m$ where $R = \beta^n$, $n$ is the n number of digits in $m$ and $\beta$ is radix used (default is $2^{28}$). To quickly calculate $R$ the following function was provided. \index{mp\_montgomery\_calc\_normalization} \begin{alltt} int mp_montgomery_calc_normalization(mp_int *a, mp_int *b); \end{alltt} Which calculates $a = R$ for the odd moduli $b$ without using multiplication or division. The normal modus operandi for Montgomery reductions is to normalize the integers before entering the system. For example, to calculate $a^3 \mbox { mod }b$ using Montgomery reduction the value of $a$ can be normalized by multiplying it by $R$. Consider the following code snippet. \begin{alltt} int main(void) \{ mp_int a, b, c, R; mp_digit mp; int result; /* initialize a,b to desired values, * mp_init R, c and set c to 1.... */ /* get normalization */ if ((result = mp_montgomery_calc_normalization(&R, b)) != MP_OKAY) \{ printf("Error getting norm. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* get mp value */ if ((result = mp_montgomery_setup(&c, &mp)) != MP_OKAY) \{ printf("Error setting up montgomery. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* normalize `a' so now a is equal to aR */ if ((result = mp_mulmod(&a, &R, &b, &a)) != MP_OKAY) \{ printf("Error computing aR. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* square a to get c = a^2R^2 */ if ((result = mp_sqr(&a, &c)) != MP_OKAY) \{ printf("Error squaring. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* now reduce `c' back down to c = a^2R^2 * R^-1 == a^2R */ if ((result = mp_montgomery_reduce(&c, &b, mp)) != MP_OKAY) \{ printf("Error reducing. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* multiply a to get c = a^3R^2 */ if ((result = mp_mul(&a, &c, &c)) != MP_OKAY) \{ printf("Error reducing. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* now reduce `c' back down to c = a^3R^2 * R^-1 == a^3R */ if ((result = mp_montgomery_reduce(&c, &b, mp)) != MP_OKAY) \{ printf("Error reducing. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* now reduce (again) `c' back down to c = a^3R * R^-1 == a^3 */ if ((result = mp_montgomery_reduce(&c, &b, mp)) != MP_OKAY) \{ printf("Error reducing. \%s", mp_error_to_string(result)); return EXIT_FAILURE; \} /* c now equals a^3 mod b */ return EXIT_SUCCESS; \} \end{alltt} This particular example does not look too efficient but it demonstrates the point of the algorithm. By normalizing the inputs the reduced results are always of the form $aR$ for some variable $a$. This allows a single final reduction to correct for the normalization and the fast reduction used within the algorithm. For more details consider examining the file \textit{bn\_mp\_exptmod\_fast.c}. \section{Restricted Dimminished Radix} ``Dimminished Radix'' reduction refers to reduction with respect to moduli that are ameniable to simple digit shifting and small multiplications. In this case the ``restricted'' variant refers to moduli of the form $\beta^k - p$ for some $k \ge 0$ and $0 < p < \beta$ where $\beta$ is the radix (default to $2^{28}$). As in the case of Montgomery reduction there is a pre--computation phase required for a given modulus. \index{mp\_dr\_setup} \begin{alltt} void mp_dr_setup(mp_int *a, mp_digit *d); \end{alltt} This computes the value required for the modulus $a$ and stores it in $d$. This function cannot fail and does not return any error codes. After the pre--computation a reduction can be performed with the following. \index{mp\_dr\_reduce} \begin{alltt} int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp); \end{alltt} This reduces $a$ in place modulo $b$ with the pre--computed value $mp$. $b$ must be of a restricted dimminished radix form and $a$ must be in the range $0 \le a < b^2$. Dimminished radix reductions are much faster than both Barrett and Montgomery reductions as they have a much lower asymtotic running time. Since the moduli are restricted this algorithm is not particularly useful for something like Rabin, RSA or BBS cryptographic purposes. This reduction algorithm is useful for Diffie-Hellman and ECC where fixed primes are acceptable. Note that unlike Montgomery reduction there is no normalization process. The result of this function is equal to the correct residue. \section{Unrestricted Dimminshed Radix} Unrestricted reductions work much like the restricted counterparts except in this case the moduli is of the form $2^k - p$ for $0 < p < \beta$. In this sense the unrestricted reductions are more flexible as they can be applied to a wider range of numbers. \index{mp\_reduce\_2k\_setup} \begin{alltt} int mp_reduce_2k_setup(mp_int *a, mp_digit *d); \end{alltt} This will compute the required $d$ value for the given moduli $a$. \index{mp\_reduce\_2k} \begin{alltt} int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d); \end{alltt} This will reduce $a$ in place modulo $n$ with the pre--computed value $d$. From my experience this routine is slower than mp\_dr\_reduce but faster for most moduli sizes than the Montgomery reduction. \chapter{Exponentiation} \section{Single Digit Exponentiation} \index{mp\_expt\_d} \begin{alltt} int mp_expt_d (mp_int * a, mp_digit b, mp_int * c) \end{alltt} This computes $c = a^b$ using a simple binary left-to-right algorithm. It is faster than repeated multiplications by $a$ for all values of $b$ greater than three. \section{Modular Exponentiation} \index{mp\_exptmod} \begin{alltt} int mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y) \end{alltt} This computes $Y \equiv G^X \mbox{ (mod }P\mbox{)}$ using a variable width sliding window algorithm. This function will automatically detect the fastest modular reduction technique to use during the operation. For negative values of $X$ the operation is performed as $Y \equiv (G^{-1} \mbox{ mod }P)^{\vert X \vert} \mbox{ (mod }P\mbox{)}$ provided that $gcd(G, P) = 1$. This function is actually a shell around the two internal exponentiation functions. This routine will automatically detect when Barrett, Montgomery, Restricted and Unrestricted Dimminished Radix based exponentiation can be used. Generally moduli of the a ``restricted dimminished radix'' form lead to the fastest modular exponentiations. Followed by Montgomery and the other two algorithms. \section{Root Finding} \index{mp\_n\_root} \begin{alltt} int mp_n_root (mp_int * a, mp_digit b, mp_int * c) \end{alltt} This computes $c = a^{1/b}$ such that $c^b \le a$ and $(c+1)^b > a$. The implementation of this function is not ideal for values of $b$ greater than three. It will work but become very slow. So unless you are working with very small numbers (less than 1000 bits) I'd avoid $b > 3$ situations. Will return a positive root only for even roots and return a root with the sign of the input for odd roots. For example, performing $4^{1/2}$ will return $2$ whereas $(-8)^{1/3}$ will return $-2$. This algorithm uses the ``Newton Approximation'' method and will converge on the correct root fairly quickly. Since the algorithm requires raising $a$ to the power of $b$ it is not ideal to attempt to find roots for large values of $b$. If particularly large roots are required then a factor method could be used instead. For example, $a^{1/16}$ is equivalent to $\left (a^{1/4} \right)^{1/4}$ or simply $\left ( \left ( \left ( a^{1/2} \right )^{1/2} \right )^{1/2} \right )^{1/2}$ \chapter{Prime Numbers} \section{Trial Division} \index{mp\_prime\_is\_divisible} \begin{alltt} int mp_prime_is_divisible (mp_int * a, int *result) \end{alltt} This will attempt to evenly divide $a$ by a list of primes\footnote{Default is the first 256 primes.} and store the outcome in ``result''. That is if $result = 0$ then $a$ is not divisible by the primes, otherwise it is. Note that if the function does not return \textbf{MP\_OKAY} the value in ``result'' should be considered undefined\footnote{Currently the default is to set it to zero first.}. \section{Fermat Test} \index{mp\_prime\_fermat} \begin{alltt} int mp_prime_fermat (mp_int * a, mp_int * b, int *result) \end{alltt} Performs a Fermat primality test to the base $b$. That is it computes $b^a \mbox{ mod }a$ and tests whether the value is equal to $b$ or not. If the values are equal then $a$ is probably prime and $result$ is set to one. Otherwise $result$ is set to zero. \section{Miller-Rabin Test} \index{mp\_prime\_miller\_rabin} \begin{alltt} int mp_prime_miller_rabin (mp_int * a, mp_int * b, int *result) \end{alltt} Performs a Miller-Rabin test to the base $b$ of $a$. This test is much stronger than the Fermat test and is very hard to fool (besides with Carmichael numbers). If $a$ passes the test (therefore is probably prime) $result$ is set to one. Otherwise $result$ is set to zero. Note that is suggested that you use the Miller-Rabin test instead of the Fermat test since all of the failures of Miller-Rabin are a subset of the failures of the Fermat test. \subsection{Required Number of Tests} Generally to ensure a number is very likely to be prime you have to perform the Miller-Rabin with at least a half-dozen or so unique bases. However, it has been proven that the probability of failure goes down as the size of the input goes up. This is why a simple function has been provided to help out. \index{mp\_prime\_rabin\_miller\_trials} \begin{alltt} int mp_prime_rabin_miller_trials(int size) \end{alltt} This returns the number of trials required for a $2^{-96}$ (or lower) probability of failure for a given ``size'' expressed in bits. This comes in handy specially since larger numbers are slower to test. For example, a 512-bit number would require ten tests whereas a 1024-bit number would only require four tests. You should always still perform a trial division before a Miller-Rabin test though. \section{Primality Testing} \index{mp\_prime\_is\_prime} \begin{alltt} int mp_prime_is_prime (mp_int * a, int t, int *result) \end{alltt} This will perform a trial division followed by $t$ rounds of Miller-Rabin tests on $a$ and store the result in $result$. If $a$ passes all of the tests $result$ is set to one, otherwise it is set to zero. Note that $t$ is bounded by $1 \le t < PRIME\_SIZE$ where $PRIME\_SIZE$ is the number of primes in the prime number table (by default this is $256$). \section{Next Prime} \index{mp\_prime\_next\_prime} \begin{alltt} int mp_prime_next_prime(mp_int *a, int t, int bbs_style) \end{alltt} This finds the next prime after $a$ that passes mp\_prime\_is\_prime() with $t$ tests. Set $bbs\_style$ to one if you want only the next prime congruent to $3 \mbox{ mod } 4$, otherwise set it to zero to find any next prime. \section{Random Primes} \index{mp\_prime\_random} \begin{alltt} int mp_prime_random(mp_int *a, int t, int size, int bbs, ltm_prime_callback cb, void *dat) \end{alltt} This will find a prime greater than $256^{size}$ which can be ``bbs\_style'' or not depending on $bbs$ and must pass $t$ rounds of tests. The ``ltm\_prime\_callback'' is a typedef for \begin{alltt} typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); \end{alltt} Which is a function that must read $len$ bytes (and return the amount stored) into $dst$. The $dat$ variable is simply copied from the original input. It can be used to pass RNG context data to the callback. The function mp\_prime\_random() is more suitable for generating primes which must be secret (as in the case of RSA) since there is no skew on the least significant bits. \textit{Note:} As of v0.30 of the LibTomMath library this function has been deprecated. It is still available but users are encouraged to use the new mp\_prime\_random\_ex() function instead. \subsection{Extended Generation} \index{mp\_prime\_random\_ex} \begin{alltt} int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat); \end{alltt} This will generate a prime in $a$ using $t$ tests of the primality testing algorithms. The variable $size$ specifies the bit length of the prime desired. The variable $flags$ specifies one of several options available (see fig. \ref{fig:primeopts}) which can be OR'ed together. The callback parameters are used as in mp\_prime\_random(). \begin{figure}[here] \begin{center} \begin{small} \begin{tabular}{|r|l|} \hline \textbf{Flag} & \textbf{Meaning} \\ \hline LTM\_PRIME\_BBS & Make the prime congruent to $3$ modulo $4$ \\ \hline LTM\_PRIME\_SAFE & Make a prime $p$ such that $(p - 1)/2$ is also prime. \\ & This option implies LTM\_PRIME\_BBS as well. \\ \hline LTM\_PRIME\_2MSB\_OFF & Makes sure that the bit adjacent to the most significant bit \\ & Is forced to zero. \\ \hline LTM\_PRIME\_2MSB\_ON & Makes sure that the bit adjacent to the most significant bit \\ & Is forced to one. \\ \hline \end{tabular} \end{small} \end{center} \caption{Primality Generation Options} \label{fig:primeopts} \end{figure} \chapter{Input and Output} \section{ASCII Conversions} \subsection{To ASCII} \index{mp\_toradix} \begin{alltt} int mp_toradix (mp_int * a, char *str, int radix); \end{alltt} This still store $a$ in ``str'' as a base-``radix'' string of ASCII chars. This function appends a NUL character to terminate the string. Valid values of ``radix'' line in the range $[2, 64]$. To determine the size (exact) required by the conversion before storing any data use the following function. \index{mp\_radix\_size} \begin{alltt} int mp_radix_size (mp_int * a, int radix, int *size) \end{alltt} This stores in ``size'' the number of characters (including space for the NUL terminator) required. Upon error this function returns an error code and ``size'' will be zero. \subsection{From ASCII} \index{mp\_read\_radix} \begin{alltt} int mp_read_radix (mp_int * a, char *str, int radix); \end{alltt} This will read the base-``radix'' NUL terminated string from ``str'' into $a$. It will stop reading when it reads a character it does not recognize (which happens to include th NUL char... imagine that...). A single leading $-$ sign can be used to denote a negative number. \section{Binary Conversions} Converting an mp\_int to and from binary is another keen idea. \index{mp\_unsigned\_bin\_size} \begin{alltt} int mp_unsigned_bin_size(mp_int *a); \end{alltt} This will return the number of bytes (octets) required to store the unsigned copy of the integer $a$. \index{mp\_to\_unsigned\_bin} \begin{alltt} int mp_to_unsigned_bin(mp_int *a, unsigned char *b); \end{alltt} This will store $a$ into the buffer $b$ in big--endian format. Fortunately this is exactly what DER (or is it ASN?) requires. It does not store the sign of the integer. \index{mp\_read\_unsigned\_bin} \begin{alltt} int mp_read_unsigned_bin(mp_int *a, unsigned char *b, int c); \end{alltt} This will read in an unsigned big--endian array of bytes (octets) from $b$ of length $c$ into $a$. The resulting integer $a$ will always be positive. For those who acknowledge the existence of negative numbers (heretic!) there are ``signed'' versions of the previous functions. \begin{alltt} int mp_signed_bin_size(mp_int *a); int mp_read_signed_bin(mp_int *a, unsigned char *b, int c); int mp_to_signed_bin(mp_int *a, unsigned char *b); \end{alltt} They operate essentially the same as the unsigned copies except they prefix the data with zero or non--zero byte depending on the sign. If the sign is zpos (e.g. not negative) the prefix is zero, otherwise the prefix is non--zero. \chapter{Algebraic Functions} \section{Extended Euclidean Algorithm} \index{mp\_exteuclid} \begin{alltt} int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3); \end{alltt} This finds the triple U1/U2/U3 using the Extended Euclidean algorithm such that the following equation holds. \begin{equation} a \cdot U1 + b \cdot U2 = U3 \end{equation} Any of the U1/U2/U3 paramters can be set to \textbf{NULL} if they are not desired. \section{Greatest Common Divisor} \index{mp\_gcd} \begin{alltt} int mp_gcd (mp_int * a, mp_int * b, mp_int * c) \end{alltt} This will compute the greatest common divisor of $a$ and $b$ and store it in $c$. \section{Least Common Multiple} \index{mp\_lcm} \begin{alltt} int mp_lcm (mp_int * a, mp_int * b, mp_int * c) \end{alltt} This will compute the least common multiple of $a$ and $b$ and store it in $c$. \section{Jacobi Symbol} \index{mp\_jacobi} \begin{alltt} int mp_jacobi (mp_int * a, mp_int * p, int *c) \end{alltt} This will compute the Jacobi symbol for $a$ with respect to $p$. If $p$ is prime this essentially computes the Legendre symbol. The result is stored in $c$ and can take on one of three values $\lbrace -1, 0, 1 \rbrace$. If $p$ is prime then the result will be $-1$ when $a$ is not a quadratic residue modulo $p$. The result will be $0$ if $a$ divides $p$ and the result will be $1$ if $a$ is a quadratic residue modulo $p$. \section{Modular Inverse} \index{mp\_invmod} \begin{alltt} int mp_invmod (mp_int * a, mp_int * b, mp_int * c) \end{alltt} Computes the multiplicative inverse of $a$ modulo $b$ and stores the result in $c$ such that $ac \equiv 1 \mbox{ (mod }b\mbox{)}$. \section{Single Digit Functions} For those using small numbers (\textit{snicker snicker}) there are several ``helper'' functions \index{mp\_add\_d} \index{mp\_sub\_d} \index{mp\_mul\_d} \index{mp\_div\_d} \index{mp\_mod\_d} \begin{alltt} int mp_add_d(mp_int *a, mp_digit b, mp_int *c); int mp_sub_d(mp_int *a, mp_digit b, mp_int *c); int mp_mul_d(mp_int *a, mp_digit b, mp_int *c); int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d); int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c); \end{alltt} These work like the full mp\_int capable variants except the second parameter $b$ is a mp\_digit. These functions fairly handy if you have to work with relatively small numbers since you will not have to allocate an entire mp\_int to store a number like $1$ or $2$. \input{bn.ind} \end{document} |
Added libtommath/bn_error.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | #include <tommath.h> #ifdef BN_ERROR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ static const struct { int code; char *msg; } msgs[] = { { MP_OKAY, "Successful" }, { MP_MEM, "Out of heap" }, { MP_VAL, "Value out of range" } }; /* return a char * string for a given code */ char *mp_error_to_string(int code) { int x; /* scan the lookup table for the given message */ for (x = 0; x < (int)(sizeof(msgs) / sizeof(msgs[0])); x++) { if (msgs[x].code == code) { return msgs[x].msg; } } /* generic reply for invalid code */ return "Invalid error code"; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_error.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_fast_mp_invmod.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | #include <tommath.h> #ifdef BN_FAST_MP_INVMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes the modular inverse via binary extended euclidean algorithm, * that is c = 1/a mod b * * Based on slow invmod except this is optimized for the case where b is * odd as per HAC Note 14.64 on pp. 610 */ int fast_mp_invmod (mp_int * a, mp_int * b, mp_int * c) { mp_int x, y, u, v, B, D; int res, neg; /* 2. [modified] b must be odd */ if (mp_iseven (b) == 1) { return MP_VAL; } /* init all our temps */ if ((res = mp_init_multi(&x, &y, &u, &v, &B, &D, NULL)) != MP_OKAY) { return res; } /* x == modulus, y == value to invert */ if ((res = mp_copy (b, &x)) != MP_OKAY) { goto LBL_ERR; } /* we need y = |a| */ if ((res = mp_mod (a, b, &y)) != MP_OKAY) { goto LBL_ERR; } /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ if ((res = mp_copy (&x, &u)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_copy (&y, &v)) != MP_OKAY) { goto LBL_ERR; } mp_set (&D, 1); top: /* 4. while u is even do */ while (mp_iseven (&u) == 1) { /* 4.1 u = u/2 */ if ((res = mp_div_2 (&u, &u)) != MP_OKAY) { goto LBL_ERR; } /* 4.2 if B is odd then */ if (mp_isodd (&B) == 1) { if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) { goto LBL_ERR; } } /* B = B/2 */ if ((res = mp_div_2 (&B, &B)) != MP_OKAY) { goto LBL_ERR; } } /* 5. while v is even do */ while (mp_iseven (&v) == 1) { /* 5.1 v = v/2 */ if ((res = mp_div_2 (&v, &v)) != MP_OKAY) { goto LBL_ERR; } /* 5.2 if D is odd then */ if (mp_isodd (&D) == 1) { /* D = (D-x)/2 */ if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) { goto LBL_ERR; } } /* D = D/2 */ if ((res = mp_div_2 (&D, &D)) != MP_OKAY) { goto LBL_ERR; } } /* 6. if u >= v then */ if (mp_cmp (&u, &v) != MP_LT) { /* u = u - v, B = B - D */ if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) { goto LBL_ERR; } } else { /* v - v - u, D = D - B */ if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) { goto LBL_ERR; } } /* if not zero goto step 4 */ if (mp_iszero (&u) == 0) { goto top; } /* now a = C, b = D, gcd == g*v */ /* if v != 1 then there is no inverse */ if (mp_cmp_d (&v, 1) != MP_EQ) { res = MP_VAL; goto LBL_ERR; } /* b is now the inverse */ neg = a->sign; while (D.sign == MP_NEG) { if ((res = mp_add (&D, b, &D)) != MP_OKAY) { goto LBL_ERR; } } mp_exch (&D, c); c->sign = neg; res = MP_OKAY; LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &B, &D, NULL); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_mp_invmod.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_fast_mp_montgomery_reduce.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 | #include <tommath.h> #ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes xR**-1 == x (mod N) via Montgomery Reduction * * This is an optimized implementation of montgomery_reduce * which uses the comba method to quickly calculate the columns of the * reduction. * * Based on Algorithm 14.32 on pp.601 of HAC. */ int fast_mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) { int ix, res, olduse; mp_word W[MP_WARRAY]; /* get old used count */ olduse = x->used; /* grow a as required */ if (x->alloc < n->used + 1) { if ((res = mp_grow (x, n->used + 1)) != MP_OKAY) { return res; } } /* first we have to get the digits of the input into * an array of double precision words W[...] */ { register mp_word *_W; register mp_digit *tmpx; /* alias for the W[] array */ _W = W; /* alias for the digits of x*/ tmpx = x->dp; /* copy the digits of a into W[0..a->used-1] */ for (ix = 0; ix < x->used; ix++) { *_W++ = *tmpx++; } /* zero the high words of W[a->used..m->used*2] */ for (; ix < n->used * 2 + 1; ix++) { *_W++ = 0; } } /* now we proceed to zero successive digits * from the least significant upwards */ for (ix = 0; ix < n->used; ix++) { /* mu = ai * m' mod b * * We avoid a double precision multiplication (which isn't required) * by casting the value down to a mp_digit. Note this requires * that W[ix-1] have the carry cleared (see after the inner loop) */ register mp_digit mu; mu = (mp_digit) (((W[ix] & MP_MASK) * rho) & MP_MASK); /* a = a + mu * m * b**i * * This is computed in place and on the fly. The multiplication * by b**i is handled by offseting which columns the results * are added to. * * Note the comba method normally doesn't handle carries in the * inner loop In this case we fix the carry from the previous * column since the Montgomery reduction requires digits of the * result (so far) [see above] to work. This is * handled by fixing up one carry after the inner loop. The * carry fixups are done in order so after these loops the * first m->used words of W[] have the carries fixed */ { register int iy; register mp_digit *tmpn; register mp_word *_W; /* alias for the digits of the modulus */ tmpn = n->dp; /* Alias for the columns set by an offset of ix */ _W = W + ix; /* inner loop */ for (iy = 0; iy < n->used; iy++) { *_W++ += ((mp_word)mu) * ((mp_word)*tmpn++); } } /* now fix carry for next digit, W[ix+1] */ W[ix + 1] += W[ix] >> ((mp_word) DIGIT_BIT); } /* now we have to propagate the carries and * shift the words downward [all those least * significant digits we zeroed]. */ { register mp_digit *tmpx; register mp_word *_W, *_W1; /* nox fix rest of carries */ /* alias for current word */ _W1 = W + ix; /* alias for next word, where the carry goes */ _W = W + ++ix; for (; ix <= n->used * 2 + 1; ix++) { *_W++ += *_W1++ >> ((mp_word) DIGIT_BIT); } /* copy out, A = A/b**n * * The result is A/b**n but instead of converting from an * array of mp_word to mp_digit than calling mp_rshd * we just copy them in the right order */ /* alias for destination word */ tmpx = x->dp; /* alias for shifted double precision result */ _W = W + n->used; for (ix = 0; ix < n->used + 1; ix++) { *tmpx++ = (mp_digit)(*_W++ & ((mp_word) MP_MASK)); } /* zero oldused digits, if the input a was larger than * m->used+1 we'll have to clear the digits */ for (; ix < olduse; ix++) { *tmpx++ = 0; } } /* set the max used and clamp */ x->used = n->used + 1; mp_clamp (x); /* if A >= m then A = A - m */ if (mp_cmp_mag (x, n) != MP_LT) { return s_mp_sub (x, n, x); } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_mp_montgomery_reduce.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_fast_s_mp_mul_digs.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | #include <tommath.h> #ifdef BN_FAST_S_MP_MUL_DIGS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Fast (comba) multiplier * * This is the fast column-array [comba] multiplier. It is * designed to compute the columns of the product first * then handle the carries afterwards. This has the effect * of making the nested loops that compute the columns very * simple and schedulable on super-scalar processors. * * This has been modified to produce a variable number of * digits of output so if say only a half-product is required * you don't have to compute the upper half (a feature * required for fast Barrett reduction). * * Based on Algorithm 14.12 on pp.595 of HAC. * */ int fast_s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) { int olduse, res, pa, ix, iz; mp_digit W[MP_WARRAY]; register mp_word _W; /* grow the destination as required */ if (c->alloc < digs) { if ((res = mp_grow (c, digs)) != MP_OKAY) { return res; } } /* number of output digits to produce */ pa = MIN(digs, a->used + b->used); /* clear the carry */ _W = 0; for (ix = 0; ix < pa; ix++) { int tx, ty; int iy; mp_digit *tmpx, *tmpy; /* get offsets into the two bignums */ ty = MIN(b->used-1, ix); tx = ix - ty; /* setup temp aliases */ tmpx = a->dp + tx; tmpy = b->dp + ty; /* this is the number of times the loop will iterrate, essentially while (tx++ < a->used && ty-- >= 0) { ... } */ iy = MIN(a->used-tx, ty+1); /* execute loop */ for (iz = 0; iz < iy; ++iz) { _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); } /* store term */ W[ix] = ((mp_digit)_W) & MP_MASK; /* make next carry */ _W = _W >> ((mp_word)DIGIT_BIT); } /* store final carry */ W[ix] = (mp_digit)(_W & MP_MASK); /* setup dest */ olduse = c->used; c->used = pa; { register mp_digit *tmpc; tmpc = c->dp; for (ix = 0; ix < pa+1; ix++) { /* now extract the previous digit [below the carry] */ *tmpc++ = W[ix]; } /* clear unused digits [that existed in the old copy of c] */ for (; ix < olduse; ix++) { *tmpc++ = 0; } } mp_clamp (c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_s_mp_mul_digs.c,v $ */ /* $Revision: 1.1.1.1.2.3 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_fast_s_mp_mul_high_digs.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | #include <tommath.h> #ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* this is a modified version of fast_s_mul_digs that only produces * output digits *above* digs. See the comments for fast_s_mul_digs * to see how it works. * * This is used in the Barrett reduction since for one of the multiplications * only the higher digits were needed. This essentially halves the work. * * Based on Algorithm 14.12 on pp.595 of HAC. */ int fast_s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) { int olduse, res, pa, ix, iz; mp_digit W[MP_WARRAY]; mp_word _W; /* grow the destination as required */ pa = a->used + b->used; if (c->alloc < pa) { if ((res = mp_grow (c, pa)) != MP_OKAY) { return res; } } /* number of output digits to produce */ pa = a->used + b->used; _W = 0; for (ix = digs; ix < pa; ix++) { int tx, ty, iy; mp_digit *tmpx, *tmpy; /* get offsets into the two bignums */ ty = MIN(b->used-1, ix); tx = ix - ty; /* setup temp aliases */ tmpx = a->dp + tx; tmpy = b->dp + ty; /* this is the number of times the loop will iterrate, essentially its while (tx++ < a->used && ty-- >= 0) { ... } */ iy = MIN(a->used-tx, ty+1); /* execute loop */ for (iz = 0; iz < iy; iz++) { _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); } /* store term */ W[ix] = ((mp_digit)_W) & MP_MASK; /* make next carry */ _W = _W >> ((mp_word)DIGIT_BIT); } /* store final carry */ W[ix] = (mp_digit)(_W & MP_MASK); /* setup dest */ olduse = c->used; c->used = pa; { register mp_digit *tmpc; tmpc = c->dp + digs; for (ix = digs; ix <= pa; ix++) { /* now extract the previous digit [below the carry] */ *tmpc++ = W[ix]; } /* clear unused digits [that existed in the old copy of c] */ for (; ix < olduse; ix++) { *tmpc++ = 0; } } mp_clamp (c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_s_mp_mul_high_digs.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_fast_s_mp_sqr.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | #include <tommath.h> #ifdef BN_FAST_S_MP_SQR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* the jist of squaring... * you do like mult except the offset of the tmpx [one that * starts closer to zero] can't equal the offset of tmpy. * So basically you set up iy like before then you min it with * (ty-tx) so that it never happens. You double all those * you add in the inner loop After that loop you do the squares and add them in. */ int fast_s_mp_sqr (mp_int * a, mp_int * b) { int olduse, res, pa, ix, iz; mp_digit W[MP_WARRAY], *tmpx; mp_word W1; /* grow the destination as required */ pa = a->used + a->used; if (b->alloc < pa) { if ((res = mp_grow (b, pa)) != MP_OKAY) { return res; } } /* number of output digits to produce */ W1 = 0; for (ix = 0; ix < pa; ix++) { int tx, ty, iy; mp_word _W; mp_digit *tmpy; /* clear counter */ _W = 0; /* get offsets into the two bignums */ ty = MIN(a->used-1, ix); tx = ix - ty; /* setup temp aliases */ tmpx = a->dp + tx; tmpy = a->dp + ty; /* this is the number of times the loop will iterrate, essentially while (tx++ < a->used && ty-- >= 0) { ... } */ iy = MIN(a->used-tx, ty+1); /* now for squaring tx can never equal ty * we halve the distance since they approach at a rate of 2x * and we have to round because odd cases need to be executed */ iy = MIN(iy, (ty-tx+1)>>1); /* execute loop */ for (iz = 0; iz < iy; iz++) { _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); } /* double the inner product and add carry */ _W = _W + _W + W1; /* even columns have the square term in them */ if ((ix&1) == 0) { _W += ((mp_word)a->dp[ix>>1])*((mp_word)a->dp[ix>>1]); } /* store it */ W[ix] = (mp_digit)(_W & MP_MASK); /* make next carry */ W1 = _W >> ((mp_word)DIGIT_BIT); } /* setup dest */ olduse = b->used; b->used = a->used+a->used; { mp_digit *tmpb; tmpb = b->dp; for (ix = 0; ix < pa; ix++) { *tmpb++ = W[ix] & MP_MASK; } /* clear unused digits [that existed in the old copy of c] */ for (; ix < olduse; ix++) { *tmpb++ = 0; } } mp_clamp (b); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_fast_s_mp_sqr.c,v $ */ /* $Revision: 1.1.1.1.2.3 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_2expt.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | #include <tommath.h> #ifdef BN_MP_2EXPT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes a = 2**b * * Simple algorithm which zeroes the int, grows it then just sets one bit * as required. */ int mp_2expt (mp_int * a, int b) { int res; /* zero a as per default */ mp_zero (a); /* grow a to accomodate the single bit */ if ((res = mp_grow (a, b / DIGIT_BIT + 1)) != MP_OKAY) { return res; } /* set the used count of where the bit will go */ a->used = b / DIGIT_BIT + 1; /* put the single bit in its place */ a->dp[b / DIGIT_BIT] = ((mp_digit)1) << (b % DIGIT_BIT); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_2expt.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_abs.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | #include <tommath.h> #ifdef BN_MP_ABS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* b = |a| * * Simple function copies the input and fixes the sign to positive */ int mp_abs (mp_int * a, mp_int * b) { int res; /* copy a to b */ if (a != b) { if ((res = mp_copy (a, b)) != MP_OKAY) { return res; } } /* force the sign of b to positive */ b->sign = MP_ZPOS; return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_abs.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_add.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | #include <tommath.h> #ifdef BN_MP_ADD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* high level addition (handles signs) */ int mp_add (mp_int * a, mp_int * b, mp_int * c) { int sa, sb, res; /* get sign of both inputs */ sa = a->sign; sb = b->sign; /* handle two cases, not four */ if (sa == sb) { /* both positive or both negative */ /* add their magnitudes, copy the sign */ c->sign = sa; res = s_mp_add (a, b, c); } else { /* one positive, the other negative */ /* subtract the one with the greater magnitude from */ /* the one of the lesser magnitude. The result gets */ /* the sign of the one with the greater magnitude. */ if (mp_cmp_mag (a, b) == MP_LT) { c->sign = sb; res = s_mp_sub (b, a, c); } else { c->sign = sa; res = s_mp_sub (a, b, c); } } return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_add.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_add_d.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | #include <tommath.h> #ifdef BN_MP_ADD_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* single digit addition */ int mp_add_d (mp_int * a, mp_digit b, mp_int * c) { int res, ix, oldused; mp_digit *tmpa, *tmpc, mu; /* grow c as required */ if (c->alloc < a->used + 1) { if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) { return res; } } /* if a is negative and |a| >= b, call c = |a| - b */ if (a->sign == MP_NEG && (a->used > 1 || a->dp[0] >= b)) { /* temporarily fix sign of a */ a->sign = MP_ZPOS; /* c = |a| - b */ res = mp_sub_d(a, b, c); /* fix signs */ a->sign = MP_NEG; c->sign = (c->used) ? MP_NEG : MP_ZPOS; return res; } /* old number of used digits in c */ oldused = c->used; /* sign always positive */ c->sign = MP_ZPOS; /* source alias */ tmpa = a->dp; /* destination alias */ tmpc = c->dp; /* if a is positive */ if (a->sign == MP_ZPOS) { /* add digit, after this we're propagating * the carry. */ *tmpc = *tmpa++ + b; mu = *tmpc >> DIGIT_BIT; *tmpc++ &= MP_MASK; /* now handle rest of the digits */ for (ix = 1; ix < a->used; ix++) { *tmpc = *tmpa++ + mu; mu = *tmpc >> DIGIT_BIT; *tmpc++ &= MP_MASK; } /* set final carry */ ix++; *tmpc++ = mu; /* setup size */ c->used = a->used + 1; } else { /* a was negative and |a| < b */ c->used = 1; /* the result is a single digit */ if (a->used == 1) { *tmpc++ = b - a->dp[0]; } else { *tmpc++ = b; } /* setup count so the clearing of oldused * can fall through correctly */ ix = 1; } /* now zero to oldused */ while (ix++ < oldused) { *tmpc++ = 0; } mp_clamp(c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_add_d.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_addmod.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | #include <tommath.h> #ifdef BN_MP_ADDMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* d = a + b (mod c) */ int mp_addmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) { int res; mp_int t; if ((res = mp_init (&t)) != MP_OKAY) { return res; } if ((res = mp_add (a, b, &t)) != MP_OKAY) { mp_clear (&t); return res; } res = mp_mod (&t, c, d); mp_clear (&t); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_addmod.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_and.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | #include <tommath.h> #ifdef BN_MP_AND_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* AND two ints together */ int mp_and (mp_int * a, mp_int * b, mp_int * c) { int res, ix, px; mp_int t, *x; if (a->used > b->used) { if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } px = b->used; x = b; } else { if ((res = mp_init_copy (&t, b)) != MP_OKAY) { return res; } px = a->used; x = a; } for (ix = 0; ix < px; ix++) { t.dp[ix] &= x->dp[ix]; } /* zero digits above the last from the smallest mp_int */ for (; ix < t.used; ix++) { t.dp[ix] = 0; } mp_clamp (&t); mp_exch (c, &t); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_and.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_clamp.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | #include <tommath.h> #ifdef BN_MP_CLAMP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* trim unused digits * * This is used to ensure that leading zero digits are * trimed and the leading "used" digit will be non-zero * Typically very fast. Also fixes the sign if there * are no more leading digits */ void mp_clamp (mp_int * a) { /* decrease used while the most significant digit is * zero. */ while (a->used > 0 && a->dp[a->used - 1] == 0) { --(a->used); } /* reset the sign flag if used == 0 */ if (a->used == 0) { a->sign = MP_ZPOS; } } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_clamp.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_clear.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | #include <tommath.h> #ifdef BN_MP_CLEAR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* clear one (frees) */ void mp_clear (mp_int * a) { int i; /* only do anything if a hasn't been freed previously */ if (a->dp != NULL) { /* first zero the digits */ for (i = 0; i < a->used; i++) { a->dp[i] = 0; } /* free ram */ XFREE(a->dp); /* reset members to make debugging easier */ a->dp = NULL; a->alloc = a->used = 0; a->sign = MP_ZPOS; } } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_clear.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_clear_multi.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | #include <tommath.h> #ifdef BN_MP_CLEAR_MULTI_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ #include <stdarg.h> void mp_clear_multi(mp_int *mp, ...) { mp_int* next_mp = mp; va_list args; va_start(args, mp); while (next_mp != NULL) { mp_clear(next_mp); next_mp = va_arg(args, mp_int*); } va_end(args); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_clear_multi.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_cmp.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | #include <tommath.h> #ifdef BN_MP_CMP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* compare two ints (signed)*/ int mp_cmp (mp_int * a, mp_int * b) { /* compare based on sign */ if (a->sign != b->sign) { if (a->sign == MP_NEG) { return MP_LT; } else { return MP_GT; } } /* compare digits */ if (a->sign == MP_NEG) { /* if negative compare opposite direction */ return mp_cmp_mag(b, a); } else { return mp_cmp_mag(a, b); } } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_cmp.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_cmp_d.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | #include <tommath.h> #ifdef BN_MP_CMP_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* compare a digit */ int mp_cmp_d(mp_int * a, mp_digit b) { /* compare based on sign */ if (a->sign == MP_NEG) { return MP_LT; } /* compare based on magnitude */ if (a->used > 1) { return MP_GT; } /* compare the only digit of a to b */ if (a->dp[0] > b) { return MP_GT; } else if (a->dp[0] < b) { return MP_LT; } else { return MP_EQ; } } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_cmp_d.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_cmp_mag.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | #include <tommath.h> #ifdef BN_MP_CMP_MAG_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* compare maginitude of two ints (unsigned) */ int mp_cmp_mag (mp_int * a, mp_int * b) { int n; mp_digit *tmpa, *tmpb; /* compare based on # of non-zero digits */ if (a->used > b->used) { return MP_GT; } if (a->used < b->used) { return MP_LT; } /* alias for a */ tmpa = a->dp + (a->used - 1); /* alias for b */ tmpb = b->dp + (a->used - 1); /* compare based on digits */ for (n = 0; n < a->used; ++n, --tmpa, --tmpb) { if (*tmpa > *tmpb) { return MP_GT; } if (*tmpa < *tmpb) { return MP_LT; } } return MP_EQ; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_cmp_mag.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_cnt_lsb.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | #include <tommath.h> #ifdef BN_MP_CNT_LSB_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ static const int lnz[16] = { 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0 }; /* Counts the number of lsbs which are zero before the first zero bit */ int mp_cnt_lsb(mp_int *a) { int x; mp_digit q, qq; /* easy out */ if (mp_iszero(a) == 1) { return 0; } /* scan lower digits until non-zero */ for (x = 0; x < a->used && a->dp[x] == 0; x++); q = a->dp[x]; x *= DIGIT_BIT; /* now scan this digit until a 1 is found */ if ((q & 1) == 0) { do { qq = q & 15; x += lnz[qq]; q >>= 4; } while (qq == 0); } return x; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_cnt_lsb.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_copy.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | #include <tommath.h> #ifdef BN_MP_COPY_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* copy, b = a */ int mp_copy (mp_int * a, mp_int * b) { int res, n; /* if dst == src do nothing */ if (a == b) { return MP_OKAY; } /* grow dest */ if (b->alloc < a->used) { if ((res = mp_grow (b, a->used)) != MP_OKAY) { return res; } } /* zero b and copy the parameters over */ { register mp_digit *tmpa, *tmpb; /* pointer aliases */ /* source */ tmpa = a->dp; /* destination */ tmpb = b->dp; /* copy all the digits */ for (n = 0; n < a->used; n++) { *tmpb++ = *tmpa++; } /* clear high digits */ for (; n < b->used; n++) { *tmpb++ = 0; } } /* copy used count and sign */ b->used = a->used; b->sign = a->sign; return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_copy.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_count_bits.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | #include <tommath.h> #ifdef BN_MP_COUNT_BITS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* returns the number of bits in an int */ int mp_count_bits (mp_int * a) { int r; mp_digit q; /* shortcut */ if (a->used == 0) { return 0; } /* get number of digits and add that */ r = (a->used - 1) * DIGIT_BIT; /* take the last digit and count the bits in it */ q = a->dp[a->used - 1]; while (q > ((mp_digit) 0)) { ++r; q >>= ((mp_digit) 1); } return r; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_count_bits.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_div.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 | #include <tommath.h> #ifdef BN_MP_DIV_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ #ifdef BN_MP_DIV_SMALL /* slower bit-bang division... also smaller */ int mp_div(mp_int * a, mp_int * b, mp_int * c, mp_int * d) { mp_int ta, tb, tq, q; int res, n, n2; /* is divisor zero ? */ if (mp_iszero (b) == 1) { return MP_VAL; } /* if a < b then q=0, r = a */ if (mp_cmp_mag (a, b) == MP_LT) { if (d != NULL) { res = mp_copy (a, d); } else { res = MP_OKAY; } if (c != NULL) { mp_zero (c); } return res; } /* init our temps */ if ((res = mp_init_multi(&ta, &tb, &tq, &q, NULL) != MP_OKAY)) { return res; } mp_set(&tq, 1); n = mp_count_bits(a) - mp_count_bits(b); if (((res = mp_abs(a, &ta)) != MP_OKAY) || ((res = mp_abs(b, &tb)) != MP_OKAY) || ((res = mp_mul_2d(&tb, n, &tb)) != MP_OKAY) || ((res = mp_mul_2d(&tq, n, &tq)) != MP_OKAY)) { goto LBL_ERR; } while (n-- >= 0) { if (mp_cmp(&tb, &ta) != MP_GT) { if (((res = mp_sub(&ta, &tb, &ta)) != MP_OKAY) || ((res = mp_add(&q, &tq, &q)) != MP_OKAY)) { goto LBL_ERR; } } if (((res = mp_div_2d(&tb, 1, &tb, NULL)) != MP_OKAY) || ((res = mp_div_2d(&tq, 1, &tq, NULL)) != MP_OKAY)) { goto LBL_ERR; } } /* now q == quotient and ta == remainder */ n = a->sign; n2 = (a->sign == b->sign ? MP_ZPOS : MP_NEG); if (c != NULL) { mp_exch(c, &q); c->sign = (mp_iszero(c) == MP_YES) ? MP_ZPOS : n2; } if (d != NULL) { mp_exch(d, &ta); d->sign = (mp_iszero(d) == MP_YES) ? MP_ZPOS : n; } LBL_ERR: mp_clear_multi(&ta, &tb, &tq, &q, NULL); return res; } #else /* integer signed division. * c*b + d == a [e.g. a/b, c=quotient, d=remainder] * HAC pp.598 Algorithm 14.20 * * Note that the description in HAC is horribly * incomplete. For example, it doesn't consider * the case where digits are removed from 'x' in * the inner loop. It also doesn't consider the * case that y has fewer than three digits, etc.. * * The overall algorithm is as described as * 14.20 from HAC but fixed to treat these cases. */ int mp_div (mp_int * a, mp_int * b, mp_int * c, mp_int * d) { mp_int q, x, y, t1, t2; int res, n, t, i, norm, neg; /* is divisor zero ? */ if (mp_iszero (b) == 1) { return MP_VAL; } /* if a < b then q=0, r = a */ if (mp_cmp_mag (a, b) == MP_LT) { if (d != NULL) { res = mp_copy (a, d); } else { res = MP_OKAY; } if (c != NULL) { mp_zero (c); } return res; } if ((res = mp_init_size (&q, a->used + 2)) != MP_OKAY) { return res; } q.used = a->used + 2; if ((res = mp_init (&t1)) != MP_OKAY) { goto LBL_Q; } if ((res = mp_init (&t2)) != MP_OKAY) { goto LBL_T1; } if ((res = mp_init_copy (&x, a)) != MP_OKAY) { goto LBL_T2; } if ((res = mp_init_copy (&y, b)) != MP_OKAY) { goto LBL_X; } /* fix the sign */ neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; x.sign = y.sign = MP_ZPOS; /* normalize both x and y, ensure that y >= b/2, [b == 2**DIGIT_BIT] */ norm = mp_count_bits(&y) % DIGIT_BIT; if (norm < (int)(DIGIT_BIT-1)) { norm = (DIGIT_BIT-1) - norm; if ((res = mp_mul_2d (&x, norm, &x)) != MP_OKAY) { goto LBL_Y; } if ((res = mp_mul_2d (&y, norm, &y)) != MP_OKAY) { goto LBL_Y; } } else { norm = 0; } /* note hac does 0 based, so if used==5 then its 0,1,2,3,4, e.g. use 4 */ n = x.used - 1; t = y.used - 1; /* while (x >= y*b**n-t) do { q[n-t] += 1; x -= y*b**{n-t} } */ if ((res = mp_lshd (&y, n - t)) != MP_OKAY) { /* y = y*b**{n-t} */ goto LBL_Y; } while (mp_cmp (&x, &y) != MP_LT) { ++(q.dp[n - t]); if ((res = mp_sub (&x, &y, &x)) != MP_OKAY) { goto LBL_Y; } } /* reset y by shifting it back down */ mp_rshd (&y, n - t); /* step 3. for i from n down to (t + 1) */ for (i = n; i >= (t + 1); i--) { if (i > x.used) { continue; } /* step 3.1 if xi == yt then set q{i-t-1} to b-1, * otherwise set q{i-t-1} to (xi*b + x{i-1})/yt */ if (x.dp[i] == y.dp[t]) { q.dp[i - t - 1] = ((((mp_digit)1) << DIGIT_BIT) - 1); } else { mp_word tmp; tmp = ((mp_word) x.dp[i]) << ((mp_word) DIGIT_BIT); tmp |= ((mp_word) x.dp[i - 1]); tmp /= ((mp_word) y.dp[t]); if (tmp > (mp_word) MP_MASK) tmp = MP_MASK; q.dp[i - t - 1] = (mp_digit) (tmp & (mp_word) (MP_MASK)); } /* while (q{i-t-1} * (yt * b + y{t-1})) > xi * b**2 + xi-1 * b + xi-2 do q{i-t-1} -= 1; */ q.dp[i - t - 1] = (q.dp[i - t - 1] + 1) & MP_MASK; do { q.dp[i - t - 1] = (q.dp[i - t - 1] - 1) & MP_MASK; /* find left hand */ mp_zero (&t1); t1.dp[0] = (t - 1 < 0) ? 0 : y.dp[t - 1]; t1.dp[1] = y.dp[t]; t1.used = 2; if ((res = mp_mul_d (&t1, q.dp[i - t - 1], &t1)) != MP_OKAY) { goto LBL_Y; } /* find right hand */ t2.dp[0] = (i - 2 < 0) ? 0 : x.dp[i - 2]; t2.dp[1] = (i - 1 < 0) ? 0 : x.dp[i - 1]; t2.dp[2] = x.dp[i]; t2.used = 3; } while (mp_cmp_mag(&t1, &t2) == MP_GT); /* step 3.3 x = x - q{i-t-1} * y * b**{i-t-1} */ if ((res = mp_mul_d (&y, q.dp[i - t - 1], &t1)) != MP_OKAY) { goto LBL_Y; } if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) { goto LBL_Y; } if ((res = mp_sub (&x, &t1, &x)) != MP_OKAY) { goto LBL_Y; } /* if x < 0 then { x = x + y*b**{i-t-1}; q{i-t-1} -= 1; } */ if (x.sign == MP_NEG) { if ((res = mp_copy (&y, &t1)) != MP_OKAY) { goto LBL_Y; } if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) { goto LBL_Y; } if ((res = mp_add (&x, &t1, &x)) != MP_OKAY) { goto LBL_Y; } q.dp[i - t - 1] = (q.dp[i - t - 1] - 1UL) & MP_MASK; } } /* now q is the quotient and x is the remainder * [which we have to normalize] */ /* get sign before writing to c */ x.sign = x.used == 0 ? MP_ZPOS : a->sign; if (c != NULL) { mp_clamp (&q); mp_exch (&q, c); c->sign = neg; } if (d != NULL) { mp_div_2d (&x, norm, &x, NULL); mp_exch (&x, d); } res = MP_OKAY; LBL_Y:mp_clear (&y); LBL_X:mp_clear (&x); LBL_T2:mp_clear (&t2); LBL_T1:mp_clear (&t1); LBL_Q:mp_clear (&q); return res; } #endif #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_div_2.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | #include <tommath.h> #ifdef BN_MP_DIV_2_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* b = a/2 */ int mp_div_2(mp_int * a, mp_int * b) { int x, res, oldused; /* copy */ if (b->alloc < a->used) { if ((res = mp_grow (b, a->used)) != MP_OKAY) { return res; } } oldused = b->used; b->used = a->used; { register mp_digit r, rr, *tmpa, *tmpb; /* source alias */ tmpa = a->dp + b->used - 1; /* dest alias */ tmpb = b->dp + b->used - 1; /* carry */ r = 0; for (x = b->used - 1; x >= 0; x--) { /* get the carry for the next iteration */ rr = *tmpa & 1; /* shift the current digit, add in carry and store */ *tmpb-- = (*tmpa-- >> 1) | (r << (DIGIT_BIT - 1)); /* forward carry to next iteration */ r = rr; } /* zero excess digits */ tmpb = b->dp + b->used; for (x = b->used; x < oldused; x++) { *tmpb++ = 0; } } b->sign = a->sign; mp_clamp (b); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div_2.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_div_2d.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 | #include <tommath.h> #ifdef BN_MP_DIV_2D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* shift right by a certain bit count (store quotient in c, optional remainder in d) */ int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d) { mp_digit D, r, rr; int x, res; mp_int t; /* if the shift count is <= 0 then we do no work */ if (b <= 0) { res = mp_copy (a, c); if (d != NULL) { mp_zero (d); } return res; } if ((res = mp_init (&t)) != MP_OKAY) { return res; } /* get the remainder */ if (d != NULL) { if ((res = mp_mod_2d (a, b, &t)) != MP_OKAY) { mp_clear (&t); return res; } } /* copy */ if ((res = mp_copy (a, c)) != MP_OKAY) { mp_clear (&t); return res; } /* shift by as many digits in the bit count */ if (b >= (int)DIGIT_BIT) { mp_rshd (c, b / DIGIT_BIT); } /* shift any bit count < DIGIT_BIT */ D = (mp_digit) (b % DIGIT_BIT); if (D != 0) { register mp_digit *tmpc, mask, shift; /* mask */ mask = (((mp_digit)1) << D) - 1; /* shift for lsb */ shift = DIGIT_BIT - D; /* alias */ tmpc = c->dp + (c->used - 1); /* carry */ r = 0; for (x = c->used - 1; x >= 0; x--) { /* get the lower bits of this word in a temp */ rr = *tmpc & mask; /* shift the current word and mix in the carry bits from the previous word */ *tmpc = (*tmpc >> D) | (r << shift); --tmpc; /* set the carry to the carry bits of the current word found above */ r = rr; } } mp_clamp (c); if (d != NULL) { mp_exch (&t, d); } mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div_2d.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_div_3.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | #include <tommath.h> #ifdef BN_MP_DIV_3_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* divide by three (based on routine from MPI and the GMP manual) */ int mp_div_3 (mp_int * a, mp_int *c, mp_digit * d) { mp_int q; mp_word w, t; mp_digit b; int res, ix; /* b = 2**DIGIT_BIT / 3 */ b = (((mp_word)1) << ((mp_word)DIGIT_BIT)) / ((mp_word)3); if ((res = mp_init_size(&q, a->used)) != MP_OKAY) { return res; } q.used = a->used; q.sign = a->sign; w = 0; for (ix = a->used - 1; ix >= 0; ix--) { w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]); if (w >= 3) { /* multiply w by [1/3] */ t = (w * ((mp_word)b)) >> ((mp_word)DIGIT_BIT); /* now subtract 3 * [w/3] from w, to get the remainder */ w -= t+t+t; /* fixup the remainder as required since * the optimization is not exact. */ while (w >= 3) { t += 1; w -= 3; } } else { t = 0; } q.dp[ix] = (mp_digit)t; } /* [optional] store the remainder */ if (d != NULL) { *d = (mp_digit)w; } /* [optional] store the quotient */ if (c != NULL) { mp_clamp(&q); mp_exch(&q, c); } mp_clear(&q); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div_3.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_div_d.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | #include <tommath.h> #ifdef BN_MP_DIV_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ static int s_is_power_of_two(mp_digit b, int *p) { int x; for (x = 1; x < DIGIT_BIT; x++) { if (b == (((mp_digit)1)<<x)) { *p = x; return 1; } } return 0; } /* single digit division (based on routine from MPI) */ int mp_div_d (mp_int * a, mp_digit b, mp_int * c, mp_digit * d) { mp_int q; mp_word w; mp_digit t; int res, ix; /* cannot divide by zero */ if (b == 0) { return MP_VAL; } /* quick outs */ if (b == 1 || mp_iszero(a) == 1) { if (d != NULL) { *d = 0; } if (c != NULL) { return mp_copy(a, c); } return MP_OKAY; } /* power of two ? */ if (s_is_power_of_two(b, &ix) == 1) { if (d != NULL) { *d = a->dp[0] & ((((mp_digit)1)<<ix) - 1); } if (c != NULL) { return mp_div_2d(a, ix, c, NULL); } return MP_OKAY; } #ifdef BN_MP_DIV_3_C /* three? */ if (b == 3) { return mp_div_3(a, c, d); } #endif /* no easy answer [c'est la vie]. Just division */ if ((res = mp_init_size(&q, a->used)) != MP_OKAY) { return res; } q.used = a->used; q.sign = a->sign; w = 0; for (ix = a->used - 1; ix >= 0; ix--) { w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]); if (w >= b) { t = (mp_digit)(w / b); w -= ((mp_word)t) * ((mp_word)b); } else { t = 0; } q.dp[ix] = (mp_digit)t; } if (d != NULL) { *d = (mp_digit)w; } if (c != NULL) { mp_clamp(&q); mp_exch(&q, c); } mp_clear(&q); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_div_d.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_dr_is_modulus.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | #include <tommath.h> #ifdef BN_MP_DR_IS_MODULUS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines if a number is a valid DR modulus */ int mp_dr_is_modulus(mp_int *a) { int ix; /* must be at least two digits */ if (a->used < 2) { return 0; } /* must be of the form b**k - a [a <= b] so all * but the first digit must be equal to -1 (mod b). */ for (ix = 1; ix < a->used; ix++) { if (a->dp[ix] != MP_MASK) { return 0; } } return 1; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_dr_is_modulus.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_dr_reduce.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | #include <tommath.h> #ifdef BN_MP_DR_REDUCE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* reduce "x" in place modulo "n" using the Diminished Radix algorithm. * * Based on algorithm from the paper * * "Generating Efficient Primes for Discrete Log Cryptosystems" * Chae Hoon Lim, Pil Joong Lee, * POSTECH Information Research Laboratories * * The modulus must be of a special format [see manual] * * Has been modified to use algorithm 7.10 from the LTM book instead * * Input x must be in the range 0 <= x <= (n-1)**2 */ int mp_dr_reduce (mp_int * x, mp_int * n, mp_digit k) { int err, i, m; mp_word r; mp_digit mu, *tmpx1, *tmpx2; /* m = digits in modulus */ m = n->used; /* ensure that "x" has at least 2m digits */ if (x->alloc < m + m) { if ((err = mp_grow (x, m + m)) != MP_OKAY) { return err; } } /* top of loop, this is where the code resumes if * another reduction pass is required. */ top: /* aliases for digits */ /* alias for lower half of x */ tmpx1 = x->dp; /* alias for upper half of x, or x/B**m */ tmpx2 = x->dp + m; /* set carry to zero */ mu = 0; /* compute (x mod B**m) + k * [x/B**m] inline and inplace */ for (i = 0; i < m; i++) { r = ((mp_word)*tmpx2++) * ((mp_word)k) + *tmpx1 + mu; *tmpx1++ = (mp_digit)(r & MP_MASK); mu = (mp_digit)(r >> ((mp_word)DIGIT_BIT)); } /* set final carry */ *tmpx1++ = mu; /* zero words above m */ for (i = m + 1; i < x->used; i++) { *tmpx1++ = 0; } /* clamp, sub and return */ mp_clamp (x); /* if x >= n then subtract and reduce again * Each successive "recursion" makes the input smaller and smaller. */ if (mp_cmp_mag (x, n) != MP_LT) { s_mp_sub(x, n, x); goto top; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_dr_reduce.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_dr_setup.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | #include <tommath.h> #ifdef BN_MP_DR_SETUP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines the setup value */ void mp_dr_setup(mp_int *a, mp_digit *d) { /* the casts are required if DIGIT_BIT is one less than * the number of bits in a mp_digit [e.g. DIGIT_BIT==31] */ *d = (mp_digit)((((mp_word)1) << ((mp_word)DIGIT_BIT)) - ((mp_word)a->dp[0])); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_dr_setup.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_exch.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | #include <tommath.h> #ifdef BN_MP_EXCH_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* swap the elements of two integers, for cases where you can't simply swap the * mp_int pointers around */ void mp_exch (mp_int * a, mp_int * b) { mp_int t; t = *a; *a = *b; *b = t; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_exch.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_expt_d.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | #include <tommath.h> #ifdef BN_MP_EXPT_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* calculate c = a**b using a square-multiply algorithm */ int mp_expt_d (mp_int * a, mp_digit b, mp_int * c) { int res, x; mp_int g; if ((res = mp_init_copy (&g, a)) != MP_OKAY) { return res; } /* set initial result */ mp_set (c, 1); for (x = 0; x < (int) DIGIT_BIT; x++) { /* square */ if ((res = mp_sqr (c, c)) != MP_OKAY) { mp_clear (&g); return res; } /* if the bit is set multiply */ if ((b & (mp_digit) (((mp_digit)1) << (DIGIT_BIT - 1))) != 0) { if ((res = mp_mul (c, &g, c)) != MP_OKAY) { mp_clear (&g); return res; } } /* shift to next bit */ b <<= 1; } mp_clear (&g); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_expt_d.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_exptmod.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | #include <tommath.h> #ifdef BN_MP_EXPTMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* this is a shell function that calls either the normal or Montgomery * exptmod functions. Originally the call to the montgomery code was * embedded in the normal function but that wasted alot of stack space * for nothing (since 99% of the time the Montgomery code would be called) */ int mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y) { int dr; /* modulus P must be positive */ if (P->sign == MP_NEG) { return MP_VAL; } /* if exponent X is negative we have to recurse */ if (X->sign == MP_NEG) { #ifdef BN_MP_INVMOD_C mp_int tmpG, tmpX; int err; /* first compute 1/G mod P */ if ((err = mp_init(&tmpG)) != MP_OKAY) { return err; } if ((err = mp_invmod(G, P, &tmpG)) != MP_OKAY) { mp_clear(&tmpG); return err; } /* now get |X| */ if ((err = mp_init(&tmpX)) != MP_OKAY) { mp_clear(&tmpG); return err; } if ((err = mp_abs(X, &tmpX)) != MP_OKAY) { mp_clear_multi(&tmpG, &tmpX, NULL); return err; } /* and now compute (1/G)**|X| instead of G**X [X < 0] */ err = mp_exptmod(&tmpG, &tmpX, P, Y); mp_clear_multi(&tmpG, &tmpX, NULL); return err; #else /* no invmod */ return MP_VAL; #endif } /* modified diminished radix reduction */ #if defined(BN_MP_REDUCE_IS_2K_L_C) && defined(BN_MP_REDUCE_2K_L_C) && defined(BN_S_MP_EXPTMOD_C) if (mp_reduce_is_2k_l(P) == MP_YES) { return s_mp_exptmod(G, X, P, Y, 1); } #endif #ifdef BN_MP_DR_IS_MODULUS_C /* is it a DR modulus? */ dr = mp_dr_is_modulus(P); #else /* default to no */ dr = 0; #endif #ifdef BN_MP_REDUCE_IS_2K_C /* if not, is it a unrestricted DR modulus? */ if (dr == 0) { dr = mp_reduce_is_2k(P) << 1; } #endif /* if the modulus is odd or dr != 0 use the montgomery method */ #ifdef BN_MP_EXPTMOD_FAST_C if (mp_isodd (P) == 1 || dr != 0) { return mp_exptmod_fast (G, X, P, Y, dr); } else { #endif #ifdef BN_S_MP_EXPTMOD_C /* otherwise use the generic Barrett reduction technique */ return s_mp_exptmod (G, X, P, Y, 0); #else /* no exptmod for evens */ return MP_VAL; #endif #ifdef BN_MP_EXPTMOD_FAST_C } #endif } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_exptmod.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_exptmod_fast.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 | #include <tommath.h> #ifdef BN_MP_EXPTMOD_FAST_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes Y == G**X mod P, HAC pp.616, Algorithm 14.85 * * Uses a left-to-right k-ary sliding window to compute the modular exponentiation. * The value of k changes based on the size of the exponent. * * Uses Montgomery or Diminished Radix reduction [whichever appropriate] */ #ifdef MP_LOW_MEM #define TAB_SIZE 32 #else #define TAB_SIZE 256 #endif int mp_exptmod_fast (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode) { mp_int M[TAB_SIZE], res; mp_digit buf, mp; int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; /* use a pointer to the reduction algorithm. This allows us to use * one of many reduction algorithms without modding the guts of * the code with if statements everywhere. */ int (*redux)(mp_int*,mp_int*,mp_digit); /* find window size */ x = mp_count_bits (X); if (x <= 7) { winsize = 2; } else if (x <= 36) { winsize = 3; } else if (x <= 140) { winsize = 4; } else if (x <= 450) { winsize = 5; } else if (x <= 1303) { winsize = 6; } else if (x <= 3529) { winsize = 7; } else { winsize = 8; } #ifdef MP_LOW_MEM if (winsize > 5) { winsize = 5; } #endif /* init M array */ /* init first cell */ if ((err = mp_init(&M[1])) != MP_OKAY) { return err; } /* now init the second half of the array */ for (x = 1<<(winsize-1); x < (1 << winsize); x++) { if ((err = mp_init(&M[x])) != MP_OKAY) { for (y = 1<<(winsize-1); y < x; y++) { mp_clear (&M[y]); } mp_clear(&M[1]); return err; } } /* determine and setup reduction code */ if (redmode == 0) { #ifdef BN_MP_MONTGOMERY_SETUP_C /* now setup montgomery */ if ((err = mp_montgomery_setup (P, &mp)) != MP_OKAY) { goto LBL_M; } #else err = MP_VAL; goto LBL_M; #endif /* automatically pick the comba one if available (saves quite a few calls/ifs) */ #ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C if (((P->used * 2 + 1) < MP_WARRAY) && P->used < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { redux = fast_mp_montgomery_reduce; } else #endif { #ifdef BN_MP_MONTGOMERY_REDUCE_C /* use slower baseline Montgomery method */ redux = mp_montgomery_reduce; #else err = MP_VAL; goto LBL_M; #endif } } else if (redmode == 1) { #if defined(BN_MP_DR_SETUP_C) && defined(BN_MP_DR_REDUCE_C) /* setup DR reduction for moduli of the form B**k - b */ mp_dr_setup(P, &mp); redux = mp_dr_reduce; #else err = MP_VAL; goto LBL_M; #endif } else { #if defined(BN_MP_REDUCE_2K_SETUP_C) && defined(BN_MP_REDUCE_2K_C) /* setup DR reduction for moduli of the form 2**k - b */ if ((err = mp_reduce_2k_setup(P, &mp)) != MP_OKAY) { goto LBL_M; } redux = mp_reduce_2k; #else err = MP_VAL; goto LBL_M; #endif } /* setup result */ if ((err = mp_init (&res)) != MP_OKAY) { goto LBL_M; } /* create M table * * * The first half of the table is not computed though accept for M[0] and M[1] */ if (redmode == 0) { #ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C /* now we need R mod m */ if ((err = mp_montgomery_calc_normalization (&res, P)) != MP_OKAY) { goto LBL_RES; } #else err = MP_VAL; goto LBL_RES; #endif /* now set M[1] to G * R mod m */ if ((err = mp_mulmod (G, &res, P, &M[1])) != MP_OKAY) { goto LBL_RES; } } else { mp_set(&res, 1); if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) { goto LBL_RES; } } /* compute the value at M[1<<(winsize-1)] by squaring M[1] (winsize-1) times */ if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) { goto LBL_RES; } for (x = 0; x < (winsize - 1); x++) { if ((err = mp_sqr (&M[1 << (winsize - 1)], &M[1 << (winsize - 1)])) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&M[1 << (winsize - 1)], P, mp)) != MP_OKAY) { goto LBL_RES; } } /* create upper table */ for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) { if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&M[x], P, mp)) != MP_OKAY) { goto LBL_RES; } } /* set initial mode and bit cnt */ mode = 0; bitcnt = 1; buf = 0; digidx = X->used - 1; bitcpy = 0; bitbuf = 0; for (;;) { /* grab next digit as required */ if (--bitcnt == 0) { /* if digidx == -1 we are out of digits so break */ if (digidx == -1) { break; } /* read next digit and reset bitcnt */ buf = X->dp[digidx--]; bitcnt = (int)DIGIT_BIT; } /* grab the next msb from the exponent */ y = (mp_digit)(buf >> (DIGIT_BIT - 1)) & 1; buf <<= (mp_digit)1; /* if the bit is zero and mode == 0 then we ignore it * These represent the leading zero bits before the first 1 bit * in the exponent. Technically this opt is not required but it * does lower the # of trivial squaring/reductions used */ if (mode == 0 && y == 0) { continue; } /* if the bit is zero and mode == 1 then we square */ if (mode == 1 && y == 0) { if ((err = mp_sqr (&res, &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, mp)) != MP_OKAY) { goto LBL_RES; } continue; } /* else we add it to the window */ bitbuf |= (y << (winsize - ++bitcpy)); mode = 2; if (bitcpy == winsize) { /* ok window is filled so square as required and multiply */ /* square first */ for (x = 0; x < winsize; x++) { if ((err = mp_sqr (&res, &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, mp)) != MP_OKAY) { goto LBL_RES; } } /* then multiply */ if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, mp)) != MP_OKAY) { goto LBL_RES; } /* empty window and reset */ bitcpy = 0; bitbuf = 0; mode = 1; } } /* if bits remain then square/multiply */ if (mode == 2 && bitcpy > 0) { /* square then multiply if the bit is set */ for (x = 0; x < bitcpy; x++) { if ((err = mp_sqr (&res, &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, mp)) != MP_OKAY) { goto LBL_RES; } /* get next bit of the window */ bitbuf <<= 1; if ((bitbuf & (1 << winsize)) != 0) { /* then multiply */ if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, mp)) != MP_OKAY) { goto LBL_RES; } } } } if (redmode == 0) { /* fixup result if Montgomery reduction is used * recall that any value in a Montgomery system is * actually multiplied by R mod n. So we have * to reduce one more time to cancel out the factor * of R. */ if ((err = redux(&res, P, mp)) != MP_OKAY) { goto LBL_RES; } } /* swap res with Y */ mp_exch (&res, Y); err = MP_OKAY; LBL_RES:mp_clear (&res); LBL_M: mp_clear(&M[1]); for (x = 1<<(winsize-1); x < (1 << winsize); x++) { mp_clear (&M[x]); } return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_exptmod_fast.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_exteuclid.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 | #include <tommath.h> #ifdef BN_MP_EXTEUCLID_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Extended euclidean algorithm of (a, b) produces a*u1 + b*u2 = u3 */ int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) { mp_int u1,u2,u3,v1,v2,v3,t1,t2,t3,q,tmp; int err; if ((err = mp_init_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL)) != MP_OKAY) { return err; } /* initialize, (u1,u2,u3) = (1,0,a) */ mp_set(&u1, 1); if ((err = mp_copy(a, &u3)) != MP_OKAY) { goto _ERR; } /* initialize, (v1,v2,v3) = (0,1,b) */ mp_set(&v2, 1); if ((err = mp_copy(b, &v3)) != MP_OKAY) { goto _ERR; } /* loop while v3 != 0 */ while (mp_iszero(&v3) == MP_NO) { /* q = u3/v3 */ if ((err = mp_div(&u3, &v3, &q, NULL)) != MP_OKAY) { goto _ERR; } /* (t1,t2,t3) = (u1,u2,u3) - (v1,v2,v3)q */ if ((err = mp_mul(&v1, &q, &tmp)) != MP_OKAY) { goto _ERR; } if ((err = mp_sub(&u1, &tmp, &t1)) != MP_OKAY) { goto _ERR; } if ((err = mp_mul(&v2, &q, &tmp)) != MP_OKAY) { goto _ERR; } if ((err = mp_sub(&u2, &tmp, &t2)) != MP_OKAY) { goto _ERR; } if ((err = mp_mul(&v3, &q, &tmp)) != MP_OKAY) { goto _ERR; } if ((err = mp_sub(&u3, &tmp, &t3)) != MP_OKAY) { goto _ERR; } /* (u1,u2,u3) = (v1,v2,v3) */ if ((err = mp_copy(&v1, &u1)) != MP_OKAY) { goto _ERR; } if ((err = mp_copy(&v2, &u2)) != MP_OKAY) { goto _ERR; } if ((err = mp_copy(&v3, &u3)) != MP_OKAY) { goto _ERR; } /* (v1,v2,v3) = (t1,t2,t3) */ if ((err = mp_copy(&t1, &v1)) != MP_OKAY) { goto _ERR; } if ((err = mp_copy(&t2, &v2)) != MP_OKAY) { goto _ERR; } if ((err = mp_copy(&t3, &v3)) != MP_OKAY) { goto _ERR; } } /* make sure U3 >= 0 */ if (u3.sign == MP_NEG) { mp_neg(&u1, &u1); mp_neg(&u2, &u2); mp_neg(&u3, &u3); } /* copy result out */ if (U1 != NULL) { mp_exch(U1, &u1); } if (U2 != NULL) { mp_exch(U2, &u2); } if (U3 != NULL) { mp_exch(U3, &u3); } err = MP_OKAY; _ERR: mp_clear_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_exteuclid.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_fread.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | #include <tommath.h> #ifdef BN_MP_FREAD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* read a bigint from a file stream in ASCII */ int mp_fread(mp_int *a, int radix, FILE *stream) { int err, ch, neg, y; /* clear a */ mp_zero(a); /* if first digit is - then set negative */ ch = fgetc(stream); if (ch == '-') { neg = MP_NEG; ch = fgetc(stream); } else { neg = MP_ZPOS; } for (;;) { /* find y in the radix map */ for (y = 0; y < radix; y++) { if (mp_s_rmap[y] == ch) { break; } } if (y == radix) { break; } /* shift up and add */ if ((err = mp_mul_d(a, radix, a)) != MP_OKAY) { return err; } if ((err = mp_add_d(a, y, a)) != MP_OKAY) { return err; } ch = fgetc(stream); } if (mp_cmp_d(a, 0) != MP_EQ) { a->sign = neg; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_fread.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_fwrite.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | #include <tommath.h> #ifdef BN_MP_FWRITE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ int mp_fwrite(mp_int *a, int radix, FILE *stream) { char *buf; int err, len, x; if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) { return err; } buf = OPT_CAST(char) XMALLOC (len); if (buf == NULL) { return MP_MEM; } if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) { XFREE (buf); return err; } for (x = 0; x < len; x++) { if (fputc(buf[x], stream) == EOF) { XFREE (buf); return MP_VAL; } } XFREE (buf); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_fwrite.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_gcd.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 | #include <tommath.h> #ifdef BN_MP_GCD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Greatest Common Divisor using the binary method */ int mp_gcd (mp_int * a, mp_int * b, mp_int * c) { mp_int u, v; int k, u_lsb, v_lsb, res; /* either zero than gcd is the largest */ if (mp_iszero (a) == 1 && mp_iszero (b) == 0) { return mp_abs (b, c); } if (mp_iszero (a) == 0 && mp_iszero (b) == 1) { return mp_abs (a, c); } /* optimized. At this point if a == 0 then * b must equal zero too */ if (mp_iszero (a) == 1) { mp_zero(c); return MP_OKAY; } /* get copies of a and b we can modify */ if ((res = mp_init_copy (&u, a)) != MP_OKAY) { return res; } if ((res = mp_init_copy (&v, b)) != MP_OKAY) { goto LBL_U; } /* must be positive for the remainder of the algorithm */ u.sign = v.sign = MP_ZPOS; /* B1. Find the common power of two for u and v */ u_lsb = mp_cnt_lsb(&u); v_lsb = mp_cnt_lsb(&v); k = MIN(u_lsb, v_lsb); if (k > 0) { /* divide the power of two out */ if ((res = mp_div_2d(&u, k, &u, NULL)) != MP_OKAY) { goto LBL_V; } if ((res = mp_div_2d(&v, k, &v, NULL)) != MP_OKAY) { goto LBL_V; } } /* divide any remaining factors of two out */ if (u_lsb != k) { if ((res = mp_div_2d(&u, u_lsb - k, &u, NULL)) != MP_OKAY) { goto LBL_V; } } if (v_lsb != k) { if ((res = mp_div_2d(&v, v_lsb - k, &v, NULL)) != MP_OKAY) { goto LBL_V; } } while (mp_iszero(&v) == 0) { /* make sure v is the largest */ if (mp_cmp_mag(&u, &v) == MP_GT) { /* swap u and v to make sure v is >= u */ mp_exch(&u, &v); } /* subtract smallest from largest */ if ((res = s_mp_sub(&v, &u, &v)) != MP_OKAY) { goto LBL_V; } /* Divide out all factors of two */ if ((res = mp_div_2d(&v, mp_cnt_lsb(&v), &v, NULL)) != MP_OKAY) { goto LBL_V; } } /* multiply by 2**k which we divided out at the beginning */ if ((res = mp_mul_2d (&u, k, c)) != MP_OKAY) { goto LBL_V; } c->sign = MP_ZPOS; res = MP_OKAY; LBL_V:mp_clear (&u); LBL_U:mp_clear (&v); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_gcd.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_get_int.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | #include <tommath.h> #ifdef BN_MP_GET_INT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* get the lower 32-bits of an mp_int */ unsigned long mp_get_int(mp_int * a) { int i; unsigned long res; if (a->used == 0) { return 0; } /* get number of digits of the lsb we have to read */ i = MIN(a->used,(int)((sizeof(unsigned long)*CHAR_BIT+DIGIT_BIT-1)/DIGIT_BIT))-1; /* get most significant digit of result */ res = DIGIT(a,i); while (--i >= 0) { res = (res << DIGIT_BIT) | DIGIT(a,i); } /* force result to 32-bits always so it is consistent on non 32-bit platforms */ return res & 0xFFFFFFFFUL; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_get_int.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_grow.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | #include <tommath.h> #ifdef BN_MP_GROW_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* grow as required */ int mp_grow (mp_int * a, int size) { int i; mp_digit *tmp; /* if the alloc size is smaller alloc more ram */ if (a->alloc < size) { /* ensure there are always at least MP_PREC digits extra on top */ size += (MP_PREC * 2) - (size % MP_PREC); /* reallocate the array a->dp * * We store the return in a temporary variable * in case the operation failed we don't want * to overwrite the dp member of a. */ tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * size); if (tmp == NULL) { /* reallocation failed but "a" is still valid [can be freed] */ return MP_MEM; } /* reallocation succeeded so set a->dp */ a->dp = tmp; /* zero excess digits */ i = a->alloc; a->alloc = size; for (; i < a->alloc; i++) { a->dp[i] = 0; } } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_grow.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_init.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | #include <tommath.h> #ifdef BN_MP_INIT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* init a new mp_int */ int mp_init (mp_int * a) { int i; /* allocate memory required and clear it */ a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * MP_PREC); if (a->dp == NULL) { return MP_MEM; } /* set the digits to zero */ for (i = 0; i < MP_PREC; i++) { a->dp[i] = 0; } /* set the used to zero, allocated digits to the default precision * and sign to positive */ a->used = 0; a->alloc = MP_PREC; a->sign = MP_ZPOS; return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_init_copy.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | #include <tommath.h> #ifdef BN_MP_INIT_COPY_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* creates "a" then copies b into it */ int mp_init_copy (mp_int * a, mp_int * b) { int res; if ((res = mp_init (a)) != MP_OKAY) { return res; } return mp_copy (b, a); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_copy.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_init_multi.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | #include <tommath.h> #ifdef BN_MP_INIT_MULTI_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ #include <stdarg.h> int mp_init_multi(mp_int *mp, ...) { mp_err res = MP_OKAY; /* Assume ok until proven otherwise */ int n = 0; /* Number of ok inits */ mp_int* cur_arg = mp; va_list args; va_start(args, mp); /* init args to next argument from caller */ while (cur_arg != NULL) { if (mp_init(cur_arg) != MP_OKAY) { /* Oops - error! Back-track and mp_clear what we already succeeded in init-ing, then return error. */ va_list clean_args; /* end the current list */ va_end(args); /* now start cleaning up */ cur_arg = mp; va_start(clean_args, mp); while (n--) { mp_clear(cur_arg); cur_arg = va_arg(clean_args, mp_int*); } va_end(clean_args); res = MP_MEM; break; } n++; cur_arg = va_arg(args, mp_int*); } va_end(args); return res; /* Assumed ok, if error flagged above. */ } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_multi.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_init_set.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | #include <tommath.h> #ifdef BN_MP_INIT_SET_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* initialize and set a digit */ int mp_init_set (mp_int * a, mp_digit b) { int err; if ((err = mp_init(a)) != MP_OKAY) { return err; } mp_set(a, b); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_set.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_init_set_int.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | #include <tommath.h> #ifdef BN_MP_INIT_SET_INT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* initialize and set a digit */ int mp_init_set_int (mp_int * a, unsigned long b) { int err; if ((err = mp_init(a)) != MP_OKAY) { return err; } return mp_set_int(a, b); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_set_int.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_init_size.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | #include <tommath.h> #ifdef BN_MP_INIT_SIZE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* init an mp_init for a given size */ int mp_init_size (mp_int * a, int size) { int x; /* pad size so there are always extra digits */ size += (MP_PREC * 2) - (size % MP_PREC); /* alloc mem */ a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * size); if (a->dp == NULL) { return MP_MEM; } /* set the members */ a->used = 0; a->alloc = size; a->sign = MP_ZPOS; /* zero the digits */ for (x = 0; x < size; x++) { a->dp[x] = 0; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_init_size.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_invmod.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | #include <tommath.h> #ifdef BN_MP_INVMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* hac 14.61, pp608 */ int mp_invmod (mp_int * a, mp_int * b, mp_int * c) { /* b cannot be negative */ if (b->sign == MP_NEG || mp_iszero(b) == 1) { return MP_VAL; } #ifdef BN_FAST_MP_INVMOD_C /* if the modulus is odd we can use a faster routine instead */ if (mp_isodd (b) == 1) { return fast_mp_invmod (a, b, c); } #endif #ifdef BN_MP_INVMOD_SLOW_C return mp_invmod_slow(a, b, c); #endif return MP_VAL; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_invmod.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_invmod_slow.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 | #include <tommath.h> #ifdef BN_MP_INVMOD_SLOW_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* hac 14.61, pp608 */ int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c) { mp_int x, y, u, v, A, B, C, D; int res; /* b cannot be negative */ if (b->sign == MP_NEG || mp_iszero(b) == 1) { return MP_VAL; } /* init temps */ if ((res = mp_init_multi(&x, &y, &u, &v, &A, &B, &C, &D, NULL)) != MP_OKAY) { return res; } /* x = a, y = b */ if ((res = mp_mod(a, b, &x)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_copy (b, &y)) != MP_OKAY) { goto LBL_ERR; } /* 2. [modified] if x,y are both even then return an error! */ if (mp_iseven (&x) == 1 && mp_iseven (&y) == 1) { res = MP_VAL; goto LBL_ERR; } /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ if ((res = mp_copy (&x, &u)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_copy (&y, &v)) != MP_OKAY) { goto LBL_ERR; } mp_set (&A, 1); mp_set (&D, 1); top: /* 4. while u is even do */ while (mp_iseven (&u) == 1) { /* 4.1 u = u/2 */ if ((res = mp_div_2 (&u, &u)) != MP_OKAY) { goto LBL_ERR; } /* 4.2 if A or B is odd then */ if (mp_isodd (&A) == 1 || mp_isodd (&B) == 1) { /* A = (A+y)/2, B = (B-x)/2 */ if ((res = mp_add (&A, &y, &A)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) { goto LBL_ERR; } } /* A = A/2, B = B/2 */ if ((res = mp_div_2 (&A, &A)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_div_2 (&B, &B)) != MP_OKAY) { goto LBL_ERR; } } /* 5. while v is even do */ while (mp_iseven (&v) == 1) { /* 5.1 v = v/2 */ if ((res = mp_div_2 (&v, &v)) != MP_OKAY) { goto LBL_ERR; } /* 5.2 if C or D is odd then */ if (mp_isodd (&C) == 1 || mp_isodd (&D) == 1) { /* C = (C+y)/2, D = (D-x)/2 */ if ((res = mp_add (&C, &y, &C)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) { goto LBL_ERR; } } /* C = C/2, D = D/2 */ if ((res = mp_div_2 (&C, &C)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_div_2 (&D, &D)) != MP_OKAY) { goto LBL_ERR; } } /* 6. if u >= v then */ if (mp_cmp (&u, &v) != MP_LT) { /* u = u - v, A = A - C, B = B - D */ if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&A, &C, &A)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) { goto LBL_ERR; } } else { /* v - v - u, C = C - A, D = D - B */ if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&C, &A, &C)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) { goto LBL_ERR; } } /* if not zero goto step 4 */ if (mp_iszero (&u) == 0) goto top; /* now a = C, b = D, gcd == g*v */ /* if v != 1 then there is no inverse */ if (mp_cmp_d (&v, 1) != MP_EQ) { res = MP_VAL; goto LBL_ERR; } /* if its too low */ while (mp_cmp_d(&C, 0) == MP_LT) { if ((res = mp_add(&C, b, &C)) != MP_OKAY) { goto LBL_ERR; } } /* too big */ while (mp_cmp_mag(&C, b) != MP_LT) { if ((res = mp_sub(&C, b, &C)) != MP_OKAY) { goto LBL_ERR; } } /* C is now the inverse */ mp_exch (&C, c); res = MP_OKAY; LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &A, &B, &C, &D, NULL); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_invmod_slow.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_is_square.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | #include <tommath.h> #ifdef BN_MP_IS_SQUARE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Check if remainders are possible squares - fast exclude non-squares */ static const char rem_128[128] = { 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1 }; static const char rem_105[105] = { 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1 }; /* Store non-zero to ret if arg is square, and zero if not */ int mp_is_square(mp_int *arg,int *ret) { int res; mp_digit c; mp_int t; unsigned long r; /* Default to Non-square :) */ *ret = MP_NO; if (arg->sign == MP_NEG) { return MP_VAL; } /* digits used? (TSD) */ if (arg->used == 0) { return MP_OKAY; } /* First check mod 128 (suppose that DIGIT_BIT is at least 7) */ if (rem_128[127 & DIGIT(arg,0)] == 1) { return MP_OKAY; } /* Next check mod 105 (3*5*7) */ if ((res = mp_mod_d(arg,105,&c)) != MP_OKAY) { return res; } if (rem_105[c] == 1) { return MP_OKAY; } if ((res = mp_init_set_int(&t,11L*13L*17L*19L*23L*29L*31L)) != MP_OKAY) { return res; } if ((res = mp_mod(arg,&t,&t)) != MP_OKAY) { goto ERR; } r = mp_get_int(&t); /* Check for other prime modules, note it's not an ERROR but we must * free "t" so the easiest way is to goto ERR. We know that res * is already equal to MP_OKAY from the mp_mod call */ if ( (1L<<(r%11)) & 0x5C4L ) goto ERR; if ( (1L<<(r%13)) & 0x9E4L ) goto ERR; if ( (1L<<(r%17)) & 0x5CE8L ) goto ERR; if ( (1L<<(r%19)) & 0x4F50CL ) goto ERR; if ( (1L<<(r%23)) & 0x7ACCA0L ) goto ERR; if ( (1L<<(r%29)) & 0xC2EDD0CL ) goto ERR; if ( (1L<<(r%31)) & 0x6DE2B848L ) goto ERR; /* Final check - is sqr(sqrt(arg)) == arg ? */ if ((res = mp_sqrt(arg,&t)) != MP_OKAY) { goto ERR; } if ((res = mp_sqr(&t,&t)) != MP_OKAY) { goto ERR; } *ret = (mp_cmp_mag(&t,arg) == MP_EQ) ? MP_YES : MP_NO; ERR:mp_clear(&t); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_is_square.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_jacobi.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | #include <tommath.h> #ifdef BN_MP_JACOBI_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes the jacobi c = (a | n) (or Legendre if n is prime) * HAC pp. 73 Algorithm 2.149 */ int mp_jacobi (mp_int * a, mp_int * p, int *c) { mp_int a1, p1; int k, s, r, res; mp_digit residue; /* if p <= 0 return MP_VAL */ if (mp_cmp_d(p, 0) != MP_GT) { return MP_VAL; } /* step 1. if a == 0, return 0 */ if (mp_iszero (a) == 1) { *c = 0; return MP_OKAY; } /* step 2. if a == 1, return 1 */ if (mp_cmp_d (a, 1) == MP_EQ) { *c = 1; return MP_OKAY; } /* default */ s = 0; /* step 3. write a = a1 * 2**k */ if ((res = mp_init_copy (&a1, a)) != MP_OKAY) { return res; } if ((res = mp_init (&p1)) != MP_OKAY) { goto LBL_A1; } /* divide out larger power of two */ k = mp_cnt_lsb(&a1); if ((res = mp_div_2d(&a1, k, &a1, NULL)) != MP_OKAY) { goto LBL_P1; } /* step 4. if e is even set s=1 */ if ((k & 1) == 0) { s = 1; } else { /* else set s=1 if p = 1/7 (mod 8) or s=-1 if p = 3/5 (mod 8) */ residue = p->dp[0] & 7; if (residue == 1 || residue == 7) { s = 1; } else if (residue == 3 || residue == 5) { s = -1; } } /* step 5. if p == 3 (mod 4) *and* a1 == 3 (mod 4) then s = -s */ if ( ((p->dp[0] & 3) == 3) && ((a1.dp[0] & 3) == 3)) { s = -s; } /* if a1 == 1 we're done */ if (mp_cmp_d (&a1, 1) == MP_EQ) { *c = s; } else { /* n1 = n mod a1 */ if ((res = mp_mod (p, &a1, &p1)) != MP_OKAY) { goto LBL_P1; } if ((res = mp_jacobi (&p1, &a1, &r)) != MP_OKAY) { goto LBL_P1; } *c = s * r; } /* done */ res = MP_OKAY; LBL_P1:mp_clear (&p1); LBL_A1:mp_clear (&a1); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_jacobi.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_karatsuba_mul.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 | #include <tommath.h> #ifdef BN_MP_KARATSUBA_MUL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* c = |a| * |b| using Karatsuba Multiplication using * three half size multiplications * * Let B represent the radix [e.g. 2**DIGIT_BIT] and * let n represent half of the number of digits in * the min(a,b) * * a = a1 * B**n + a0 * b = b1 * B**n + b0 * * Then, a * b => a1b1 * B**2n + ((a1 + a0)(b1 + b0) - (a0b0 + a1b1)) * B + a0b0 * * Note that a1b1 and a0b0 are used twice and only need to be * computed once. So in total three half size (half # of * digit) multiplications are performed, a0b0, a1b1 and * (a1+b1)(a0+b0) * * Note that a multiplication of half the digits requires * 1/4th the number of single precision multiplications so in * total after one call 25% of the single precision multiplications * are saved. Note also that the call to mp_mul can end up back * in this function if the a0, a1, b0, or b1 are above the threshold. * This is known as divide-and-conquer and leads to the famous * O(N**lg(3)) or O(N**1.584) work which is asymptopically lower than * the standard O(N**2) that the baseline/comba methods use. * Generally though the overhead of this method doesn't pay off * until a certain size (N ~ 80) is reached. */ int mp_karatsuba_mul (mp_int * a, mp_int * b, mp_int * c) { mp_int x0, x1, y0, y1, t1, x0y0, x1y1; int B, err; /* default the return code to an error */ err = MP_MEM; /* min # of digits */ B = MIN (a->used, b->used); /* now divide in two */ B = B >> 1; /* init copy all the temps */ if (mp_init_size (&x0, B) != MP_OKAY) goto ERR; if (mp_init_size (&x1, a->used - B) != MP_OKAY) goto X0; if (mp_init_size (&y0, B) != MP_OKAY) goto X1; if (mp_init_size (&y1, b->used - B) != MP_OKAY) goto Y0; /* init temps */ if (mp_init_size (&t1, B * 2) != MP_OKAY) goto Y1; if (mp_init_size (&x0y0, B * 2) != MP_OKAY) goto T1; if (mp_init_size (&x1y1, B * 2) != MP_OKAY) goto X0Y0; /* now shift the digits */ x0.used = y0.used = B; x1.used = a->used - B; y1.used = b->used - B; { register int x; register mp_digit *tmpa, *tmpb, *tmpx, *tmpy; /* we copy the digits directly instead of using higher level functions * since we also need to shift the digits */ tmpa = a->dp; tmpb = b->dp; tmpx = x0.dp; tmpy = y0.dp; for (x = 0; x < B; x++) { *tmpx++ = *tmpa++; *tmpy++ = *tmpb++; } tmpx = x1.dp; for (x = B; x < a->used; x++) { *tmpx++ = *tmpa++; } tmpy = y1.dp; for (x = B; x < b->used; x++) { *tmpy++ = *tmpb++; } } /* only need to clamp the lower words since by definition the * upper words x1/y1 must have a known number of digits */ mp_clamp (&x0); mp_clamp (&y0); /* now calc the products x0y0 and x1y1 */ /* after this x0 is no longer required, free temp [x0==t2]! */ if (mp_mul (&x0, &y0, &x0y0) != MP_OKAY) goto X1Y1; /* x0y0 = x0*y0 */ if (mp_mul (&x1, &y1, &x1y1) != MP_OKAY) goto X1Y1; /* x1y1 = x1*y1 */ /* now calc x1+x0 and y1+y0 */ if (s_mp_add (&x1, &x0, &t1) != MP_OKAY) goto X1Y1; /* t1 = x1 - x0 */ if (s_mp_add (&y1, &y0, &x0) != MP_OKAY) goto X1Y1; /* t2 = y1 - y0 */ if (mp_mul (&t1, &x0, &t1) != MP_OKAY) goto X1Y1; /* t1 = (x1 + x0) * (y1 + y0) */ /* add x0y0 */ if (mp_add (&x0y0, &x1y1, &x0) != MP_OKAY) goto X1Y1; /* t2 = x0y0 + x1y1 */ if (s_mp_sub (&t1, &x0, &t1) != MP_OKAY) goto X1Y1; /* t1 = (x1+x0)*(y1+y0) - (x1y1 + x0y0) */ /* shift by B */ if (mp_lshd (&t1, B) != MP_OKAY) goto X1Y1; /* t1 = (x0y0 + x1y1 - (x1-x0)*(y1-y0))<<B */ if (mp_lshd (&x1y1, B * 2) != MP_OKAY) goto X1Y1; /* x1y1 = x1y1 << 2*B */ if (mp_add (&x0y0, &t1, &t1) != MP_OKAY) goto X1Y1; /* t1 = x0y0 + t1 */ if (mp_add (&t1, &x1y1, c) != MP_OKAY) goto X1Y1; /* t1 = x0y0 + t1 + x1y1 */ /* Algorithm succeeded set the return code to MP_OKAY */ err = MP_OKAY; X1Y1:mp_clear (&x1y1); X0Y0:mp_clear (&x0y0); T1:mp_clear (&t1); Y1:mp_clear (&y1); Y0:mp_clear (&y0); X1:mp_clear (&x1); X0:mp_clear (&x0); ERR: return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_karatsuba_mul.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_karatsuba_sqr.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 | #include <tommath.h> #ifdef BN_MP_KARATSUBA_SQR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Karatsuba squaring, computes b = a*a using three * half size squarings * * See comments of karatsuba_mul for details. It * is essentially the same algorithm but merely * tuned to perform recursive squarings. */ int mp_karatsuba_sqr (mp_int * a, mp_int * b) { mp_int x0, x1, t1, t2, x0x0, x1x1; int B, err; err = MP_MEM; /* min # of digits */ B = a->used; /* now divide in two */ B = B >> 1; /* init copy all the temps */ if (mp_init_size (&x0, B) != MP_OKAY) goto ERR; if (mp_init_size (&x1, a->used - B) != MP_OKAY) goto X0; /* init temps */ if (mp_init_size (&t1, a->used * 2) != MP_OKAY) goto X1; if (mp_init_size (&t2, a->used * 2) != MP_OKAY) goto T1; if (mp_init_size (&x0x0, B * 2) != MP_OKAY) goto T2; if (mp_init_size (&x1x1, (a->used - B) * 2) != MP_OKAY) goto X0X0; { register int x; register mp_digit *dst, *src; src = a->dp; /* now shift the digits */ dst = x0.dp; for (x = 0; x < B; x++) { *dst++ = *src++; } dst = x1.dp; for (x = B; x < a->used; x++) { *dst++ = *src++; } } x0.used = B; x1.used = a->used - B; mp_clamp (&x0); /* now calc the products x0*x0 and x1*x1 */ if (mp_sqr (&x0, &x0x0) != MP_OKAY) goto X1X1; /* x0x0 = x0*x0 */ if (mp_sqr (&x1, &x1x1) != MP_OKAY) goto X1X1; /* x1x1 = x1*x1 */ /* now calc (x1+x0)**2 */ if (s_mp_add (&x1, &x0, &t1) != MP_OKAY) goto X1X1; /* t1 = x1 - x0 */ if (mp_sqr (&t1, &t1) != MP_OKAY) goto X1X1; /* t1 = (x1 - x0) * (x1 - x0) */ /* add x0y0 */ if (s_mp_add (&x0x0, &x1x1, &t2) != MP_OKAY) goto X1X1; /* t2 = x0x0 + x1x1 */ if (s_mp_sub (&t1, &t2, &t1) != MP_OKAY) goto X1X1; /* t1 = (x1+x0)**2 - (x0x0 + x1x1) */ /* shift by B */ if (mp_lshd (&t1, B) != MP_OKAY) goto X1X1; /* t1 = (x0x0 + x1x1 - (x1-x0)*(x1-x0))<<B */ if (mp_lshd (&x1x1, B * 2) != MP_OKAY) goto X1X1; /* x1x1 = x1x1 << 2*B */ if (mp_add (&x0x0, &t1, &t1) != MP_OKAY) goto X1X1; /* t1 = x0x0 + t1 */ if (mp_add (&t1, &x1x1, b) != MP_OKAY) goto X1X1; /* t1 = x0x0 + t1 + x1x1 */ err = MP_OKAY; X1X1:mp_clear (&x1x1); X0X0:mp_clear (&x0x0); T2:mp_clear (&t2); T1:mp_clear (&t1); X1:mp_clear (&x1); X0:mp_clear (&x0); ERR: return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_karatsuba_sqr.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_lcm.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | #include <tommath.h> #ifdef BN_MP_LCM_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes least common multiple as |a*b|/(a, b) */ int mp_lcm (mp_int * a, mp_int * b, mp_int * c) { int res; mp_int t1, t2; if ((res = mp_init_multi (&t1, &t2, NULL)) != MP_OKAY) { return res; } /* t1 = get the GCD of the two inputs */ if ((res = mp_gcd (a, b, &t1)) != MP_OKAY) { goto LBL_T; } /* divide the smallest by the GCD */ if (mp_cmp_mag(a, b) == MP_LT) { /* store quotient in t2 such that t2 * b is the LCM */ if ((res = mp_div(a, &t1, &t2, NULL)) != MP_OKAY) { goto LBL_T; } res = mp_mul(b, &t2, c); } else { /* store quotient in t2 such that t2 * a is the LCM */ if ((res = mp_div(b, &t1, &t2, NULL)) != MP_OKAY) { goto LBL_T; } res = mp_mul(a, &t2, c); } /* fix the sign to positive */ c->sign = MP_ZPOS; LBL_T: mp_clear_multi (&t1, &t2, NULL); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_lcm.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_lshd.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | #include <tommath.h> #ifdef BN_MP_LSHD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* shift left a certain amount of digits */ int mp_lshd (mp_int * a, int b) { int x, res; /* if its less than zero return */ if (b <= 0) { return MP_OKAY; } /* grow to fit the new digits */ if (a->alloc < a->used + b) { if ((res = mp_grow (a, a->used + b)) != MP_OKAY) { return res; } } { register mp_digit *top, *bottom; /* increment the used by the shift amount then copy upwards */ a->used += b; /* top */ top = a->dp + a->used - 1; /* base */ bottom = a->dp + a->used - 1 - b; /* much like mp_rshd this is implemented using a sliding window * except the window goes the otherway around. Copying from * the bottom to the top. see bn_mp_rshd.c for more info. */ for (x = a->used - 1; x >= b; x--) { *top-- = *bottom--; } /* zero the lower digits */ top = a->dp; for (x = 0; x < b; x++) { *top++ = 0; } } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_lshd.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_mod.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | #include <tommath.h> #ifdef BN_MP_MOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* c = a mod b, 0 <= c < b */ int mp_mod (mp_int * a, mp_int * b, mp_int * c) { mp_int t; int res; if ((res = mp_init (&t)) != MP_OKAY) { return res; } if ((res = mp_div (a, b, NULL, &t)) != MP_OKAY) { mp_clear (&t); return res; } if (t.sign != b->sign) { res = mp_add (b, &t, c); } else { res = MP_OKAY; mp_exch (&t, c); } mp_clear (&t); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mod.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_mod_2d.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | #include <tommath.h> #ifdef BN_MP_MOD_2D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* calc a value mod 2**b */ int mp_mod_2d (mp_int * a, int b, mp_int * c) { int x, res; /* if b is <= 0 then zero the int */ if (b <= 0) { mp_zero (c); return MP_OKAY; } /* if the modulus is larger than the value than return */ if (b >= (int) (a->used * DIGIT_BIT)) { res = mp_copy (a, c); return res; } /* copy */ if ((res = mp_copy (a, c)) != MP_OKAY) { return res; } /* zero digits above the last digit of the modulus */ for (x = (b / DIGIT_BIT) + ((b % DIGIT_BIT) == 0 ? 0 : 1); x < c->used; x++) { c->dp[x] = 0; } /* clear the digit that is not completely outside/inside the modulus */ c->dp[b / DIGIT_BIT] &= (mp_digit) ((((mp_digit) 1) << (((mp_digit) b) % DIGIT_BIT)) - ((mp_digit) 1)); mp_clamp (c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mod_2d.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_mod_d.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | #include <tommath.h> #ifdef BN_MP_MOD_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ int mp_mod_d (mp_int * a, mp_digit b, mp_digit * c) { return mp_div_d(a, b, NULL, c); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mod_d.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_montgomery_calc_normalization.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | #include <tommath.h> #ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* * shifts with subtractions when the result is greater than b. * * The method is slightly modified to shift B unconditionally upto just under * the leading bit of b. This saves alot of multiple precision shifting. */ int mp_montgomery_calc_normalization (mp_int * a, mp_int * b) { int x, bits, res; /* how many bits of last digit does b use */ bits = mp_count_bits (b) % DIGIT_BIT; if (b->used > 1) { if ((res = mp_2expt (a, (b->used - 1) * DIGIT_BIT + bits - 1)) != MP_OKAY) { return res; } } else { mp_set(a, 1); bits = 1; } /* now compute C = A * B mod b */ for (x = bits - 1; x < (int)DIGIT_BIT; x++) { if ((res = mp_mul_2 (a, a)) != MP_OKAY) { return res; } if (mp_cmp_mag (a, b) != MP_LT) { if ((res = s_mp_sub (a, b, a)) != MP_OKAY) { return res; } } } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_montgomery_calc_normalization.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_montgomery_reduce.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 | #include <tommath.h> #ifdef BN_MP_MONTGOMERY_REDUCE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes xR**-1 == x (mod N) via Montgomery Reduction */ int mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) { int ix, res, digs; mp_digit mu; /* can the fast reduction [comba] method be used? * * Note that unlike in mul you're safely allowed *less* * than the available columns [255 per default] since carries * are fixed up in the inner loop. */ digs = n->used * 2 + 1; if ((digs < MP_WARRAY) && n->used < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { return fast_mp_montgomery_reduce (x, n, rho); } /* grow the input as required */ if (x->alloc < digs) { if ((res = mp_grow (x, digs)) != MP_OKAY) { return res; } } x->used = digs; for (ix = 0; ix < n->used; ix++) { /* mu = ai * rho mod b * * The value of rho must be precalculated via * montgomery_setup() such that * it equals -1/n0 mod b this allows the * following inner loop to reduce the * input one digit at a time */ mu = (mp_digit) (((mp_word)x->dp[ix]) * ((mp_word)rho) & MP_MASK); /* a = a + mu * m * b**i */ { register int iy; register mp_digit *tmpn, *tmpx, u; register mp_word r; /* alias for digits of the modulus */ tmpn = n->dp; /* alias for the digits of x [the input] */ tmpx = x->dp + ix; /* set the carry to zero */ u = 0; /* Multiply and add in place */ for (iy = 0; iy < n->used; iy++) { /* compute product and sum */ r = ((mp_word)mu) * ((mp_word)*tmpn++) + ((mp_word) u) + ((mp_word) * tmpx); /* get carry */ u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); /* fix digit */ *tmpx++ = (mp_digit)(r & ((mp_word) MP_MASK)); } /* At this point the ix'th digit of x should be zero */ /* propagate carries upwards as required*/ while (u) { *tmpx += u; u = *tmpx >> DIGIT_BIT; *tmpx++ &= MP_MASK; } } } /* at this point the n.used'th least * significant digits of x are all zero * which means we can shift x to the * right by n.used digits and the * residue is unchanged. */ /* x = x/b**n.used */ mp_clamp(x); mp_rshd (x, n->used); /* if x >= n then x = x - n */ if (mp_cmp_mag (x, n) != MP_LT) { return s_mp_sub (x, n, x); } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_montgomery_reduce.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_montgomery_setup.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | #include <tommath.h> #ifdef BN_MP_MONTGOMERY_SETUP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* setups the montgomery reduction stuff */ int mp_montgomery_setup (mp_int * n, mp_digit * rho) { mp_digit x, b; /* fast inversion mod 2**k * * Based on the fact that * * XA = 1 (mod 2**n) => (X(2-XA)) A = 1 (mod 2**2n) * => 2*X*A - X*X*A*A = 1 * => 2*(1) - (1) = 1 */ b = n->dp[0]; if ((b & 1) == 0) { return MP_VAL; } x = (((b + 2) & 4) << 1) + b; /* here x*a==1 mod 2**4 */ x *= 2 - b * x; /* here x*a==1 mod 2**8 */ #if !defined(MP_8BIT) x *= 2 - b * x; /* here x*a==1 mod 2**16 */ #endif #if defined(MP_64BIT) || !(defined(MP_8BIT) || defined(MP_16BIT)) x *= 2 - b * x; /* here x*a==1 mod 2**32 */ #endif #ifdef MP_64BIT x *= 2 - b * x; /* here x*a==1 mod 2**64 */ #endif /* rho = -1/m mod b */ *rho = (((mp_word)1 << ((mp_word) DIGIT_BIT)) - x) & MP_MASK; return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_montgomery_setup.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_mul.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | #include <tommath.h> #ifdef BN_MP_MUL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* high level multiplication (handles sign) */ int mp_mul (mp_int * a, mp_int * b, mp_int * c) { int res, neg; neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; /* use Toom-Cook? */ #ifdef BN_MP_TOOM_MUL_C if (MIN (a->used, b->used) >= TOOM_MUL_CUTOFF) { res = mp_toom_mul(a, b, c); } else #endif #ifdef BN_MP_KARATSUBA_MUL_C /* use Karatsuba? */ if (MIN (a->used, b->used) >= KARATSUBA_MUL_CUTOFF) { res = mp_karatsuba_mul (a, b, c); } else #endif { /* can we use the fast multiplier? * * The fast multiplier can be used if the output will * have less than MP_WARRAY digits and the number of * digits won't affect carry propagation */ int digs = a->used + b->used + 1; #ifdef BN_FAST_S_MP_MUL_DIGS_C if ((digs < MP_WARRAY) && MIN(a->used, b->used) <= (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { res = fast_s_mp_mul_digs (a, b, c, digs); } else #endif #ifdef BN_S_MP_MUL_DIGS_C res = s_mp_mul (a, b, c); /* uses s_mp_mul_digs */ #else res = MP_VAL; #endif } c->sign = (c->used > 0) ? neg : MP_ZPOS; return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_mul_2.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 | #include <tommath.h> #ifdef BN_MP_MUL_2_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* b = a*2 */ int mp_mul_2(mp_int * a, mp_int * b) { int x, res, oldused; /* grow to accomodate result */ if (b->alloc < a->used + 1) { if ((res = mp_grow (b, a->used + 1)) != MP_OKAY) { return res; } } oldused = b->used; b->used = a->used; { register mp_digit r, rr, *tmpa, *tmpb; /* alias for source */ tmpa = a->dp; /* alias for dest */ tmpb = b->dp; /* carry */ r = 0; for (x = 0; x < a->used; x++) { /* get what will be the *next* carry bit from the * MSB of the current digit */ rr = *tmpa >> ((mp_digit)(DIGIT_BIT - 1)); /* now shift up this digit, add in the carry [from the previous] */ *tmpb++ = ((*tmpa++ << ((mp_digit)1)) | r) & MP_MASK; /* copy the carry that would be from the source * digit into the next iteration */ r = rr; } /* new leading digit? */ if (r != 0) { /* add a MSB which is always 1 at this point */ *tmpb = 1; ++(b->used); } /* now zero any excess digits on the destination * that we didn't write to */ tmpb = b->dp + b->used; for (x = b->used; x < oldused; x++) { *tmpb++ = 0; } } b->sign = a->sign; return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul_2.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_mul_2d.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | #include <tommath.h> #ifdef BN_MP_MUL_2D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* shift left by a certain bit count */ int mp_mul_2d (mp_int * a, int b, mp_int * c) { mp_digit d; int res; /* copy */ if (a != c) { if ((res = mp_copy (a, c)) != MP_OKAY) { return res; } } if (c->alloc < (int)(c->used + b/DIGIT_BIT + 1)) { if ((res = mp_grow (c, c->used + b / DIGIT_BIT + 1)) != MP_OKAY) { return res; } } /* shift by as many digits in the bit count */ if (b >= (int)DIGIT_BIT) { if ((res = mp_lshd (c, b / DIGIT_BIT)) != MP_OKAY) { return res; } } /* shift any bit count < DIGIT_BIT */ d = (mp_digit) (b % DIGIT_BIT); if (d != 0) { register mp_digit *tmpc, shift, mask, r, rr; register int x; /* bitmask for carries */ mask = (((mp_digit)1) << d) - 1; /* shift for msbs */ shift = DIGIT_BIT - d; /* alias */ tmpc = c->dp; /* carry */ r = 0; for (x = 0; x < c->used; x++) { /* get the higher bits of the current word */ rr = (*tmpc >> shift) & mask; /* shift the current word and OR in the carry */ *tmpc = ((*tmpc << d) | r) & MP_MASK; ++tmpc; /* set the carry to the carry bits of the current word */ r = rr; } /* set final carry */ if (r != 0) { c->dp[(c->used)++] = r; } } mp_clamp (c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul_2d.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_mul_d.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | #include <tommath.h> #ifdef BN_MP_MUL_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* multiply by a digit */ int mp_mul_d (mp_int * a, mp_digit b, mp_int * c) { mp_digit u, *tmpa, *tmpc; mp_word r; int ix, res, olduse; /* make sure c is big enough to hold a*b */ if (c->alloc < a->used + 1) { if ((res = mp_grow (c, a->used + 1)) != MP_OKAY) { return res; } } /* get the original destinations used count */ olduse = c->used; /* set the sign */ c->sign = a->sign; /* alias for a->dp [source] */ tmpa = a->dp; /* alias for c->dp [dest] */ tmpc = c->dp; /* zero carry */ u = 0; /* compute columns */ for (ix = 0; ix < a->used; ix++) { /* compute product and carry sum for this term */ r = ((mp_word) u) + ((mp_word)*tmpa++) * ((mp_word)b); /* mask off higher bits to get a single digit */ *tmpc++ = (mp_digit) (r & ((mp_word) MP_MASK)); /* send carry into next iteration */ u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); } /* store final carry [if any] and increment ix offset */ *tmpc++ = u; ++ix; /* now zero digits above the top */ while (ix++ < olduse) { *tmpc++ = 0; } /* set used count */ c->used = a->used + 1; mp_clamp(c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mul_d.c,v $ */ /* $Revision: 1.1.1.1.2.3 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_mulmod.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | #include <tommath.h> #ifdef BN_MP_MULMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* d = a * b (mod c) */ int mp_mulmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) { int res; mp_int t; if ((res = mp_init (&t)) != MP_OKAY) { return res; } if ((res = mp_mul (a, b, &t)) != MP_OKAY) { mp_clear (&t); return res; } res = mp_mod (&t, c, d); mp_clear (&t); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_mulmod.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_n_root.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | #include <tommath.h> #ifdef BN_MP_N_ROOT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* find the n'th root of an integer * * Result found such that (c)**b <= a and (c+1)**b > a * * This algorithm uses Newton's approximation * x[i+1] = x[i] - f(x[i])/f'(x[i]) * which will find the root in log(N) time where * each step involves a fair bit. This is not meant to * find huge roots [square and cube, etc]. */ int mp_n_root (mp_int * a, mp_digit b, mp_int * c) { mp_int t1, t2, t3; int res, neg; /* input must be positive if b is even */ if ((b & 1) == 0 && a->sign == MP_NEG) { return MP_VAL; } if ((res = mp_init (&t1)) != MP_OKAY) { return res; } if ((res = mp_init (&t2)) != MP_OKAY) { goto LBL_T1; } if ((res = mp_init (&t3)) != MP_OKAY) { goto LBL_T2; } /* if a is negative fudge the sign but keep track */ neg = a->sign; a->sign = MP_ZPOS; /* t2 = 2 */ mp_set (&t2, 2); do { /* t1 = t2 */ if ((res = mp_copy (&t2, &t1)) != MP_OKAY) { goto LBL_T3; } /* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */ /* t3 = t1**(b-1) */ if ((res = mp_expt_d (&t1, b - 1, &t3)) != MP_OKAY) { goto LBL_T3; } /* numerator */ /* t2 = t1**b */ if ((res = mp_mul (&t3, &t1, &t2)) != MP_OKAY) { goto LBL_T3; } /* t2 = t1**b - a */ if ((res = mp_sub (&t2, a, &t2)) != MP_OKAY) { goto LBL_T3; } /* denominator */ /* t3 = t1**(b-1) * b */ if ((res = mp_mul_d (&t3, b, &t3)) != MP_OKAY) { goto LBL_T3; } /* t3 = (t1**b - a)/(b * t1**(b-1)) */ if ((res = mp_div (&t2, &t3, &t3, NULL)) != MP_OKAY) { goto LBL_T3; } if ((res = mp_sub (&t1, &t3, &t2)) != MP_OKAY) { goto LBL_T3; } } while (mp_cmp (&t1, &t2) != MP_EQ); /* result can be off by a few so check */ for (;;) { if ((res = mp_expt_d (&t1, b, &t2)) != MP_OKAY) { goto LBL_T3; } if (mp_cmp (&t2, a) == MP_GT) { if ((res = mp_sub_d (&t1, 1, &t1)) != MP_OKAY) { goto LBL_T3; } } else { break; } } /* reset the sign of a first */ a->sign = neg; /* set the result */ mp_exch (&t1, c); /* set the sign of the result */ c->sign = neg; res = MP_OKAY; LBL_T3:mp_clear (&t3); LBL_T2:mp_clear (&t2); LBL_T1:mp_clear (&t1); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_n_root.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_neg.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | #include <tommath.h> #ifdef BN_MP_NEG_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* b = -a */ int mp_neg (mp_int * a, mp_int * b) { int res; if (a != b) { if ((res = mp_copy (a, b)) != MP_OKAY) { return res; } } if (mp_iszero(b) != MP_YES) { b->sign = (a->sign == MP_ZPOS) ? MP_NEG : MP_ZPOS; } else { b->sign = MP_ZPOS; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_neg.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_or.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | #include <tommath.h> #ifdef BN_MP_OR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* OR two ints together */ int mp_or (mp_int * a, mp_int * b, mp_int * c) { int res, ix, px; mp_int t, *x; if (a->used > b->used) { if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } px = b->used; x = b; } else { if ((res = mp_init_copy (&t, b)) != MP_OKAY) { return res; } px = a->used; x = a; } for (ix = 0; ix < px; ix++) { t.dp[ix] |= x->dp[ix]; } mp_clamp (&t); mp_exch (c, &t); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_or.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_prime_fermat.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | #include <tommath.h> #ifdef BN_MP_PRIME_FERMAT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* performs one Fermat test. * * If "a" were prime then b**a == b (mod a) since the order of * the multiplicative sub-group would be phi(a) = a-1. That means * it would be the same as b**(a mod (a-1)) == b**1 == b (mod a). * * Sets result to 1 if the congruence holds, or zero otherwise. */ int mp_prime_fermat (mp_int * a, mp_int * b, int *result) { mp_int t; int err; /* default to composite */ *result = MP_NO; /* ensure b > 1 */ if (mp_cmp_d(b, 1) != MP_GT) { return MP_VAL; } /* init t */ if ((err = mp_init (&t)) != MP_OKAY) { return err; } /* compute t = b**a mod a */ if ((err = mp_exptmod (b, a, a, &t)) != MP_OKAY) { goto LBL_T; } /* is it equal to b? */ if (mp_cmp (&t, b) == MP_EQ) { *result = MP_YES; } err = MP_OKAY; LBL_T:mp_clear (&t); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_fermat.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_prime_is_divisible.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | #include <tommath.h> #ifdef BN_MP_PRIME_IS_DIVISIBLE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines if an integers is divisible by one * of the first PRIME_SIZE primes or not * * sets result to 0 if not, 1 if yes */ int mp_prime_is_divisible (mp_int * a, int *result) { int err, ix; mp_digit res; /* default to not */ *result = MP_NO; for (ix = 0; ix < PRIME_SIZE; ix++) { /* what is a mod LBL_prime_tab[ix] */ if ((err = mp_mod_d (a, ltm_prime_tab[ix], &res)) != MP_OKAY) { return err; } /* is the residue zero? */ if (res == 0) { *result = MP_YES; return MP_OKAY; } } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_is_divisible.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_prime_is_prime.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | #include <tommath.h> #ifdef BN_MP_PRIME_IS_PRIME_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* performs a variable number of rounds of Miller-Rabin * * Probability of error after t rounds is no more than * * Sets result to 1 if probably prime, 0 otherwise */ int mp_prime_is_prime (mp_int * a, int t, int *result) { mp_int b; int ix, err, res; /* default to no */ *result = MP_NO; /* valid value of t? */ if (t <= 0 || t > PRIME_SIZE) { return MP_VAL; } /* is the input equal to one of the primes in the table? */ for (ix = 0; ix < PRIME_SIZE; ix++) { if (mp_cmp_d(a, ltm_prime_tab[ix]) == MP_EQ) { *result = 1; return MP_OKAY; } } /* first perform trial division */ if ((err = mp_prime_is_divisible (a, &res)) != MP_OKAY) { return err; } /* return if it was trivially divisible */ if (res == MP_YES) { return MP_OKAY; } /* now perform the miller-rabin rounds */ if ((err = mp_init (&b)) != MP_OKAY) { return err; } for (ix = 0; ix < t; ix++) { /* set the prime */ mp_set (&b, ltm_prime_tab[ix]); if ((err = mp_prime_miller_rabin (a, &b, &res)) != MP_OKAY) { goto LBL_B; } if (res == MP_NO) { goto LBL_B; } } /* passed the test */ *result = MP_YES; LBL_B:mp_clear (&b); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_is_prime.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_prime_miller_rabin.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | #include <tommath.h> #ifdef BN_MP_PRIME_MILLER_RABIN_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Miller-Rabin test of "a" to the base of "b" as described in * HAC pp. 139 Algorithm 4.24 * * Sets result to 0 if definitely composite or 1 if probably prime. * Randomly the chance of error is no more than 1/4 and often * very much lower. */ int mp_prime_miller_rabin (mp_int * a, mp_int * b, int *result) { mp_int n1, y, r; int s, j, err; /* default */ *result = MP_NO; /* ensure b > 1 */ if (mp_cmp_d(b, 1) != MP_GT) { return MP_VAL; } /* get n1 = a - 1 */ if ((err = mp_init_copy (&n1, a)) != MP_OKAY) { return err; } if ((err = mp_sub_d (&n1, 1, &n1)) != MP_OKAY) { goto LBL_N1; } /* set 2**s * r = n1 */ if ((err = mp_init_copy (&r, &n1)) != MP_OKAY) { goto LBL_N1; } /* count the number of least significant bits * which are zero */ s = mp_cnt_lsb(&r); /* now divide n - 1 by 2**s */ if ((err = mp_div_2d (&r, s, &r, NULL)) != MP_OKAY) { goto LBL_R; } /* compute y = b**r mod a */ if ((err = mp_init (&y)) != MP_OKAY) { goto LBL_R; } if ((err = mp_exptmod (b, &r, a, &y)) != MP_OKAY) { goto LBL_Y; } /* if y != 1 and y != n1 do */ if (mp_cmp_d (&y, 1) != MP_EQ && mp_cmp (&y, &n1) != MP_EQ) { j = 1; /* while j <= s-1 and y != n1 */ while ((j <= (s - 1)) && mp_cmp (&y, &n1) != MP_EQ) { if ((err = mp_sqrmod (&y, a, &y)) != MP_OKAY) { goto LBL_Y; } /* if y == 1 then composite */ if (mp_cmp_d (&y, 1) == MP_EQ) { goto LBL_Y; } ++j; } /* if y != n1 then composite */ if (mp_cmp (&y, &n1) != MP_EQ) { goto LBL_Y; } } /* probably prime now */ *result = MP_YES; LBL_Y:mp_clear (&y); LBL_R:mp_clear (&r); LBL_N1:mp_clear (&n1); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_miller_rabin.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_prime_next_prime.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 | #include <tommath.h> #ifdef BN_MP_PRIME_NEXT_PRIME_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* finds the next prime after the number "a" using "t" trials * of Miller-Rabin. * * bbs_style = 1 means the prime must be congruent to 3 mod 4 */ int mp_prime_next_prime(mp_int *a, int t, int bbs_style) { int err, res, x, y; mp_digit res_tab[PRIME_SIZE], step, kstep; mp_int b; /* ensure t is valid */ if (t <= 0 || t > PRIME_SIZE) { return MP_VAL; } /* force positive */ a->sign = MP_ZPOS; /* simple algo if a is less than the largest prime in the table */ if (mp_cmp_d(a, ltm_prime_tab[PRIME_SIZE-1]) == MP_LT) { /* find which prime it is bigger than */ for (x = PRIME_SIZE - 2; x >= 0; x--) { if (mp_cmp_d(a, ltm_prime_tab[x]) != MP_LT) { if (bbs_style == 1) { /* ok we found a prime smaller or * equal [so the next is larger] * * however, the prime must be * congruent to 3 mod 4 */ if ((ltm_prime_tab[x + 1] & 3) != 3) { /* scan upwards for a prime congruent to 3 mod 4 */ for (y = x + 1; y < PRIME_SIZE; y++) { if ((ltm_prime_tab[y] & 3) == 3) { mp_set(a, ltm_prime_tab[y]); return MP_OKAY; } } } } else { mp_set(a, ltm_prime_tab[x + 1]); return MP_OKAY; } } } /* at this point a maybe 1 */ if (mp_cmp_d(a, 1) == MP_EQ) { mp_set(a, 2); return MP_OKAY; } /* fall through to the sieve */ } /* generate a prime congruent to 3 mod 4 or 1/3 mod 4? */ if (bbs_style == 1) { kstep = 4; } else { kstep = 2; } /* at this point we will use a combination of a sieve and Miller-Rabin */ if (bbs_style == 1) { /* if a mod 4 != 3 subtract the correct value to make it so */ if ((a->dp[0] & 3) != 3) { if ((err = mp_sub_d(a, (a->dp[0] & 3) + 1, a)) != MP_OKAY) { return err; }; } } else { if (mp_iseven(a) == 1) { /* force odd */ if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) { return err; } } } /* generate the restable */ for (x = 1; x < PRIME_SIZE; x++) { if ((err = mp_mod_d(a, ltm_prime_tab[x], res_tab + x)) != MP_OKAY) { return err; } } /* init temp used for Miller-Rabin Testing */ if ((err = mp_init(&b)) != MP_OKAY) { return err; } for (;;) { /* skip to the next non-trivially divisible candidate */ step = 0; do { /* y == 1 if any residue was zero [e.g. cannot be prime] */ y = 0; /* increase step to next candidate */ step += kstep; /* compute the new residue without using division */ for (x = 1; x < PRIME_SIZE; x++) { /* add the step to each residue */ res_tab[x] += kstep; /* subtract the modulus [instead of using division] */ if (res_tab[x] >= ltm_prime_tab[x]) { res_tab[x] -= ltm_prime_tab[x]; } /* set flag if zero */ if (res_tab[x] == 0) { y = 1; } } } while (y == 1 && step < ((((mp_digit)1)<<DIGIT_BIT) - kstep)); /* add the step */ if ((err = mp_add_d(a, step, a)) != MP_OKAY) { goto LBL_ERR; } /* if didn't pass sieve and step == MAX then skip test */ if (y == 1 && step >= ((((mp_digit)1)<<DIGIT_BIT) - kstep)) { continue; } /* is this prime? */ for (x = 0; x < t; x++) { mp_set(&b, ltm_prime_tab[t]); if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) { goto LBL_ERR; } if (res == MP_NO) { break; } } if (res == MP_YES) { break; } } err = MP_OKAY; LBL_ERR: mp_clear(&b); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_next_prime.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_prime_rabin_miller_trials.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | #include <tommath.h> #ifdef BN_MP_PRIME_RABIN_MILLER_TRIALS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ static const struct { int k, t; } sizes[] = { { 128, 28 }, { 256, 16 }, { 384, 10 }, { 512, 7 }, { 640, 6 }, { 768, 5 }, { 896, 4 }, { 1024, 4 } }; /* returns # of RM trials required for a given bit size */ int mp_prime_rabin_miller_trials(int size) { int x; for (x = 0; x < (int)(sizeof(sizes)/(sizeof(sizes[0]))); x++) { if (sizes[x].k == size) { return sizes[x].t; } else if (sizes[x].k > size) { return (x == 0) ? sizes[0].t : sizes[x - 1].t; } } return sizes[x-1].t + 1; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_rabin_miller_trials.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_prime_random_ex.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 | #include <tommath.h> #ifdef BN_MP_PRIME_RANDOM_EX_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* makes a truly random prime of a given size (bits), * * Flags are as follows: * * LTM_PRIME_BBS - make prime congruent to 3 mod 4 * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero * LTM_PRIME_2MSB_ON - make the 2nd highest bit one * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself * so it can be NULL * */ /* This is possibly the mother of all prime generation functions, muahahahahaha! */ int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat) { unsigned char *tmp, maskAND, maskOR_msb, maskOR_lsb; int res, err, bsize, maskOR_msb_offset; /* sanity check the input */ if (size <= 1 || t <= 0) { return MP_VAL; } /* LTM_PRIME_SAFE implies LTM_PRIME_BBS */ if (flags & LTM_PRIME_SAFE) { flags |= LTM_PRIME_BBS; } /* calc the byte size */ bsize = (size>>3) + ((size&7)?1:0); /* we need a buffer of bsize bytes */ tmp = OPT_CAST(unsigned char) XMALLOC(bsize); if (tmp == NULL) { return MP_MEM; } /* calc the maskAND value for the MSbyte*/ maskAND = ((size&7) == 0) ? 0xFF : (0xFF >> (8 - (size & 7))); /* calc the maskOR_msb */ maskOR_msb = 0; maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0; if (flags & LTM_PRIME_2MSB_ON) { maskOR_msb |= 0x80 >> ((9 - size) & 7); } /* get the maskOR_lsb */ maskOR_lsb = 1; if (flags & LTM_PRIME_BBS) { maskOR_lsb |= 3; } do { /* read the bytes */ if (cb(tmp, bsize, dat) != bsize) { err = MP_VAL; goto error; } /* work over the MSbyte */ tmp[0] &= maskAND; tmp[0] |= 1 << ((size - 1) & 7); /* mix in the maskORs */ tmp[maskOR_msb_offset] |= maskOR_msb; tmp[bsize-1] |= maskOR_lsb; /* read it in */ if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY) { goto error; } /* is it prime? */ if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { goto error; } if (res == MP_NO) { continue; } if (flags & LTM_PRIME_SAFE) { /* see if (a-1)/2 is prime */ if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) { goto error; } if ((err = mp_div_2(a, a)) != MP_OKAY) { goto error; } /* is it prime? */ if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { goto error; } } } while (res == MP_NO); if (flags & LTM_PRIME_SAFE) { /* restore a to the original value */ if ((err = mp_mul_2(a, a)) != MP_OKAY) { goto error; } if ((err = mp_add_d(a, 1, a)) != MP_OKAY) { goto error; } } err = MP_OKAY; error: XFREE(tmp); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_prime_random_ex.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_radix_size.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | #include <tommath.h> #ifdef BN_MP_RADIX_SIZE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* returns size of ASCII reprensentation */ int mp_radix_size (mp_int * a, int radix, int *size) { int res, digs; mp_int t; mp_digit d; *size = 0; /* special case for binary */ if (radix == 2) { *size = mp_count_bits (a) + (a->sign == MP_NEG ? 1 : 0) + 1; return MP_OKAY; } /* make sure the radix is in range */ if (radix < 2 || radix > 64) { return MP_VAL; } if (mp_iszero(a) == MP_YES) { *size = 2; return MP_OKAY; } /* digs is the digit count */ digs = 0; /* if it's negative add one for the sign */ if (a->sign == MP_NEG) { ++digs; } /* init a copy of the input */ if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } /* force temp to positive */ t.sign = MP_ZPOS; /* fetch out all of the digits */ while (mp_iszero (&t) == MP_NO) { if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { mp_clear (&t); return res; } ++digs; } mp_clear (&t); /* * return digs + 1, the 1 is for the NULL byte that would be required. * mp_toradix_n requires a minimum of 3 bytes, so never report less than * that. */ if ( digs >= 2 ) { *size = digs + 1; } else { *size = 3; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_radix_size.c,v $ */ /* $Revision: 1.1.1.1.2.3 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_radix_smap.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 | #include <tommath.h> #ifdef BN_MP_RADIX_SMAP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* chars used in radix conversions */ const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_radix_smap.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_rand.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | #include <tommath.h> #ifdef BN_MP_RAND_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* makes a pseudo-random int of a given size */ int mp_rand (mp_int * a, int digits) { int res; mp_digit d; mp_zero (a); if (digits <= 0) { return MP_OKAY; } /* first place a random non-zero digit */ do { d = ((mp_digit) abs (rand ())) & MP_MASK; } while (d == 0); if ((res = mp_add_d (a, d, a)) != MP_OKAY) { return res; } while (--digits > 0) { if ((res = mp_lshd (a, 1)) != MP_OKAY) { return res; } if ((res = mp_add_d (a, ((mp_digit) abs (rand ())), a)) != MP_OKAY) { return res; } } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_rand.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_read_radix.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | #include <tommath.h> #ifdef BN_MP_READ_RADIX_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* read a string [ASCII] in a given radix */ int mp_read_radix (mp_int * a, const char *str, int radix) { int y, res, neg; char ch; /* make sure the radix is ok */ if (radix < 2 || radix > 64) { return MP_VAL; } /* if the leading digit is a * minus set the sign to negative. */ if (*str == '-') { ++str; neg = MP_NEG; } else { neg = MP_ZPOS; } /* set the integer to the default of zero */ mp_zero (a); /* process each digit of the string */ while (*str) { /* if the radix < 36 the conversion is case insensitive * this allows numbers like 1AB and 1ab to represent the same value * [e.g. in hex] */ ch = (char) ((radix < 36) ? toupper (*str) : *str); for (y = 0; y < 64; y++) { if (ch == mp_s_rmap[y]) { break; } } /* if the char was found in the map * and is less than the given radix add it * to the number, otherwise exit the loop. */ if (y < radix) { if ((res = mp_mul_d (a, (mp_digit) radix, a)) != MP_OKAY) { return res; } if ((res = mp_add_d (a, (mp_digit) y, a)) != MP_OKAY) { return res; } } else { break; } ++str; } /* if an illegal character was found, fail. */ if ( *str != '\0' ) { mp_zero( a ); return MP_VAL; } /* set the sign only if a != 0 */ if (mp_iszero(a) != 1) { a->sign = neg; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_read_radix.c,v $ */ /* $Revision: 1.1.1.1.2.3 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_read_signed_bin.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | #include <tommath.h> #ifdef BN_MP_READ_SIGNED_BIN_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* read signed bin, big endian, first byte is 0==positive or 1==negative */ int mp_read_signed_bin (mp_int * a, const unsigned char *b, int c) { int res; /* read magnitude */ if ((res = mp_read_unsigned_bin (a, b + 1, c - 1)) != MP_OKAY) { return res; } /* first byte is 0 for positive, non-zero for negative */ if (b[0] == 0) { a->sign = MP_ZPOS; } else { a->sign = MP_NEG; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_read_signed_bin.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_read_unsigned_bin.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | #include <tommath.h> #ifdef BN_MP_READ_UNSIGNED_BIN_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* reads a unsigned char array, assumes the msb is stored first [big endian] */ int mp_read_unsigned_bin (mp_int * a, const unsigned char *b, int c) { int res; /* make sure there are at least two digits */ if (a->alloc < 2) { if ((res = mp_grow(a, 2)) != MP_OKAY) { return res; } } /* zero the int */ mp_zero (a); /* read the bytes in */ while (c-- > 0) { if ((res = mp_mul_2d (a, 8, a)) != MP_OKAY) { return res; } #ifndef MP_8BIT a->dp[0] |= *b++; a->used += 1; #else a->dp[0] = (*b & MP_MASK); a->dp[1] |= ((*b++ >> 7U) & 1); a->used += 2; #endif } mp_clamp (a); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_read_unsigned_bin.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_reduce.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | #include <tommath.h> #ifdef BN_MP_REDUCE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* reduces x mod m, assumes 0 < x < m**2, mu is * precomputed via mp_reduce_setup. * From HAC pp.604 Algorithm 14.42 */ int mp_reduce (mp_int * x, mp_int * m, mp_int * mu) { mp_int q; int res, um = m->used; /* q = x */ if ((res = mp_init_copy (&q, x)) != MP_OKAY) { return res; } /* q1 = x / b**(k-1) */ mp_rshd (&q, um - 1); /* according to HAC this optimization is ok */ if (((unsigned long) um) > (((mp_digit)1) << (DIGIT_BIT - 1))) { if ((res = mp_mul (&q, mu, &q)) != MP_OKAY) { goto CLEANUP; } } else { #ifdef BN_S_MP_MUL_HIGH_DIGS_C if ((res = s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) { goto CLEANUP; } #elif defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C) if ((res = fast_s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) { goto CLEANUP; } #else { res = MP_VAL; goto CLEANUP; } #endif } /* q3 = q2 / b**(k+1) */ mp_rshd (&q, um + 1); /* x = x mod b**(k+1), quick (no division) */ if ((res = mp_mod_2d (x, DIGIT_BIT * (um + 1), x)) != MP_OKAY) { goto CLEANUP; } /* q = q * m mod b**(k+1), quick (no division) */ if ((res = s_mp_mul_digs (&q, m, &q, um + 1)) != MP_OKAY) { goto CLEANUP; } /* x = x - q */ if ((res = mp_sub (x, &q, x)) != MP_OKAY) { goto CLEANUP; } /* If x < 0, add b**(k+1) to it */ if (mp_cmp_d (x, 0) == MP_LT) { mp_set (&q, 1); if ((res = mp_lshd (&q, um + 1)) != MP_OKAY) goto CLEANUP; if ((res = mp_add (x, &q, x)) != MP_OKAY) goto CLEANUP; } /* Back off if it's too big */ while (mp_cmp (x, m) != MP_LT) { if ((res = s_mp_sub (x, m, x)) != MP_OKAY) { goto CLEANUP; } } CLEANUP: mp_clear (&q); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_reduce_2k.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | #include <tommath.h> #ifdef BN_MP_REDUCE_2K_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* reduces a modulo n where n is of the form 2**p - d */ int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d) { mp_int q; int p, res; if ((res = mp_init(&q)) != MP_OKAY) { return res; } p = mp_count_bits(n); top: /* q = a/2**p, a = a mod 2**p */ if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { goto ERR; } if (d != 1) { /* q = q * d */ if ((res = mp_mul_d(&q, d, &q)) != MP_OKAY) { goto ERR; } } /* a = a + q */ if ((res = s_mp_add(a, &q, a)) != MP_OKAY) { goto ERR; } if (mp_cmp_mag(a, n) != MP_LT) { s_mp_sub(a, n, a); goto top; } ERR: mp_clear(&q); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_reduce_2k_l.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | #include <tommath.h> #ifdef BN_MP_REDUCE_2K_L_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* reduces a modulo n where n is of the form 2**p - d This differs from reduce_2k since "d" can be larger than a single digit. */ int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d) { mp_int q; int p, res; if ((res = mp_init(&q)) != MP_OKAY) { return res; } p = mp_count_bits(n); top: /* q = a/2**p, a = a mod 2**p */ if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { goto ERR; } /* q = q * d */ if ((res = mp_mul(&q, d, &q)) != MP_OKAY) { goto ERR; } /* a = a + q */ if ((res = s_mp_add(a, &q, a)) != MP_OKAY) { goto ERR; } if (mp_cmp_mag(a, n) != MP_LT) { s_mp_sub(a, n, a); goto top; } ERR: mp_clear(&q); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k_l.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_reduce_2k_setup.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | #include <tommath.h> #ifdef BN_MP_REDUCE_2K_SETUP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines the setup value */ int mp_reduce_2k_setup(mp_int *a, mp_digit *d) { int res, p; mp_int tmp; if ((res = mp_init(&tmp)) != MP_OKAY) { return res; } p = mp_count_bits(a); if ((res = mp_2expt(&tmp, p)) != MP_OKAY) { mp_clear(&tmp); return res; } if ((res = s_mp_sub(&tmp, a, &tmp)) != MP_OKAY) { mp_clear(&tmp); return res; } *d = tmp.dp[0]; mp_clear(&tmp); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k_setup.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_reduce_2k_setup_l.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | #include <tommath.h> #ifdef BN_MP_REDUCE_2K_SETUP_L_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines the setup value */ int mp_reduce_2k_setup_l(mp_int *a, mp_int *d) { int res; mp_int tmp; if ((res = mp_init(&tmp)) != MP_OKAY) { return res; } if ((res = mp_2expt(&tmp, mp_count_bits(a))) != MP_OKAY) { goto ERR; } if ((res = s_mp_sub(&tmp, a, d)) != MP_OKAY) { goto ERR; } ERR: mp_clear(&tmp); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_2k_setup_l.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_reduce_is_2k.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | #include <tommath.h> #ifdef BN_MP_REDUCE_IS_2K_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines if mp_reduce_2k can be used */ int mp_reduce_is_2k(mp_int *a) { int ix, iy, iw; mp_digit iz; if (a->used == 0) { return MP_NO; } else if (a->used == 1) { return MP_YES; } else if (a->used > 1) { iy = mp_count_bits(a); iz = 1; iw = 1; /* Test every bit from the second digit up, must be 1 */ for (ix = DIGIT_BIT; ix < iy; ix++) { if ((a->dp[iw] & iz) == 0) { return MP_NO; } iz <<= 1; if (iz > (mp_digit)MP_MASK) { ++iw; iz = 1; } } } return MP_YES; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_is_2k.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_reduce_is_2k_l.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | #include <tommath.h> #ifdef BN_MP_REDUCE_IS_2K_L_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines if reduce_2k_l can be used */ int mp_reduce_is_2k_l(mp_int *a) { int ix, iy; if (a->used == 0) { return MP_NO; } else if (a->used == 1) { return MP_YES; } else if (a->used > 1) { /* if more than half of the digits are -1 we're sold */ for (iy = ix = 0; ix < a->used; ix++) { if (a->dp[ix] == MP_MASK) { ++iy; } } return (iy >= (a->used/2)) ? MP_YES : MP_NO; } return MP_NO; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_is_2k_l.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_reduce_setup.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | #include <tommath.h> #ifdef BN_MP_REDUCE_SETUP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* pre-calculate the value required for Barrett reduction * For a given modulus "b" it calulates the value required in "a" */ int mp_reduce_setup (mp_int * a, mp_int * b) { int res; if ((res = mp_2expt (a, b->used * 2 * DIGIT_BIT)) != MP_OKAY) { return res; } return mp_div (a, b, a, NULL); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_reduce_setup.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_rshd.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | #include <tommath.h> #ifdef BN_MP_RSHD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* shift right a certain amount of digits */ void mp_rshd (mp_int * a, int b) { int x; /* if b <= 0 then ignore it */ if (b <= 0) { return; } /* if b > used then simply zero it and return */ if (a->used <= b) { mp_zero (a); return; } { register mp_digit *bottom, *top; /* shift the digits down */ /* bottom */ bottom = a->dp; /* top [offset into digits] */ top = a->dp + b; /* this is implemented as a sliding window where * the window is b-digits long and digits from * the top of the window are copied to the bottom * * e.g. b-2 | b-1 | b0 | b1 | b2 | ... | bb | ----> /\ | ----> \-------------------/ ----> */ for (x = 0; x < (a->used - b); x++) { *bottom++ = *top++; } /* zero the top digits */ for (; x < a->used; x++) { *bottom++ = 0; } } /* remove excess digits */ a->used -= b; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_rshd.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_set.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | #include <tommath.h> #ifdef BN_MP_SET_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* set to a digit */ void mp_set (mp_int * a, mp_digit b) { mp_zero (a); a->dp[0] = b & MP_MASK; a->used = (a->dp[0] != 0) ? 1 : 0; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_set.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_set_int.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | #include <tommath.h> #ifdef BN_MP_SET_INT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* set a 32-bit const */ int mp_set_int (mp_int * a, unsigned long b) { int x, res; mp_zero (a); /* set four bits at a time */ for (x = 0; x < 8; x++) { /* shift the number up four bits */ if ((res = mp_mul_2d (a, 4, a)) != MP_OKAY) { return res; } /* OR in the top four bits of the source */ a->dp[0] |= (b >> 28) & 15; /* shift the source up to the next four bits */ b <<= 4; /* ensure that digits are not clamped off */ a->used += 1; } mp_clamp (a); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_set_int.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_shrink.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | #include <tommath.h> #ifdef BN_MP_SHRINK_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* shrink a bignum */ int mp_shrink (mp_int * a) { mp_digit *tmp; if (a->alloc != a->used && a->used > 0) { if ((tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * a->used)) == NULL) { return MP_MEM; } a->dp = tmp; a->alloc = a->used; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_shrink.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_signed_bin_size.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | #include <tommath.h> #ifdef BN_MP_SIGNED_BIN_SIZE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* get the size for an signed equivalent */ int mp_signed_bin_size (mp_int * a) { return 1 + mp_unsigned_bin_size (a); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_signed_bin_size.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_sqr.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | #include <tommath.h> #ifdef BN_MP_SQR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes b = a*a */ int mp_sqr (mp_int * a, mp_int * b) { int res; #ifdef BN_MP_TOOM_SQR_C /* use Toom-Cook? */ if (a->used >= TOOM_SQR_CUTOFF) { res = mp_toom_sqr(a, b); /* Karatsuba? */ } else #endif #ifdef BN_MP_KARATSUBA_SQR_C if (a->used >= KARATSUBA_SQR_CUTOFF) { res = mp_karatsuba_sqr (a, b); } else #endif { #ifdef BN_FAST_S_MP_SQR_C /* can we use the fast comba multiplier? */ if ((a->used * 2 + 1) < MP_WARRAY && a->used < (1 << (sizeof(mp_word) * CHAR_BIT - 2*DIGIT_BIT - 1))) { res = fast_s_mp_sqr (a, b); } else #endif #ifdef BN_S_MP_SQR_C res = s_mp_sqr (a, b); #else res = MP_VAL; #endif } b->sign = MP_ZPOS; return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sqr.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_sqrmod.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | #include <tommath.h> #ifdef BN_MP_SQRMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* c = a * a (mod b) */ int mp_sqrmod (mp_int * a, mp_int * b, mp_int * c) { int res; mp_int t; if ((res = mp_init (&t)) != MP_OKAY) { return res; } if ((res = mp_sqr (a, &t)) != MP_OKAY) { mp_clear (&t); return res; } res = mp_mod (&t, b, c); mp_clear (&t); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sqrmod.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_sqrt.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | #include <tommath.h> #ifdef BN_MP_SQRT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* this function is less generic than mp_n_root, simpler and faster */ int mp_sqrt(mp_int *arg, mp_int *ret) { int res; mp_int t1,t2; /* must be positive */ if (arg->sign == MP_NEG) { return MP_VAL; } /* easy out */ if (mp_iszero(arg) == MP_YES) { mp_zero(ret); return MP_OKAY; } if ((res = mp_init_copy(&t1, arg)) != MP_OKAY) { return res; } if ((res = mp_init(&t2)) != MP_OKAY) { goto E2; } /* First approx. (not very bad for large arg) */ mp_rshd (&t1,t1.used/2); /* t1 > 0 */ if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) { goto E1; } if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) { goto E1; } if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) { goto E1; } /* And now t1 > sqrt(arg) */ do { if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) { goto E1; } if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) { goto E1; } if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) { goto E1; } /* t1 >= sqrt(arg) >= t2 at this point */ } while (mp_cmp_mag(&t1,&t2) == MP_GT); mp_exch(&t1,ret); E1: mp_clear(&t2); E2: mp_clear(&t1); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sqrt.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_sub.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | #include <tommath.h> #ifdef BN_MP_SUB_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* high level subtraction (handles signs) */ int mp_sub (mp_int * a, mp_int * b, mp_int * c) { int sa, sb, res; sa = a->sign; sb = b->sign; if (sa != sb) { /* subtract a negative from a positive, OR */ /* subtract a positive from a negative. */ /* In either case, ADD their magnitudes, */ /* and use the sign of the first number. */ c->sign = sa; res = s_mp_add (a, b, c); } else { /* subtract a positive from a positive, OR */ /* subtract a negative from a negative. */ /* First, take the difference between their */ /* magnitudes, then... */ if (mp_cmp_mag (a, b) != MP_LT) { /* Copy the sign from the first */ c->sign = sa; /* The first has a larger or equal magnitude */ res = s_mp_sub (a, b, c); } else { /* The result has the *opposite* sign from */ /* the first number. */ c->sign = (sa == MP_ZPOS) ? MP_NEG : MP_ZPOS; /* The second has a larger magnitude */ res = s_mp_sub (b, a, c); } } return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sub.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_sub_d.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | #include <tommath.h> #ifdef BN_MP_SUB_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* single digit subtraction */ int mp_sub_d (mp_int * a, mp_digit b, mp_int * c) { mp_digit *tmpa, *tmpc, mu; int res, ix, oldused; /* grow c as required */ if (c->alloc < a->used + 1) { if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) { return res; } } /* if a is negative just do an unsigned * addition [with fudged signs] */ if (a->sign == MP_NEG) { a->sign = MP_ZPOS; res = mp_add_d(a, b, c); a->sign = c->sign = MP_NEG; return res; } /* setup regs */ oldused = c->used; tmpa = a->dp; tmpc = c->dp; /* if a <= b simply fix the single digit */ if ((a->used == 1 && a->dp[0] <= b) || a->used == 0) { if (a->used == 1) { *tmpc++ = b - *tmpa; } else { *tmpc++ = b; } ix = 1; /* negative/1digit */ c->sign = MP_NEG; c->used = 1; } else { /* positive/size */ c->sign = MP_ZPOS; c->used = a->used; /* subtract first digit */ *tmpc = *tmpa++ - b; mu = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1); *tmpc++ &= MP_MASK; /* handle rest of the digits */ for (ix = 1; ix < a->used; ix++) { *tmpc = *tmpa++ - mu; mu = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1); *tmpc++ &= MP_MASK; } } /* zero excess digits */ while (ix++ < oldused) { *tmpc++ = 0; } mp_clamp(c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_sub_d.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:53 $ */ |
Added libtommath/bn_mp_submod.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | #include <tommath.h> #ifdef BN_MP_SUBMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* d = a - b (mod c) */ int mp_submod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) { int res; mp_int t; if ((res = mp_init (&t)) != MP_OKAY) { return res; } if ((res = mp_sub (a, b, &t)) != MP_OKAY) { mp_clear (&t); return res; } res = mp_mod (&t, c, d); mp_clear (&t); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_submod.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_mp_to_signed_bin.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | #include <tommath.h> #ifdef BN_MP_TO_SIGNED_BIN_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* store in signed [big endian] format */ int mp_to_signed_bin (mp_int * a, unsigned char *b) { int res; if ((res = mp_to_unsigned_bin (a, b + 1)) != MP_OKAY) { return res; } b[0] = (unsigned char) ((a->sign == MP_ZPOS) ? 0 : 1); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_signed_bin.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_mp_to_signed_bin_n.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | #include <tommath.h> #ifdef BN_MP_TO_SIGNED_BIN_N_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* store in signed [big endian] format */ int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) { if (*outlen < (unsigned long)mp_signed_bin_size(a)) { return MP_VAL; } *outlen = mp_signed_bin_size(a); return mp_to_signed_bin(a, b); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_signed_bin_n.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_mp_to_unsigned_bin.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | #include <tommath.h> #ifdef BN_MP_TO_UNSIGNED_BIN_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* store in unsigned [big endian] format */ int mp_to_unsigned_bin (mp_int * a, unsigned char *b) { int x, res; mp_int t; if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } x = 0; while (mp_iszero (&t) == 0) { #ifndef MP_8BIT b[x++] = (unsigned char) (t.dp[0] & 255); #else b[x++] = (unsigned char) (t.dp[0] | ((t.dp[1] & 0x01) << 7)); #endif if ((res = mp_div_2d (&t, 8, &t, NULL)) != MP_OKAY) { mp_clear (&t); return res; } } bn_reverse (b, x); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_unsigned_bin.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_mp_to_unsigned_bin_n.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | #include <tommath.h> #ifdef BN_MP_TO_UNSIGNED_BIN_N_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* store in unsigned [big endian] format */ int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) { if (*outlen < (unsigned long)mp_unsigned_bin_size(a)) { return MP_VAL; } *outlen = mp_unsigned_bin_size(a); return mp_to_unsigned_bin(a, b); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_to_unsigned_bin_n.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_mp_toom_mul.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 | #include <tommath.h> #ifdef BN_MP_TOOM_MUL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* multiplication using the Toom-Cook 3-way algorithm * * Much more complicated than Karatsuba but has a lower * asymptotic running time of O(N**1.464). This algorithm is * only particularly useful on VERY large inputs * (we're talking 1000s of digits here...). */ int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c) { mp_int w0, w1, w2, w3, w4, tmp1, tmp2, a0, a1, a2, b0, b1, b2; int res, B; /* init temps */ if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &b0, &b1, &b2, &tmp1, &tmp2, NULL)) != MP_OKAY) { return res; } /* B */ B = MIN(a->used, b->used) / 3; /* a = a2 * B**2 + a1 * B + a0 */ if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) { goto ERR; } if ((res = mp_copy(a, &a1)) != MP_OKAY) { goto ERR; } mp_rshd(&a1, B); mp_mod_2d(&a1, DIGIT_BIT * B, &a1); if ((res = mp_copy(a, &a2)) != MP_OKAY) { goto ERR; } mp_rshd(&a2, B*2); /* b = b2 * B**2 + b1 * B + b0 */ if ((res = mp_mod_2d(b, DIGIT_BIT * B, &b0)) != MP_OKAY) { goto ERR; } if ((res = mp_copy(b, &b1)) != MP_OKAY) { goto ERR; } mp_rshd(&b1, B); mp_mod_2d(&b1, DIGIT_BIT * B, &b1); if ((res = mp_copy(b, &b2)) != MP_OKAY) { goto ERR; } mp_rshd(&b2, B*2); /* w0 = a0*b0 */ if ((res = mp_mul(&a0, &b0, &w0)) != MP_OKAY) { goto ERR; } /* w4 = a2 * b2 */ if ((res = mp_mul(&a2, &b2, &w4)) != MP_OKAY) { goto ERR; } /* w1 = (a2 + 2(a1 + 2a0))(b2 + 2(b1 + 2b0)) */ if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&b0, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp2, &b2, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_mul(&tmp1, &tmp2, &w1)) != MP_OKAY) { goto ERR; } /* w3 = (a0 + 2(a1 + 2a2))(b0 + 2(b1 + 2b2)) */ if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&b2, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_mul(&tmp1, &tmp2, &w3)) != MP_OKAY) { goto ERR; } /* w2 = (a2 + a1 + a0)(b2 + b1 + b0) */ if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&b2, &b1, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_mul(&tmp1, &tmp2, &w2)) != MP_OKAY) { goto ERR; } /* now solve the matrix 0 0 0 0 1 1 2 4 8 16 1 1 1 1 1 16 8 4 2 1 1 0 0 0 0 using 12 subtractions, 4 shifts, 2 small divisions and 1 small multiplication */ /* r1 - r4 */ if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) { goto ERR; } /* r3 - r0 */ if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) { goto ERR; } /* r1/2 */ if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) { goto ERR; } /* r3/2 */ if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) { goto ERR; } /* r2 - r0 - r4 */ if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) { goto ERR; } /* r1 - r2 */ if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { goto ERR; } /* r3 - r2 */ if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { goto ERR; } /* r1 - 8r0 */ if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) { goto ERR; } /* r3 - 8r4 */ if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { goto ERR; } /* 3r2 - r1 - r3 */ if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { goto ERR; } /* r1 - r2 */ if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { goto ERR; } /* r3 - r2 */ if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { goto ERR; } /* r1/3 */ if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) { goto ERR; } /* r3/3 */ if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) { goto ERR; } /* at this point shift W[n] by B*n */ if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) { goto ERR; } if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) { goto ERR; } if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) { goto ERR; } if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&w0, &w1, c)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, c, c)) != MP_OKAY) { goto ERR; } ERR: mp_clear_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &b0, &b1, &b2, &tmp1, &tmp2, NULL); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toom_mul.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_mp_toom_sqr.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 | #include <tommath.h> #ifdef BN_MP_TOOM_SQR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* squaring using Toom-Cook 3-way algorithm */ int mp_toom_sqr(mp_int *a, mp_int *b) { mp_int w0, w1, w2, w3, w4, tmp1, a0, a1, a2; int res, B; /* init temps */ if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL)) != MP_OKAY) { return res; } /* B */ B = a->used / 3; /* a = a2 * B**2 + a1 * B + a0 */ if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) { goto ERR; } if ((res = mp_copy(a, &a1)) != MP_OKAY) { goto ERR; } mp_rshd(&a1, B); mp_mod_2d(&a1, DIGIT_BIT * B, &a1); if ((res = mp_copy(a, &a2)) != MP_OKAY) { goto ERR; } mp_rshd(&a2, B*2); /* w0 = a0*a0 */ if ((res = mp_sqr(&a0, &w0)) != MP_OKAY) { goto ERR; } /* w4 = a2 * a2 */ if ((res = mp_sqr(&a2, &w4)) != MP_OKAY) { goto ERR; } /* w1 = (a2 + 2(a1 + 2a0))**2 */ if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sqr(&tmp1, &w1)) != MP_OKAY) { goto ERR; } /* w3 = (a0 + 2(a1 + 2a2))**2 */ if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sqr(&tmp1, &w3)) != MP_OKAY) { goto ERR; } /* w2 = (a2 + a1 + a0)**2 */ if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sqr(&tmp1, &w2)) != MP_OKAY) { goto ERR; } /* now solve the matrix 0 0 0 0 1 1 2 4 8 16 1 1 1 1 1 16 8 4 2 1 1 0 0 0 0 using 12 subtractions, 4 shifts, 2 small divisions and 1 small multiplication. */ /* r1 - r4 */ if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) { goto ERR; } /* r3 - r0 */ if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) { goto ERR; } /* r1/2 */ if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) { goto ERR; } /* r3/2 */ if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) { goto ERR; } /* r2 - r0 - r4 */ if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) { goto ERR; } /* r1 - r2 */ if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { goto ERR; } /* r3 - r2 */ if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { goto ERR; } /* r1 - 8r0 */ if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) { goto ERR; } /* r3 - 8r4 */ if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { goto ERR; } /* 3r2 - r1 - r3 */ if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { goto ERR; } /* r1 - r2 */ if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { goto ERR; } /* r3 - r2 */ if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { goto ERR; } /* r1/3 */ if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) { goto ERR; } /* r3/3 */ if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) { goto ERR; } /* at this point shift W[n] by B*n */ if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) { goto ERR; } if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) { goto ERR; } if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) { goto ERR; } if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&w0, &w1, b)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, b, b)) != MP_OKAY) { goto ERR; } ERR: mp_clear_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toom_sqr.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_mp_toradix.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | #include <tommath.h> #ifdef BN_MP_TORADIX_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* stores a bignum as a ASCII string in a given radix (2..64) */ int mp_toradix (mp_int * a, char *str, int radix) { int res, digs; mp_int t; mp_digit d; char *_s = str; /* check range of the radix */ if (radix < 2 || radix > 64) { return MP_VAL; } /* quick out if its zero */ if (mp_iszero(a) == 1) { *str++ = '0'; *str = '\0'; return MP_OKAY; } if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } /* if it is negative output a - */ if (t.sign == MP_NEG) { ++_s; *str++ = '-'; t.sign = MP_ZPOS; } digs = 0; while (mp_iszero (&t) == 0) { if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { mp_clear (&t); return res; } *str++ = mp_s_rmap[d]; ++digs; } /* reverse the digits of the string. In this case _s points * to the first digit [exluding the sign] of the number] */ bn_reverse ((unsigned char *)_s, digs); /* append a NULL so the string is properly terminated */ *str = '\0'; mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toradix.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_mp_toradix_n.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | #include <tommath.h> #ifdef BN_MP_TORADIX_N_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* stores a bignum as a ASCII string in a given radix (2..64) * * Stores upto maxlen-1 chars and always a NULL byte */ int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen) { int res, digs; mp_int t; mp_digit d; char *_s = str; /* check range of the maxlen, radix */ if (maxlen < 3 || radix < 2 || radix > 64) { return MP_VAL; } /* quick out if its zero */ if (mp_iszero(a) == 1) { *str++ = '0'; *str = '\0'; return MP_OKAY; } if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } /* if it is negative output a - */ if (t.sign == MP_NEG) { /* we have to reverse our digits later... but not the - sign!! */ ++_s; /* store the flag and mark the number as positive */ *str++ = '-'; t.sign = MP_ZPOS; /* subtract a char */ --maxlen; } digs = 0; while (mp_iszero (&t) == 0) { if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { mp_clear (&t); return res; } *str++ = mp_s_rmap[d]; ++digs; if (--maxlen == 1) { /* no more room */ break; } } /* reverse the digits of the string. In this case _s points * to the first digit [exluding the sign] of the number] */ bn_reverse ((unsigned char *)_s, digs); /* append a NULL so the string is properly terminated */ *str = '\0'; mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_toradix_n.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_mp_unsigned_bin_size.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | #include <tommath.h> #ifdef BN_MP_UNSIGNED_BIN_SIZE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* get the size for an unsigned equivalent */ int mp_unsigned_bin_size (mp_int * a) { int size = mp_count_bits (a); return (size / 8 + ((size & 7) != 0 ? 1 : 0)); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_unsigned_bin_size.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_mp_xor.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | #include <tommath.h> #ifdef BN_MP_XOR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* XOR two ints together */ int mp_xor (mp_int * a, mp_int * b, mp_int * c) { int res, ix, px; mp_int t, *x; if (a->used > b->used) { if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } px = b->used; x = b; } else { if ((res = mp_init_copy (&t, b)) != MP_OKAY) { return res; } px = a->used; x = a; } for (ix = 0; ix < px; ix++) { t.dp[ix] ^= x->dp[ix]; } mp_clamp (&t); mp_exch (c, &t); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_xor.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_mp_zero.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | #include <tommath.h> #ifdef BN_MP_ZERO_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* set to zero */ void mp_zero (mp_int * a) { int n; mp_digit *tmp; a->sign = MP_ZPOS; a->used = 0; tmp = a->dp; for (n = 0; n < a->alloc; n++) { *tmp++ = 0; } } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_zero.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_prime_tab.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | #include <tommath.h> #ifdef BN_PRIME_TAB_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ const mp_digit ltm_prime_tab[] = { 0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013, 0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035, 0x003B, 0x003D, 0x0043, 0x0047, 0x0049, 0x004F, 0x0053, 0x0059, 0x0061, 0x0065, 0x0067, 0x006B, 0x006D, 0x0071, 0x007F, #ifndef MP_8BIT 0x0083, 0x0089, 0x008B, 0x0095, 0x0097, 0x009D, 0x00A3, 0x00A7, 0x00AD, 0x00B3, 0x00B5, 0x00BF, 0x00C1, 0x00C5, 0x00C7, 0x00D3, 0x00DF, 0x00E3, 0x00E5, 0x00E9, 0x00EF, 0x00F1, 0x00FB, 0x0101, 0x0107, 0x010D, 0x010F, 0x0115, 0x0119, 0x011B, 0x0125, 0x0133, 0x0137, 0x0139, 0x013D, 0x014B, 0x0151, 0x015B, 0x015D, 0x0161, 0x0167, 0x016F, 0x0175, 0x017B, 0x017F, 0x0185, 0x018D, 0x0191, 0x0199, 0x01A3, 0x01A5, 0x01AF, 0x01B1, 0x01B7, 0x01BB, 0x01C1, 0x01C9, 0x01CD, 0x01CF, 0x01D3, 0x01DF, 0x01E7, 0x01EB, 0x01F3, 0x01F7, 0x01FD, 0x0209, 0x020B, 0x021D, 0x0223, 0x022D, 0x0233, 0x0239, 0x023B, 0x0241, 0x024B, 0x0251, 0x0257, 0x0259, 0x025F, 0x0265, 0x0269, 0x026B, 0x0277, 0x0281, 0x0283, 0x0287, 0x028D, 0x0293, 0x0295, 0x02A1, 0x02A5, 0x02AB, 0x02B3, 0x02BD, 0x02C5, 0x02CF, 0x02D7, 0x02DD, 0x02E3, 0x02E7, 0x02EF, 0x02F5, 0x02F9, 0x0301, 0x0305, 0x0313, 0x031D, 0x0329, 0x032B, 0x0335, 0x0337, 0x033B, 0x033D, 0x0347, 0x0355, 0x0359, 0x035B, 0x035F, 0x036D, 0x0371, 0x0373, 0x0377, 0x038B, 0x038F, 0x0397, 0x03A1, 0x03A9, 0x03AD, 0x03B3, 0x03B9, 0x03C7, 0x03CB, 0x03D1, 0x03D7, 0x03DF, 0x03E5, 0x03F1, 0x03F5, 0x03FB, 0x03FD, 0x0407, 0x0409, 0x040F, 0x0419, 0x041B, 0x0425, 0x0427, 0x042D, 0x043F, 0x0443, 0x0445, 0x0449, 0x044F, 0x0455, 0x045D, 0x0463, 0x0469, 0x047F, 0x0481, 0x048B, 0x0493, 0x049D, 0x04A3, 0x04A9, 0x04B1, 0x04BD, 0x04C1, 0x04C7, 0x04CD, 0x04CF, 0x04D5, 0x04E1, 0x04EB, 0x04FD, 0x04FF, 0x0503, 0x0509, 0x050B, 0x0511, 0x0515, 0x0517, 0x051B, 0x0527, 0x0529, 0x052F, 0x0551, 0x0557, 0x055D, 0x0565, 0x0577, 0x0581, 0x058F, 0x0593, 0x0595, 0x0599, 0x059F, 0x05A7, 0x05AB, 0x05AD, 0x05B3, 0x05BF, 0x05C9, 0x05CB, 0x05CF, 0x05D1, 0x05D5, 0x05DB, 0x05E7, 0x05F3, 0x05FB, 0x0607, 0x060D, 0x0611, 0x0617, 0x061F, 0x0623, 0x062B, 0x062F, 0x063D, 0x0641, 0x0647, 0x0649, 0x064D, 0x0653 #endif }; #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_prime_tab.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_reverse.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | #include <tommath.h> #ifdef BN_REVERSE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* reverse an array, used for radix code */ void bn_reverse (unsigned char *s, int len) { int ix, iy; unsigned char t; ix = 0; iy = len - 1; while (ix < iy) { t = s[ix]; s[ix] = s[iy]; s[iy] = t; ++ix; --iy; } } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_reverse.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_s_mp_add.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | #include <tommath.h> #ifdef BN_S_MP_ADD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* low level addition, based on HAC pp.594, Algorithm 14.7 */ int s_mp_add (mp_int * a, mp_int * b, mp_int * c) { mp_int *x; int olduse, res, min, max; /* find sizes, we let |a| <= |b| which means we have to sort * them. "x" will point to the input with the most digits */ if (a->used > b->used) { min = b->used; max = a->used; x = a; } else { min = a->used; max = b->used; x = b; } /* init result */ if (c->alloc < max + 1) { if ((res = mp_grow (c, max + 1)) != MP_OKAY) { return res; } } /* get old used digit count and set new one */ olduse = c->used; c->used = max + 1; { register mp_digit u, *tmpa, *tmpb, *tmpc; register int i; /* alias for digit pointers */ /* first input */ tmpa = a->dp; /* second input */ tmpb = b->dp; /* destination */ tmpc = c->dp; /* zero the carry */ u = 0; for (i = 0; i < min; i++) { /* Compute the sum at one digit, T[i] = A[i] + B[i] + U */ *tmpc = *tmpa++ + *tmpb++ + u; /* U = carry bit of T[i] */ u = *tmpc >> ((mp_digit)DIGIT_BIT); /* take away carry bit from T[i] */ *tmpc++ &= MP_MASK; } /* now copy higher words if any, that is in A+B * if A or B has more digits add those in */ if (min != max) { for (; i < max; i++) { /* T[i] = X[i] + U */ *tmpc = x->dp[i] + u; /* U = carry bit of T[i] */ u = *tmpc >> ((mp_digit)DIGIT_BIT); /* take away carry bit from T[i] */ *tmpc++ &= MP_MASK; } } /* add carry */ *tmpc++ = u; /* clear digits above oldused */ for (i = c->used; i < olduse; i++) { *tmpc++ = 0; } } mp_clamp (c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_add.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_s_mp_exptmod.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | #include <tommath.h> #ifdef BN_S_MP_EXPTMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ #ifdef MP_LOW_MEM #define TAB_SIZE 32 #else #define TAB_SIZE 256 #endif int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode) { mp_int M[TAB_SIZE], res, mu; mp_digit buf; int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; int (*redux)(mp_int*,mp_int*,mp_int*); /* find window size */ x = mp_count_bits (X); if (x <= 7) { winsize = 2; } else if (x <= 36) { winsize = 3; } else if (x <= 140) { winsize = 4; } else if (x <= 450) { winsize = 5; } else if (x <= 1303) { winsize = 6; } else if (x <= 3529) { winsize = 7; } else { winsize = 8; } #ifdef MP_LOW_MEM if (winsize > 5) { winsize = 5; } #endif /* init M array */ /* init first cell */ if ((err = mp_init(&M[1])) != MP_OKAY) { return err; } /* now init the second half of the array */ for (x = 1<<(winsize-1); x < (1 << winsize); x++) { if ((err = mp_init(&M[x])) != MP_OKAY) { for (y = 1<<(winsize-1); y < x; y++) { mp_clear (&M[y]); } mp_clear(&M[1]); return err; } } /* create mu, used for Barrett reduction */ if ((err = mp_init (&mu)) != MP_OKAY) { goto LBL_M; } if (redmode == 0) { if ((err = mp_reduce_setup (&mu, P)) != MP_OKAY) { goto LBL_MU; } redux = mp_reduce; } else { if ((err = mp_reduce_2k_setup_l (P, &mu)) != MP_OKAY) { goto LBL_MU; } redux = mp_reduce_2k_l; } /* create M table * * The M table contains powers of the base, * e.g. M[x] = G**x mod P * * The first half of the table is not * computed though accept for M[0] and M[1] */ if ((err = mp_mod (G, P, &M[1])) != MP_OKAY) { goto LBL_MU; } /* compute the value at M[1<<(winsize-1)] by squaring * M[1] (winsize-1) times */ if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) { goto LBL_MU; } for (x = 0; x < (winsize - 1); x++) { /* square it */ if ((err = mp_sqr (&M[1 << (winsize - 1)], &M[1 << (winsize - 1)])) != MP_OKAY) { goto LBL_MU; } /* reduce modulo P */ if ((err = redux (&M[1 << (winsize - 1)], P, &mu)) != MP_OKAY) { goto LBL_MU; } } /* create upper table, that is M[x] = M[x-1] * M[1] (mod P) * for x = (2**(winsize - 1) + 1) to (2**winsize - 1) */ for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) { if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) { goto LBL_MU; } if ((err = redux (&M[x], P, &mu)) != MP_OKAY) { goto LBL_MU; } } /* setup result */ if ((err = mp_init (&res)) != MP_OKAY) { goto LBL_MU; } mp_set (&res, 1); /* set initial mode and bit cnt */ mode = 0; bitcnt = 1; buf = 0; digidx = X->used - 1; bitcpy = 0; bitbuf = 0; for (;;) { /* grab next digit as required */ if (--bitcnt == 0) { /* if digidx == -1 we are out of digits */ if (digidx == -1) { break; } /* read next digit and reset the bitcnt */ buf = X->dp[digidx--]; bitcnt = (int) DIGIT_BIT; } /* grab the next msb from the exponent */ y = (buf >> (mp_digit)(DIGIT_BIT - 1)) & 1; buf <<= (mp_digit)1; /* if the bit is zero and mode == 0 then we ignore it * These represent the leading zero bits before the first 1 bit * in the exponent. Technically this opt is not required but it * does lower the # of trivial squaring/reductions used */ if (mode == 0 && y == 0) { continue; } /* if the bit is zero and mode == 1 then we square */ if (mode == 1 && y == 0) { if ((err = mp_sqr (&res, &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, &mu)) != MP_OKAY) { goto LBL_RES; } continue; } /* else we add it to the window */ bitbuf |= (y << (winsize - ++bitcpy)); mode = 2; if (bitcpy == winsize) { /* ok window is filled so square as required and multiply */ /* square first */ for (x = 0; x < winsize; x++) { if ((err = mp_sqr (&res, &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, &mu)) != MP_OKAY) { goto LBL_RES; } } /* then multiply */ if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, &mu)) != MP_OKAY) { goto LBL_RES; } /* empty window and reset */ bitcpy = 0; bitbuf = 0; mode = 1; } } /* if bits remain then square/multiply */ if (mode == 2 && bitcpy > 0) { /* square then multiply if the bit is set */ for (x = 0; x < bitcpy; x++) { if ((err = mp_sqr (&res, &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, &mu)) != MP_OKAY) { goto LBL_RES; } bitbuf <<= 1; if ((bitbuf & (1 << winsize)) != 0) { /* then multiply */ if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, &mu)) != MP_OKAY) { goto LBL_RES; } } } } mp_exch (&res, Y); err = MP_OKAY; LBL_RES:mp_clear (&res); LBL_MU:mp_clear (&mu); LBL_M: mp_clear(&M[1]); for (x = 1<<(winsize-1); x < (1 << winsize); x++) { mp_clear (&M[x]); } return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_exptmod.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_s_mp_mul_digs.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | #include <tommath.h> #ifdef BN_S_MP_MUL_DIGS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* multiplies |a| * |b| and only computes upto digs digits of result * HAC pp. 595, Algorithm 14.12 Modified so you can control how * many digits of output are created. */ int s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) { mp_int t; int res, pa, pb, ix, iy; mp_digit u; mp_word r; mp_digit tmpx, *tmpt, *tmpy; /* can we use the fast multiplier? */ if (((digs) < MP_WARRAY) && MIN (a->used, b->used) < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { return fast_s_mp_mul_digs (a, b, c, digs); } if ((res = mp_init_size (&t, digs)) != MP_OKAY) { return res; } t.used = digs; /* compute the digits of the product directly */ pa = a->used; for (ix = 0; ix < pa; ix++) { /* set the carry to zero */ u = 0; /* limit ourselves to making digs digits of output */ pb = MIN (b->used, digs - ix); /* setup some aliases */ /* copy of the digit from a used within the nested loop */ tmpx = a->dp[ix]; /* an alias for the destination shifted ix places */ tmpt = t.dp + ix; /* an alias for the digits of b */ tmpy = b->dp; /* compute the columns of the output and propagate the carry */ for (iy = 0; iy < pb; iy++) { /* compute the column as a mp_word */ r = ((mp_word)*tmpt) + ((mp_word)tmpx) * ((mp_word)*tmpy++) + ((mp_word) u); /* the new column is the lower part of the result */ *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); /* get the carry word from the result */ u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); } /* set carry if it is placed below digs */ if (ix + iy < digs) { *tmpt = u; } } mp_clamp (&t); mp_exch (&t, c); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_mul_digs.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_s_mp_mul_high_digs.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | #include <tommath.h> #ifdef BN_S_MP_MUL_HIGH_DIGS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* multiplies |a| * |b| and does not compute the lower digs digits * [meant to get the higher part of the product] */ int s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) { mp_int t; int res, pa, pb, ix, iy; mp_digit u; mp_word r; mp_digit tmpx, *tmpt, *tmpy; /* can we use the fast multiplier? */ #ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C if (((a->used + b->used + 1) < MP_WARRAY) && MIN (a->used, b->used) < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { return fast_s_mp_mul_high_digs (a, b, c, digs); } #endif if ((res = mp_init_size (&t, a->used + b->used + 1)) != MP_OKAY) { return res; } t.used = a->used + b->used + 1; pa = a->used; pb = b->used; for (ix = 0; ix < pa; ix++) { /* clear the carry */ u = 0; /* left hand side of A[ix] * B[iy] */ tmpx = a->dp[ix]; /* alias to the address of where the digits will be stored */ tmpt = &(t.dp[digs]); /* alias for where to read the right hand side from */ tmpy = b->dp + (digs - ix); for (iy = digs - ix; iy < pb; iy++) { /* calculate the double precision result */ r = ((mp_word)*tmpt) + ((mp_word)tmpx) * ((mp_word)*tmpy++) + ((mp_word) u); /* get the lower part */ *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); /* carry the carry */ u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); } *tmpt = u; } mp_clamp (&t); mp_exch (&t, c); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_mul_high_digs.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_s_mp_sqr.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | #include <tommath.h> #ifdef BN_S_MP_SQR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* low level squaring, b = a*a, HAC pp.596-597, Algorithm 14.16 */ int s_mp_sqr (mp_int * a, mp_int * b) { mp_int t; int res, ix, iy, pa; mp_word r; mp_digit u, tmpx, *tmpt; pa = a->used; if ((res = mp_init_size (&t, 2*pa + 1)) != MP_OKAY) { return res; } /* default used is maximum possible size */ t.used = 2*pa + 1; for (ix = 0; ix < pa; ix++) { /* first calculate the digit at 2*ix */ /* calculate double precision result */ r = ((mp_word) t.dp[2*ix]) + ((mp_word)a->dp[ix])*((mp_word)a->dp[ix]); /* store lower part in result */ t.dp[ix+ix] = (mp_digit) (r & ((mp_word) MP_MASK)); /* get the carry */ u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); /* left hand side of A[ix] * A[iy] */ tmpx = a->dp[ix]; /* alias for where to store the results */ tmpt = t.dp + (2*ix + 1); for (iy = ix + 1; iy < pa; iy++) { /* first calculate the product */ r = ((mp_word)tmpx) * ((mp_word)a->dp[iy]); /* now calculate the double precision result, note we use * addition instead of *2 since it's easier to optimize */ r = ((mp_word) *tmpt) + r + r + ((mp_word) u); /* store lower part */ *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); /* get carry */ u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); } /* propagate upwards */ while (u != ((mp_digit) 0)) { r = ((mp_word) *tmpt) + ((mp_word) u); *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); } } mp_clamp (&t); mp_exch (&t, b); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_sqr.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bn_s_mp_sub.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | #include <tommath.h> #ifdef BN_S_MP_SUB_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* low level subtraction (assumes |a| > |b|), HAC pp.595 Algorithm 14.9 */ int s_mp_sub (mp_int * a, mp_int * b, mp_int * c) { int olduse, res, min, max; /* find sizes */ min = b->used; max = a->used; /* init result */ if (c->alloc < max) { if ((res = mp_grow (c, max)) != MP_OKAY) { return res; } } olduse = c->used; c->used = max; { register mp_digit u, *tmpa, *tmpb, *tmpc; register int i; /* alias for digit pointers */ tmpa = a->dp; tmpb = b->dp; tmpc = c->dp; /* set carry to zero */ u = 0; for (i = 0; i < min; i++) { /* T[i] = A[i] - B[i] - U */ *tmpc = *tmpa++ - *tmpb++ - u; /* U = carry bit of T[i] * Note this saves performing an AND operation since * if a carry does occur it will propagate all the way to the * MSB. As a result a single shift is enough to get the carry */ u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1)); /* Clear carry from T[i] */ *tmpc++ &= MP_MASK; } /* now copy higher words if any, e.g. if A has more digits than B */ for (; i < max; i++) { /* T[i] = A[i] - U */ *tmpc = *tmpa++ - u; /* U = carry bit of T[i] */ u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1)); /* Clear carry from T[i] */ *tmpc++ &= MP_MASK; } /* clear digits above used (since we may not have grown result above) */ for (i = c->used; i < olduse; i++) { *tmpc++ = 0; } } mp_clamp (c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_s_mp_sub.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/bncore.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | #include <tommath.h> #ifdef BNCORE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Known optimal configurations CPU /Compiler /MUL CUTOFF/SQR CUTOFF ------------------------------------------------------------- Intel P4 Northwood /GCC v3.4.1 / 88/ 128/LTM 0.32 ;-) AMD Athlon64 /GCC v3.4.4 / 80/ 120/LTM 0.35 */ int KARATSUBA_MUL_CUTOFF = 80, /* Min. number of digits before Karatsuba multiplication is used. */ KARATSUBA_SQR_CUTOFF = 120, /* Min. number of digits before Karatsuba squaring is used. */ TOOM_MUL_CUTOFF = 350, /* no optimal values of these are known yet so set em high */ TOOM_SQR_CUTOFF = 400; #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bncore.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/booker.pl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #!/bin/perl # #Used to prepare the book "tommath.src" for LaTeX by pre-processing it into a .tex file # #Essentially you write the "tommath.src" as normal LaTex except where you want code snippets you put # #EXAM,file # #This preprocessor will then open "file" and insert it as a verbatim copy. # #Tom St Denis #get graphics type if (shift =~ /PDF/) { $graph = ""; } else { $graph = ".ps"; } open(IN,"<tommath.src") or die "Can't open source file"; open(OUT,">tommath.tex") or die "Can't open destination file"; print "Scanning for sections\n"; $chapter = $section = $subsection = 0; $x = 0; while (<IN>) { print "."; if (!(++$x % 80)) { print "\n"; } #update the headings if (~($_ =~ /\*/)) { if ($_ =~ /\\chapter{.+}/) { ++$chapter; $section = $subsection = 0; } elsif ($_ =~ /\\section{.+}/) { ++$section; $subsection = 0; } elsif ($_ =~ /\\subsection{.+}/) { ++$subsection; } } if ($_ =~ m/MARK/) { @m = split(",",$_); chomp(@m[1]); $index1{@m[1]} = $chapter; $index2{@m[1]} = $section; $index3{@m[1]} = $subsection; } } close(IN); open(IN,"<tommath.src") or die "Can't open source file"; $readline = $wroteline = 0; $srcline = 0; while (<IN>) { ++$readline; ++$srcline; if ($_ =~ m/MARK/) { } elsif ($_ =~ m/EXAM/ || $_ =~ m/LIST/) { if ($_ =~ m/EXAM/) { $skipheader = 1; } else { $skipheader = 0; } # EXAM,file chomp($_); @m = split(",",$_); open(SRC,"<$m[1]") or die "Error:$srcline:Can't open source file $m[1]"; print "$srcline:Inserting $m[1]:"; $line = 0; $tmp = $m[1]; $tmp =~ s/_/"\\_"/ge; print OUT "\\vspace{+3mm}\\begin{small}\n\\hspace{-5.1mm}{\\bf File}: $tmp\n\\vspace{-3mm}\n\\begin{alltt}\n"; $wroteline += 5; if ($skipheader == 1) { # scan till next end of comment, e.g. skip license while (<SRC>) { $text[$line++] = $_; last if ($_ =~ /math\.libtomcrypt\.org/); } <SRC>; } $inline = 0; while (<SRC>) { next if ($_ =~ /\$Source/); next if ($_ =~ /\$Revision/); next if ($_ =~ /\$Date/); $text[$line++] = $_; ++$inline; chomp($_); $_ =~ s/\t/" "/ge; $_ =~ s/{/"^{"/ge; $_ =~ s/}/"^}"/ge; $_ =~ s/\\/'\symbol{92}'/ge; $_ =~ s/\^/"\\"/ge; printf OUT ("%03d ", $line); for ($x = 0; $x < length($_); $x++) { print OUT chr(vec($_, $x, 8)); if ($x == 75) { print OUT "\n "; ++$wroteline; } } print OUT "\n"; ++$wroteline; } $totlines = $line; print OUT "\\end{alltt}\n\\end{small}\n"; close(SRC); print "$inline lines\n"; $wroteline += 2; } elsif ($_ =~ m/@\d+,.+@/) { # line contains [number,text] # e.g. @14,for (ix = 0)@ $txt = $_; while ($txt =~ m/@\d+,.+@/) { @m = split("@",$txt); # splits into text, one, two @parms = split(",",$m[1]); # splits one,two into two elements # now search from $parms[0] down for $parms[1] $found1 = 0; $found2 = 0; for ($i = $parms[0]; $i < $totlines && $found1 == 0; $i++) { if ($text[$i] =~ m/\Q$parms[1]\E/) { $foundline1 = $i + 1; $found1 = 1; } } # now search backwards for ($i = $parms[0] - 1; $i >= 0 && $found2 == 0; $i--) { if ($text[$i] =~ m/\Q$parms[1]\E/) { $foundline2 = $i + 1; $found2 = 1; } } # now use the closest match or the first if tied if ($found1 == 1 && $found2 == 0) { $found = 1; $foundline = $foundline1; } elsif ($found1 == 0 && $found2 == 1) { $found = 1; $foundline = $foundline2; } elsif ($found1 == 1 && $found2 == 1) { $found = 1; if (($foundline1 - $parms[0]) <= ($parms[0] - $foundline2)) { $foundline = $foundline1; } else { $foundline = $foundline2; } } else { $found = 0; } # if found replace if ($found == 1) { $delta = $parms[0] - $foundline; print "Found replacement tag for \"$parms[1]\" on line $srcline which refers to line $foundline (delta $delta)\n"; $_ =~ s/@\Q$m[1]\E@/$foundline/; } else { print "ERROR: The tag \"$parms[1]\" on line $srcline was not found in the most recently parsed source!\n"; } # remake the rest of the line $cnt = @m; $txt = ""; for ($i = 2; $i < $cnt; $i++) { $txt = $txt . $m[$i] . "@"; } } print OUT $_; ++$wroteline; } elsif ($_ =~ /~.+~/) { # line contains a ~text~ pair used to refer to indexing :-) $txt = $_; while ($txt =~ /~.+~/) { @m = split("~", $txt); # word is the second position $word = @m[1]; $a = $index1{$word}; $b = $index2{$word}; $c = $index3{$word}; # if chapter (a) is zero it wasn't found if ($a == 0) { print "ERROR: the tag \"$word\" on line $srcline was not found previously marked.\n"; } else { # format the tag as x, x.y or x.y.z depending on the values $str = $a; $str = $str . ".$b" if ($b != 0); $str = $str . ".$c" if ($c != 0); if ($b == 0 && $c == 0) { # its a chapter if ($a <= 10) { if ($a == 1) { $str = "chapter one"; } elsif ($a == 2) { $str = "chapter two"; } elsif ($a == 3) { $str = "chapter three"; } elsif ($a == 4) { $str = "chapter four"; } elsif ($a == 5) { $str = "chapter five"; } elsif ($a == 6) { $str = "chapter six"; } elsif ($a == 7) { $str = "chapter seven"; } elsif ($a == 8) { $str = "chapter eight"; } elsif ($a == 9) { $str = "chapter nine"; } elsif ($a == 2) { $str = "chapter ten"; } } else { $str = "chapter " . $str; } } else { $str = "section " . $str if ($b != 0 && $c == 0); $str = "sub-section " . $str if ($b != 0 && $c != 0); } #substitute $_ =~ s/~\Q$word\E~/$str/; print "Found replacement tag for marker \"$word\" on line $srcline which refers to $str\n"; } # remake rest of the line $cnt = @m; $txt = ""; for ($i = 2; $i < $cnt; $i++) { $txt = $txt . $m[$i] . "~"; } } print OUT $_; ++$wroteline; } elsif ($_ =~ m/FIGU/) { # FIGU,file,caption chomp($_); @m = split(",", $_); print OUT "\\begin{center}\n\\begin{figure}[here]\n\\includegraphics{pics/$m[1]$graph}\n"; print OUT "\\caption{$m[2]}\n\\label{pic:$m[1]}\n\\end{figure}\n\\end{center}\n"; $wroteline += 4; } else { print OUT $_; ++$wroteline; } } print "Read $readline lines, wrote $wroteline lines\n"; close (OUT); close (IN); |
Added libtommath/callgraph.txt.
more than 10,000 changes
Added libtommath/changes.txt.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | August 1st, 2005 v0.36 -- LTM_PRIME_2MSB_ON was fixed and the "OFF" flag was removed. -- [Peter LaDow] found a typo in the XREALLOC macro -- [Peter LaDow] pointed out that mp_read_(un)signed_bin should have "const" on the input -- Ported LTC patch to fix the prime_random_ex() function to get the bitsize correct [and the maskOR flags] -- Kevin Kenny pointed out a stray // -- David Hulton pointed out a typo in the textbook [mp_montgomery_setup() pseudo-code] -- Neal Hamilton (Elliptic Semiconductor) pointed out that my Karatsuba notation was backwards and that I could use unsigned operations in the routine. -- Paul Schmidt pointed out a linking error in mp_exptmod() when BN_S_MP_EXPTMOD_C is undefined (and another for read_radix) -- Updated makefiles to be way more flexible March 12th, 2005 v0.35 -- Stupid XOR function missing line again... oops. -- Fixed bug in invmod not handling negative inputs correctly [Wolfgang Ehrhardt] -- Made exteuclid always give positive u3 output...[ Wolfgang Ehrhardt ] -- [Wolfgang Ehrhardt] Suggested a fix for mp_reduce() which avoided underruns. ;-) -- mp_rand() would emit one too many digits and it was possible to get a 0 out of it ... oops -- Added montgomery to the testing to make sure it handles 1..10 digit moduli correctly -- Fixed bug in comba that would lead to possible erroneous outputs when "pa < digs" -- Fixed bug in mp_toradix_size for "0" [Kevin Kenny] -- Updated chapters 1-5 of the textbook ;-) It now talks about the new comba code! February 12th, 2005 v0.34 -- Fixed two more small errors in mp_prime_random_ex() -- Fixed overflow in mp_mul_d() [Kevin Kenny] -- Added mp_to_(un)signed_bin_n() functions which do bounds checking for ya [and report the size] -- Added "large" diminished radix support. Speeds up things like DSA where the moduli is of the form 2^k - P for some P < 2^(k/2) or so Actually is faster than Montgomery on my AMD64 (and probably much faster on a P4) -- Updated the manual a bit -- Ok so I haven't done the textbook work yet... My current freelance gig has landed me in France till the end of Feb/05. Once I get back I'll have tons of free time and I plan to go to town on the book. As of this release the API will freeze. At least until the book catches up with all the changes. I welcome bug reports but new algorithms will have to wait. December 23rd, 2004 v0.33 -- Fixed "small" variant for mp_div() which would munge with negative dividends... -- Fixed bug in mp_prime_random_ex() which would set the most significant byte to zero when no special flags were set -- Fixed overflow [minor] bug in fast_s_mp_sqr() -- Made the makefiles easier to configure the group/user that ltm will install as -- Fixed "final carry" bug in comba multipliers. (Volkan Ceylan) -- Matt Johnston pointed out a missing semi-colon in mp_exptmod October 29th, 2004 v0.32 -- Added "makefile.shared" for shared object support -- Added more to the build options/configs in the manual -- Started the Depends framework, wrote dep.pl to scan deps and produce "callgraph.txt" ;-) -- Wrote SC_RSA_1 which will enable close to the minimum required to perform RSA on 32-bit [or 64-bit] platforms with LibTomCrypt -- Merged in the small/slower mp_div replacement. You can now toggle which you want to use as your mp_div() at build time. Saves roughly 8KB or so. -- Renamed a few files and changed some comments to make depends system work better. (No changes to function names) -- Merged in new Combas that perform 2 reads per inner loop instead of the older 3reads/2writes per inner loop of the old code. Really though if you want speed learn to use TomsFastMath ;-) August 9th, 2004 v0.31 -- "profiled" builds now :-) new timings for Intel Northwoods -- Added "pretty" build target -- Update mp_init() to actually assign 0's instead of relying on calloc() -- "Wolfgang Ehrhardt" <[email protected]> found a bug in mp_mul() where if you multiply a negative by zero you get negative zero as the result. Oops. -- J Harper from PeerSec let me toy with his AMD64 and I got 60-bit digits working properly [this also means that I fixed a bug where if sizeof(int) < sizeof(mp_digit) it would bug] April 11th, 2004 v0.30 -- Added "mp_toradix_n" which stores upto "n-1" least significant digits of an mp_int -- Johan Lindh sent a patch so MSVC wouldn't whine about redefining malloc [in weird dll modes] -- Henrik Goldman spotted a missing OPT_CAST in mp_fwrite() -- Tuned tommath.h so that when MP_LOW_MEM is defined MP_PREC shall be reduced. [I also allow MP_PREC to be externally defined now] -- Sped up mp_cnt_lsb() by using a 4x4 table [e.g. 4x speedup] -- Added mp_prime_random_ex() which is a more versatile prime generator accurate to exact bit lengths (unlike the deprecated but still available mp_prime_random() which is only accurate to byte lengths). See the new LTM_PRIME_* flags ;-) -- Alex Polushin contributed an optimized mp_sqrt() as well as mp_get_int() and mp_is_square(). I've cleaned them all up to be a little more consistent [along with one bug fix] for this release. -- Added mp_init_set and mp_init_set_int to initialize and set small constants with one function call. -- Removed /etclib directory [um LibTomPoly deprecates this]. -- Fixed mp_mod() so the sign of the result agrees with the sign of the modulus. ++ N.B. My semester is almost up so expect updates to the textbook to be posted to the libtomcrypt.org website. Jan 25th, 2004 v0.29 ++ Note: "Henrik" from the v0.28 changelog refers to Henrik Goldman ;-) -- Added fix to mp_shrink to prevent a realloc when used == 0 [e.g. realloc zero bytes???] -- Made the mp_prime_rabin_miller_trials() function internal table smaller and also set the minimum number of tests to two (sounds a bit safer). -- Added a mp_exteuclid() which computes the extended euclidean algorithm. -- Fixed a memory leak in s_mp_exptmod() [called when Barrett reduction is to be used] which would arise if a multiplication or subsequent reduction failed [would not free the temp result]. -- Made an API change to mp_radix_size(). It now returns an error code and stores the required size through an "int star" passed to it. Dec 24th, 2003 v0.28 -- Henrik Goldman suggested I add casts to the montomgery code [stores into mu...] so compilers wouldn't spew [erroneous] diagnostics... fixed. -- Henrik Goldman also spotted two typos. One in mp_radix_size() and another in mp_toradix(). -- Added fix to mp_shrink() to avoid a memory leak. -- Added mp_prime_random() which requires a callback to make truly random primes of a given nature (idea from chat with Niels Ferguson at Crypto'03) -- Picked up a second wind. I'm filled with Gooo. Mission Gooo! -- Removed divisions from mp_reduce_is_2k() -- Sped up mp_div_d() [general case] to use only one division per digit instead of two. -- Added the heap macros from LTC to LTM. Now you can easily [by editing four lines of tommath.h] change the name of the heap functions used in LTM [also compatible with LTC via MPI mode] -- Added bn_prime_rabin_miller_trials() which gives the number of Rabin-Miller trials to achieve a failure rate of less than 2^-96 -- fixed bug in fast_mp_invmod(). The initial testing logic was wrong. An invalid input is not when "a" and "b" are even it's when "b" is even [the algo is for odd moduli only]. -- Started a new manual [finally]. It is incomplete and will be finished as time goes on. I had to stop adding full demos around half way in chapter three so I could at least get a good portion of the manual done. If you really need help using the library you can always email me! -- My Textbook is now included as part of the package [all Public Domain] Sept 19th, 2003 v0.27 -- Removed changes.txt~ which was made by accident since "kate" decided it was a good time to re-enable backups... [kde is fun!] -- In mp_grow() "a->dp" is not overwritten by realloc call [re: memory leak] Now if mp_grow() fails the mp_int is still valid and can be cleared via mp_clear() to reclaim the memory. -- Henrik Goldman found a buffer overflow bug in mp_add_d(). Fixed. -- Cleaned up mp_mul_d() to be much easier to read and follow. Aug 29th, 2003 v0.26 -- Fixed typo that caused warning with GCC 3.2 -- Martin Marcel noticed a bug in mp_neg() that allowed negative zeroes. Also, Martin is the fellow who noted the bugs in mp_gcd() of 0.24/0.25. -- Martin Marcel noticed an optimization [and slight bug] in mp_lcm(). -- Added fix to mp_read_unsigned_bin to prevent a buffer overflow. -- Beefed up the comments in the baseline multipliers [and montgomery] -- Added "mont" demo to the makefile.msvc in etc/ -- Optimized sign compares in mp_cmp from 4 to 2 cases. Aug 4th, 2003 v0.25 -- Fix to mp_gcd again... oops (0,-a) == (-a, 0) == a -- Fix to mp_clear which didn't reset the sign [Greg Rose] -- Added mp_error_to_string() to convert return codes to strings. [Greg Rose] -- Optimized fast_mp_invmod() to do the test for invalid inputs [both even] first so temps don't have to be initialized if it's going to fail. -- Optimized mp_gcd() by removing mp_div_2d calls for when one of the inputs is odd. -- Tons of new comments, some indentation fixups, etc. -- mp_jacobi() returns MP_VAL if the modulus is less than or equal to zero. -- fixed two typos in the header of each file :-) -- LibTomMath is officially Public Domain [see LICENSE] July 15th, 2003 v0.24 -- Optimized mp_add_d and mp_sub_d to not allocate temporary variables -- Fixed mp_gcd() so the gcd of 0,0 is 0. Allows the gcd operation to be chained e.g. (0,0,a) == a [instead of 1] -- Should be one of the last release for a while. Working on LibTomMath book now. -- optimized the pprime demo [/etc/pprime.c] to first make a huge table of single digit primes then it reads them randomly instead of randomly choosing/testing single digit primes. July 12th, 2003 v0.23 -- Optimized mp_prime_next_prime() to not use mp_mod [via is_divisible()] in each iteration. Instead now a smaller table is kept of the residues which can be updated without division. -- Fixed a bug in next_prime() where an input of zero would be treated as odd and have two added to it [to move to the next odd]. -- fixed a bug in prime_fermat() and prime_miller_rabin() which allowed the base to be negative, zero or one. Normally the test is only valid if the base is greater than one. -- changed the next_prime() prototype to accept a new parameter "bbs_style" which will find the next prime congruent to 3 mod 4. The default [bbs_style==0] will make primes which are either congruent to 1 or 3 mod 4. -- fixed mp_read_unsigned_bin() so that it doesn't include both code for the case DIGIT_BIT < 8 and >= 8 -- optimized div_d() to easy out on division by 1 [or if a == 0] and use logical shifts if the divisor is a power of two. -- the default DIGIT_BIT type was not int for non-default builds. Fixed. July 2nd, 2003 v0.22 -- Fixed up mp_invmod so the result is properly in range now [was always congruent to the inverse...] -- Fixed up s_mp_exptmod and mp_exptmod_fast so the lower half of the pre-computed table isn't allocated which makes the algorithm use half as much ram. -- Fixed the install script not to make the book :-) [which isn't included anyways] -- added mp_cnt_lsb() which counts how many of the lsbs are zero -- optimized mp_gcd() to use the new mp_cnt_lsb() to replace multiple divisions by two by a single division. -- applied similar optimization to mp_prime_miller_rabin(). -- Fixed a bug in both mp_invmod() and fast_mp_invmod() which tested for odd via "mp_iseven() == 0" which is not valid [since zero is not even either]. June 19th, 2003 v0.21 -- Fixed bug in mp_mul_d which would not handle sign correctly [would not always forward it] -- Removed the #line lines from gen.pl [was in violation of ISO C] June 8th, 2003 v0.20 -- Removed the book from the package. Added the TDCAL license document. -- This release is officially pure-bred TDCAL again [last officially TDCAL based release was v0.16] June 6th, 2003 v0.19 -- Fixed a bug in mp_montgomery_reduce() which was introduced when I tweaked mp_rshd() in the previous release. Essentially the digits were not trimmed before the compare which cause a subtraction to occur all the time. -- Fixed up etc/tune.c a bit to stop testing new cutoffs after 16 failures [to find more optimal points]. Brute force ho! May 29th, 2003 v0.18 -- Fixed a bug in s_mp_sqr which would handle carries properly just not very elegantly. (e.g. correct result, just bad looking code) -- Fixed bug in mp_sqr which still had a 512 constant instead of MP_WARRAY -- Added Toom-Cook multipliers [needs tuning!] -- Added efficient divide by 3 algorithm mp_div_3 -- Re-wrote mp_div_d to be faster than calling mp_div -- Added in a donated BCC makefile and a single page LTM poster ([email protected]) -- Added mp_reduce_2k which reduces an input modulo n = 2**p - k for any single digit k -- Made the exptmod system be aware of the 2k reduction algorithms. -- Rewrote mp_dr_reduce to be smaller, simpler and easier to understand. May 17th, 2003 v0.17 -- Benjamin Goldberg submitted optimized mp_add and mp_sub routines. A new gen.pl as well as several smaller suggestions. Thanks! -- removed call to mp_cmp in inner loop of mp_div and put mp_cmp_mag in its place :-) -- Fixed bug in mp_exptmod that would cause it to fail for odd moduli when DIGIT_BIT != 28 -- mp_exptmod now also returns errors if the modulus is negative and will handle negative exponents -- mp_prime_is_prime will now return true if the input is one of the primes in the prime table -- Damian M Gryski ([email protected]) found a index out of bounds error in the mp_fast_s_mp_mul_high_digs function which didn't come up before. (fixed) -- Refactored the DR reduction code so there is only one function per file. -- Fixed bug in the mp_mul() which would erroneously avoid the faster multiplier [comba] when it was allowed. The bug would not cause the incorrect value to be produced just less efficient (fixed) -- Fixed similar bug in the Montgomery reduction code. -- Added tons of (mp_digit) casts so the 7/15/28/31 bit digit code will work flawlessly out of the box. Also added limited support for 64-bit machines with a 60-bit digit. Both thanks to Tom Wu ([email protected]) -- Added new comments here and there, cleaned up some code [style stuff] -- Fixed a lingering typo in mp_exptmod* that would set bitcnt to zero then one. Very silly stuff :-) -- Fixed up mp_exptmod_fast so it would set "redux" to the comba Montgomery reduction if allowed. This saves quite a few calls and if statements. -- Added etc/mont.c a test of the Montgomery reduction [assuming all else works :-| ] -- Fixed up etc/tune.c to use a wider test range [more appropriate] also added a x86 based addition which uses RDTSC for high precision timing. -- Updated demo/demo.c to remove MPI stuff [won't work anyways], made the tests run for 2 seconds each so its not so insanely slow. Also made the output space delimited [and fixed up various errors] -- Added logs directory, logs/graph.dem which will use gnuplot to make a series of PNG files that go with the pre-made index.html. You have to build [via make timing] and run ltmtest first in the root of the package. -- Fixed a bug in mp_sub and mp_add where "-a - -a" or "-a + a" would produce -0 as the result [obviously invalid]. -- Fixed a bug in mp_rshd. If the count == a.used it should zero/return [instead of shifting] -- Fixed a "off-by-one" bug in mp_mul2d. The initial size check on alloc would be off by one if the residue shifting caused a carry. -- Fixed a bug where s_mp_mul_digs() would not call the Comba based routine if allowed. This made Barrett reduction slower than it had to be. Mar 29th, 2003 v0.16 -- Sped up mp_div by making normalization one shift call -- Sped up mp_mul_2d/mp_div_2d by aliasing pointers :-) -- Cleaned up mp_gcd to use the macros for odd/even detection -- Added comments here and there, mostly there but occasionally here too. Mar 22nd, 2003 v0.15 -- Added series of prime testing routines to lib -- Fixed up etc/tune.c -- Added DR reduction algorithm -- Beefed up the manual more. -- Fixed up demo/demo.c so it doesn't have so many warnings and it does the full series of tests -- Added "pre-gen" directory which will hold a "gen.pl"'ed copy of the entire lib [done at zipup time so its always the latest] -- Added conditional casts for C++ users [boo!] Mar 15th, 2003 v0.14 -- Tons of manual updates -- cleaned up the directory -- added MSVC makefiles -- source changes [that I don't recall] -- Fixed up the lshd/rshd code to use pointer aliasing -- Fixed up the mul_2d and div_2d to not call rshd/lshd unless needed -- Fixed up etc/tune.c a tad -- fixed up demo/demo.c to output comma-delimited results of timing also fixed up timing demo to use a finer granularity for various functions -- fixed up demo/demo.c testing to pause during testing so my Duron won't catch on fire [stays around 31-35C during testing :-)] Feb 13th, 2003 v0.13 -- tons of minor speed-ups in low level add, sub, mul_2 and div_2 which propagate to other functions like mp_invmod, mp_div, etc... -- Sped up mp_exptmod_fast by using new code to find R mod m [e.g. B^n mod m] -- minor fixes Jan 17th, 2003 v0.12 -- re-wrote the majority of the makefile so its more portable and will install via "make install" on most *nix platforms -- Re-packaged all the source as seperate files. Means the library a single file packagage any more. Instead of just adding "bn.c" you have to add libtommath.a -- Renamed "bn.h" to "tommath.h" -- Changes to the manual to reflect all of this -- Used GNU Indent to clean up the source Jan 15th, 2003 v0.11 -- More subtle fixes -- Moved to gentoo linux [hurrah!] so made *nix specific fixes to the make process -- Sped up the montgomery reduction code quite a bit -- fixed up demo so when building timing for the x86 it assumes ELF format now Jan 9th, 2003 v0.10 -- Pekka Riikonen suggested fixes to the radix conversion code. -- Added baseline montgomery and comba montgomery reductions, sped up exptmods [to a point, see bn.h for MONTGOMERY_EXPT_CUTOFF] Jan 6th, 2003 v0.09 -- Updated the manual to reflect recent changes. :-) -- Added Jacobi function (mp_jacobi) to supplement the number theory side of the lib -- Added a Mersenne prime finder demo in ./etc/mersenne.c Jan 2nd, 2003 v0.08 -- Sped up the multipliers by moving the inner loop variables into a smaller scope -- Corrected a bunch of small "warnings" -- Added more comments -- Made "mtest" be able to use /dev/random, /dev/urandom or stdin for RNG data -- Corrected some bugs where error messages were potentially ignored -- add etc/pprime.c program which makes numbers which are provably prime. Jan 1st, 2003 v0.07 -- Removed alot of heap operations from core functions to speed them up -- Added a root finding function [and mp_sqrt macro like from MPI] -- Added more to manual Dec 31st, 2002 v0.06 -- Sped up the s_mp_add, s_mp_sub which inturn sped up mp_invmod, mp_exptmod, etc... -- Cleaned up the header a bit more Dec 30th, 2002 v0.05 -- Builds with MSVC out of the box -- Fixed a bug in mp_invmod w.r.t. even moduli -- Made mp_toradix and mp_read_radix use char instead of unsigned char arrays -- Fixed up exptmod to use fewer multiplications -- Fixed up mp_init_size to use only one heap operation -- Note there is a slight "off-by-one" bug in the library somewhere without the padding (see the source for comment) the library crashes in libtomcrypt. Anyways a reasonable workaround is to pad the numbers which will always correct it since as the numbers grow the padding will still be beyond the end of the number -- Added more to the manual Dec 29th, 2002 v0.04 -- Fixed a memory leak in mp_to_unsigned_bin -- optimized invmod code -- Fixed bug in mp_div -- use exchange instead of copy for results -- added a bit more to the manual Dec 27th, 2002 v0.03 -- Sped up s_mp_mul_high_digs by not computing the carries of the lower digits -- Fixed a bug where mp_set_int wouldn't zero the value first and set the used member. -- fixed a bug in s_mp_mul_high_digs where the limit placed on the result digits was not calculated properly -- fixed bugs in add/sub/mul/sqr_mod functions where if the modulus and dest were the same it wouldn't work -- fixed a bug in mp_mod and mp_mod_d concerning negative inputs -- mp_mul_d didn't preserve sign -- Many many many many fixes -- Works in LibTomCrypt now :-) -- Added iterations to the timing demos... more accurate. -- Tom needs a job. Dec 26th, 2002 v0.02 -- Fixed a few "slips" in the manual. This is "LibTomMath" afterall :-) -- Added mp_cmp_mag, mp_neg, mp_abs and mp_radix_size that were missing. -- Sped up the fast [comba] multipliers more [yahoo!] Dec 25th,2002 v0.01 -- Initial release. Gimme a break. -- Todo list, add details to manual [e.g. algorithms] more comments in code example programs |
Added libtommath/demo/demo.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 | #include <time.h> #ifdef IOWNANATHLON #include <unistd.h> #define SLEEP sleep(4) #else #define SLEEP #endif #include "tommath.h" void ndraw(mp_int * a, char *name) { char buf[16000]; printf("%s: ", name); mp_toradix(a, buf, 10); printf("%s\n", buf); } static void draw(mp_int * a) { ndraw(a, ""); } unsigned long lfsr = 0xAAAAAAAAUL; int lbit(void) { if (lfsr & 0x80000000UL) { lfsr = ((lfsr << 1) ^ 0x8000001BUL) & 0xFFFFFFFFUL; return 1; } else { lfsr <<= 1; return 0; } } int myrng(unsigned char *dst, int len, void *dat) { int x; for (x = 0; x < len; x++) dst[x] = rand() & 0xFF; return len; } char cmd[4096], buf[4096]; int main(void) { mp_int a, b, c, d, e, f; unsigned long expt_n, add_n, sub_n, mul_n, div_n, sqr_n, mul2d_n, div2d_n, gcd_n, lcm_n, inv_n, div2_n, mul2_n, add_d_n, sub_d_n, t; unsigned rr; int i, n, err, cnt, ix, old_kara_m, old_kara_s; mp_digit mp; mp_init(&a); mp_init(&b); mp_init(&c); mp_init(&d); mp_init(&e); mp_init(&f); srand(time(NULL)); #if 0 // test montgomery printf("Testing montgomery...\n"); for (i = 1; i < 10; i++) { printf("Testing digit size: %d\n", i); for (n = 0; n < 1000; n++) { mp_rand(&a, i); a.dp[0] |= 1; // let's see if R is right mp_montgomery_calc_normalization(&b, &a); mp_montgomery_setup(&a, &mp); // now test a random reduction for (ix = 0; ix < 100; ix++) { mp_rand(&c, 1 + abs(rand()) % (2*i)); mp_copy(&c, &d); mp_copy(&c, &e); mp_mod(&d, &a, &d); mp_montgomery_reduce(&c, &a, mp); mp_mulmod(&c, &b, &a, &c); if (mp_cmp(&c, &d) != MP_EQ) { printf("d = e mod a, c = e MOD a\n"); mp_todecimal(&a, buf); printf("a = %s\n", buf); mp_todecimal(&e, buf); printf("e = %s\n", buf); mp_todecimal(&d, buf); printf("d = %s\n", buf); mp_todecimal(&c, buf); printf("c = %s\n", buf); printf("compare no compare!\n"); exit(EXIT_FAILURE); } } } } printf("done\n"); // test mp_get_int printf("Testing: mp_get_int\n"); for (i = 0; i < 1000; ++i) { t = ((unsigned long) rand() * rand() + 1) & 0xFFFFFFFF; mp_set_int(&a, t); if (t != mp_get_int(&a)) { printf("mp_get_int() bad result!\n"); return 1; } } mp_set_int(&a, 0); if (mp_get_int(&a) != 0) { printf("mp_get_int() bad result!\n"); return 1; } mp_set_int(&a, 0xffffffff); if (mp_get_int(&a) != 0xffffffff) { printf("mp_get_int() bad result!\n"); return 1; } // test mp_sqrt printf("Testing: mp_sqrt\n"); for (i = 0; i < 1000; ++i) { printf("%6d\r", i); fflush(stdout); n = (rand() & 15) + 1; mp_rand(&a, n); if (mp_sqrt(&a, &b) != MP_OKAY) { printf("mp_sqrt() error!\n"); return 1; } mp_n_root(&a, 2, &a); if (mp_cmp_mag(&b, &a) != MP_EQ) { printf("mp_sqrt() bad result!\n"); return 1; } } printf("\nTesting: mp_is_square\n"); for (i = 0; i < 1000; ++i) { printf("%6d\r", i); fflush(stdout); /* test mp_is_square false negatives */ n = (rand() & 7) + 1; mp_rand(&a, n); mp_sqr(&a, &a); if (mp_is_square(&a, &n) != MP_OKAY) { printf("fn:mp_is_square() error!\n"); return 1; } if (n == 0) { printf("fn:mp_is_square() bad result!\n"); return 1; } /* test for false positives */ mp_add_d(&a, 1, &a); if (mp_is_square(&a, &n) != MP_OKAY) { printf("fp:mp_is_square() error!\n"); return 1; } if (n == 1) { printf("fp:mp_is_square() bad result!\n"); return 1; } } printf("\n\n"); /* test for size */ for (ix = 10; ix < 128; ix++) { printf("Testing (not safe-prime): %9d bits \r", ix); fflush(stdout); err = mp_prime_random_ex(&a, 8, ix, (rand() & 1) ? LTM_PRIME_2MSB_OFF : LTM_PRIME_2MSB_ON, myrng, NULL); if (err != MP_OKAY) { printf("failed with err code %d\n", err); return EXIT_FAILURE; } if (mp_count_bits(&a) != ix) { printf("Prime is %d not %d bits!!!\n", mp_count_bits(&a), ix); return EXIT_FAILURE; } } for (ix = 16; ix < 128; ix++) { printf("Testing ( safe-prime): %9d bits \r", ix); fflush(stdout); err = mp_prime_random_ex(&a, 8, ix, ((rand() & 1) ? LTM_PRIME_2MSB_OFF : LTM_PRIME_2MSB_ON) | LTM_PRIME_SAFE, myrng, NULL); if (err != MP_OKAY) { printf("failed with err code %d\n", err); return EXIT_FAILURE; } if (mp_count_bits(&a) != ix) { printf("Prime is %d not %d bits!!!\n", mp_count_bits(&a), ix); return EXIT_FAILURE; } /* let's see if it's really a safe prime */ mp_sub_d(&a, 1, &a); mp_div_2(&a, &a); mp_prime_is_prime(&a, 8, &cnt); if (cnt != MP_YES) { printf("sub is not prime!\n"); return EXIT_FAILURE; } } printf("\n\n"); mp_read_radix(&a, "123456", 10); mp_toradix_n(&a, buf, 10, 3); printf("a == %s\n", buf); mp_toradix_n(&a, buf, 10, 4); printf("a == %s\n", buf); mp_toradix_n(&a, buf, 10, 30); printf("a == %s\n", buf); #if 0 for (;;) { fgets(buf, sizeof(buf), stdin); mp_read_radix(&a, buf, 10); mp_prime_next_prime(&a, 5, 1); mp_toradix(&a, buf, 10); printf("%s, %lu\n", buf, a.dp[0] & 3); } #endif /* test mp_cnt_lsb */ printf("testing mp_cnt_lsb...\n"); mp_set(&a, 1); for (ix = 0; ix < 1024; ix++) { if (mp_cnt_lsb(&a) != ix) { printf("Failed at %d, %d\n", ix, mp_cnt_lsb(&a)); return 0; } mp_mul_2(&a, &a); } /* test mp_reduce_2k */ printf("Testing mp_reduce_2k...\n"); for (cnt = 3; cnt <= 128; ++cnt) { mp_digit tmp; mp_2expt(&a, cnt); mp_sub_d(&a, 2, &a); /* a = 2**cnt - 2 */ printf("\nTesting %4d bits", cnt); printf("(%d)", mp_reduce_is_2k(&a)); mp_reduce_2k_setup(&a, &tmp); printf("(%d)", tmp); for (ix = 0; ix < 1000; ix++) { if (!(ix & 127)) { printf("."); fflush(stdout); } mp_rand(&b, (cnt / DIGIT_BIT + 1) * 2); mp_copy(&c, &b); mp_mod(&c, &a, &c); mp_reduce_2k(&b, &a, 2); if (mp_cmp(&c, &b)) { printf("FAILED\n"); exit(0); } } } /* test mp_div_3 */ printf("Testing mp_div_3...\n"); mp_set(&d, 3); for (cnt = 0; cnt < 10000;) { mp_digit r1, r2; if (!(++cnt & 127)) printf("%9d\r", cnt); mp_rand(&a, abs(rand()) % 128 + 1); mp_div(&a, &d, &b, &e); mp_div_3(&a, &c, &r2); if (mp_cmp(&b, &c) || mp_cmp_d(&e, r2)) { printf("\n\nmp_div_3 => Failure\n"); } } printf("\n\nPassed div_3 testing\n"); /* test the DR reduction */ printf("testing mp_dr_reduce...\n"); for (cnt = 2; cnt < 32; cnt++) { printf("%d digit modulus\n", cnt); mp_grow(&a, cnt); mp_zero(&a); for (ix = 1; ix < cnt; ix++) { a.dp[ix] = MP_MASK; } a.used = cnt; a.dp[0] = 3; mp_rand(&b, cnt - 1); mp_copy(&b, &c); rr = 0; do { if (!(rr & 127)) { printf("%9lu\r", rr); fflush(stdout); } mp_sqr(&b, &b); mp_add_d(&b, 1, &b); mp_copy(&b, &c); mp_mod(&b, &a, &b); mp_dr_reduce(&c, &a, (((mp_digit) 1) << DIGIT_BIT) - a.dp[0]); if (mp_cmp(&b, &c) != MP_EQ) { printf("Failed on trial %lu\n", rr); exit(-1); } } while (++rr < 500); printf("Passed DR test for %d digits\n", cnt); } #endif /* test the mp_reduce_2k_l code */ #if 0 #if 0 /* first load P with 2^1024 - 0x2A434 B9FDEC95 D8F9D550 FFFFFFFF FFFFFFFF */ mp_2expt(&a, 1024); mp_read_radix(&b, "2A434B9FDEC95D8F9D550FFFFFFFFFFFFFFFF", 16); mp_sub(&a, &b, &a); #elif 1 /* p = 2^2048 - 0x1 00000000 00000000 00000000 00000000 4945DDBF 8EA2A91D 5776399B B83E188F */ mp_2expt(&a, 2048); mp_read_radix(&b, "1000000000000000000000000000000004945DDBF8EA2A91D5776399BB83E188F", 16); mp_sub(&a, &b, &a); #endif mp_todecimal(&a, buf); printf("p==%s\n", buf); /* now mp_reduce_is_2k_l() should return */ if (mp_reduce_is_2k_l(&a) != 1) { printf("mp_reduce_is_2k_l() return 0, should be 1\n"); return EXIT_FAILURE; } mp_reduce_2k_setup_l(&a, &d); /* now do a million square+1 to see if it varies */ mp_rand(&b, 64); mp_mod(&b, &a, &b); mp_copy(&b, &c); printf("testing mp_reduce_2k_l..."); fflush(stdout); for (cnt = 0; cnt < (1UL << 20); cnt++) { mp_sqr(&b, &b); mp_add_d(&b, 1, &b); mp_reduce_2k_l(&b, &a, &d); mp_sqr(&c, &c); mp_add_d(&c, 1, &c); mp_mod(&c, &a, &c); if (mp_cmp(&b, &c) != MP_EQ) { printf("mp_reduce_2k_l() failed at step %lu\n", cnt); mp_tohex(&b, buf); printf("b == %s\n", buf); mp_tohex(&c, buf); printf("c == %s\n", buf); return EXIT_FAILURE; } } printf("...Passed\n"); #endif div2_n = mul2_n = inv_n = expt_n = lcm_n = gcd_n = add_n = sub_n = mul_n = div_n = sqr_n = mul2d_n = div2d_n = cnt = add_d_n = sub_d_n = 0; /* force KARA and TOOM to enable despite cutoffs */ KARATSUBA_SQR_CUTOFF = KARATSUBA_MUL_CUTOFF = 8; TOOM_SQR_CUTOFF = TOOM_MUL_CUTOFF = 16; for (;;) { /* randomly clear and re-init one variable, this has the affect of triming the alloc space */ switch (abs(rand()) % 7) { case 0: mp_clear(&a); mp_init(&a); break; case 1: mp_clear(&b); mp_init(&b); break; case 2: mp_clear(&c); mp_init(&c); break; case 3: mp_clear(&d); mp_init(&d); break; case 4: mp_clear(&e); mp_init(&e); break; case 5: mp_clear(&f); mp_init(&f); break; case 6: break; /* don't clear any */ } printf ("%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu/%4lu ", add_n, sub_n, mul_n, div_n, sqr_n, mul2d_n, div2d_n, gcd_n, lcm_n, expt_n, inv_n, div2_n, mul2_n, add_d_n, sub_d_n); fgets(cmd, 4095, stdin); cmd[strlen(cmd) - 1] = 0; printf("%s ]\r", cmd); fflush(stdout); if (!strcmp(cmd, "mul2d")) { ++mul2d_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); sscanf(buf, "%d", &rr); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); mp_mul_2d(&a, rr, &a); a.sign = b.sign; if (mp_cmp(&a, &b) != MP_EQ) { printf("mul2d failed, rr == %d\n", rr); draw(&a); draw(&b); return 0; } } else if (!strcmp(cmd, "div2d")) { ++div2d_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); sscanf(buf, "%d", &rr); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); mp_div_2d(&a, rr, &a, &e); a.sign = b.sign; if (a.used == b.used && a.used == 0) { a.sign = b.sign = MP_ZPOS; } if (mp_cmp(&a, &b) != MP_EQ) { printf("div2d failed, rr == %d\n", rr); draw(&a); draw(&b); return 0; } } else if (!strcmp(cmd, "add")) { ++add_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&c, buf, 64); mp_copy(&a, &d); mp_add(&d, &b, &d); if (mp_cmp(&c, &d) != MP_EQ) { printf("add %lu failure!\n", add_n); draw(&a); draw(&b); draw(&c); draw(&d); return 0; } /* test the sign/unsigned storage functions */ rr = mp_signed_bin_size(&c); mp_to_signed_bin(&c, (unsigned char *) cmd); memset(cmd + rr, rand() & 255, sizeof(cmd) - rr); mp_read_signed_bin(&d, (unsigned char *) cmd, rr); if (mp_cmp(&c, &d) != MP_EQ) { printf("mp_signed_bin failure!\n"); draw(&c); draw(&d); return 0; } rr = mp_unsigned_bin_size(&c); mp_to_unsigned_bin(&c, (unsigned char *) cmd); memset(cmd + rr, rand() & 255, sizeof(cmd) - rr); mp_read_unsigned_bin(&d, (unsigned char *) cmd, rr); if (mp_cmp_mag(&c, &d) != MP_EQ) { printf("mp_unsigned_bin failure!\n"); draw(&c); draw(&d); return 0; } } else if (!strcmp(cmd, "sub")) { ++sub_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&c, buf, 64); mp_copy(&a, &d); mp_sub(&d, &b, &d); if (mp_cmp(&c, &d) != MP_EQ) { printf("sub %lu failure!\n", sub_n); draw(&a); draw(&b); draw(&c); draw(&d); return 0; } } else if (!strcmp(cmd, "mul")) { ++mul_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&c, buf, 64); mp_copy(&a, &d); mp_mul(&d, &b, &d); if (mp_cmp(&c, &d) != MP_EQ) { printf("mul %lu failure!\n", mul_n); draw(&a); draw(&b); draw(&c); draw(&d); return 0; } } else if (!strcmp(cmd, "div")) { ++div_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&c, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&d, buf, 64); mp_div(&a, &b, &e, &f); if (mp_cmp(&c, &e) != MP_EQ || mp_cmp(&d, &f) != MP_EQ) { printf("div %lu %d, %d, failure!\n", div_n, mp_cmp(&c, &e), mp_cmp(&d, &f)); draw(&a); draw(&b); draw(&c); draw(&d); draw(&e); draw(&f); return 0; } } else if (!strcmp(cmd, "sqr")) { ++sqr_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); mp_copy(&a, &c); mp_sqr(&c, &c); if (mp_cmp(&b, &c) != MP_EQ) { printf("sqr %lu failure!\n", sqr_n); draw(&a); draw(&b); draw(&c); return 0; } } else if (!strcmp(cmd, "gcd")) { ++gcd_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&c, buf, 64); mp_copy(&a, &d); mp_gcd(&d, &b, &d); d.sign = c.sign; if (mp_cmp(&c, &d) != MP_EQ) { printf("gcd %lu failure!\n", gcd_n); draw(&a); draw(&b); draw(&c); draw(&d); return 0; } } else if (!strcmp(cmd, "lcm")) { ++lcm_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&c, buf, 64); mp_copy(&a, &d); mp_lcm(&d, &b, &d); d.sign = c.sign; if (mp_cmp(&c, &d) != MP_EQ) { printf("lcm %lu failure!\n", lcm_n); draw(&a); draw(&b); draw(&c); draw(&d); return 0; } } else if (!strcmp(cmd, "expt")) { ++expt_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&c, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&d, buf, 64); mp_copy(&a, &e); mp_exptmod(&e, &b, &c, &e); if (mp_cmp(&d, &e) != MP_EQ) { printf("expt %lu failure!\n", expt_n); draw(&a); draw(&b); draw(&c); draw(&d); draw(&e); return 0; } } else if (!strcmp(cmd, "invmod")) { ++inv_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&c, buf, 64); mp_invmod(&a, &b, &d); mp_mulmod(&d, &a, &b, &e); if (mp_cmp_d(&e, 1) != MP_EQ) { printf("inv [wrong value from MPI?!] failure\n"); draw(&a); draw(&b); draw(&c); draw(&d); mp_gcd(&a, &b, &e); draw(&e); return 0; } } else if (!strcmp(cmd, "div2")) { ++div2_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); mp_div_2(&a, &c); if (mp_cmp(&c, &b) != MP_EQ) { printf("div_2 %lu failure\n", div2_n); draw(&a); draw(&b); draw(&c); return 0; } } else if (!strcmp(cmd, "mul2")) { ++mul2_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); mp_mul_2(&a, &c); if (mp_cmp(&c, &b) != MP_EQ) { printf("mul_2 %lu failure\n", mul2_n); draw(&a); draw(&b); draw(&c); return 0; } } else if (!strcmp(cmd, "add_d")) { ++add_d_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); sscanf(buf, "%d", &ix); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); mp_add_d(&a, ix, &c); if (mp_cmp(&b, &c) != MP_EQ) { printf("add_d %lu failure\n", add_d_n); draw(&a); draw(&b); draw(&c); printf("d == %d\n", ix); return 0; } } else if (!strcmp(cmd, "sub_d")) { ++sub_d_n; fgets(buf, 4095, stdin); mp_read_radix(&a, buf, 64); fgets(buf, 4095, stdin); sscanf(buf, "%d", &ix); fgets(buf, 4095, stdin); mp_read_radix(&b, buf, 64); mp_sub_d(&a, ix, &c); if (mp_cmp(&b, &c) != MP_EQ) { printf("sub_d %lu failure\n", sub_d_n); draw(&a); draw(&b); draw(&c); printf("d == %d\n", ix); return 0; } } } return 0; } /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/demo/demo.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/demo/timing.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 | #include <tommath.h> #include <time.h> ulong64 _tt; #ifdef IOWNANATHLON #include <unistd.h> #define SLEEP sleep(4) #else #define SLEEP #endif void ndraw(mp_int * a, char *name) { char buf[4096]; printf("%s: ", name); mp_toradix(a, buf, 64); printf("%s\n", buf); } static void draw(mp_int * a) { ndraw(a, ""); } unsigned long lfsr = 0xAAAAAAAAUL; int lbit(void) { if (lfsr & 0x80000000UL) { lfsr = ((lfsr << 1) ^ 0x8000001BUL) & 0xFFFFFFFFUL; return 1; } else { lfsr <<= 1; return 0; } } /* RDTSC from Scott Duplichan */ static ulong64 TIMFUNC(void) { #if defined __GNUC__ #if defined(__i386__) || defined(__x86_64__) unsigned long long a; __asm__ __volatile__("rdtsc\nmovl %%eax,%0\nmovl %%edx,4+%0\n":: "m"(a):"%eax", "%edx"); return a; #else /* gcc-IA64 version */ unsigned long result; __asm__ __volatile__("mov %0=ar.itc":"=r"(result)::"memory"); while (__builtin_expect((int) result == -1, 0)) __asm__ __volatile__("mov %0=ar.itc":"=r"(result)::"memory"); return result; #endif // Microsoft and Intel Windows compilers #elif defined _M_IX86 __asm rdtsc #elif defined _M_AMD64 return __rdtsc(); #elif defined _M_IA64 #if defined __INTEL_COMPILER #include <ia64intrin.h> #endif return __getReg(3116); #else #error need rdtsc function for this build #endif } #define DO(x) x; x; //#define DO4(x) DO2(x); DO2(x); //#define DO8(x) DO4(x); DO4(x); //#define DO(x) DO8(x); DO8(x); int main(void) { ulong64 tt, gg, CLK_PER_SEC; FILE *log, *logb, *logc, *logd; mp_int a, b, c, d, e, f; int n, cnt, ix, old_kara_m, old_kara_s; unsigned rr; mp_init(&a); mp_init(&b); mp_init(&c); mp_init(&d); mp_init(&e); mp_init(&f); srand(time(NULL)); /* temp. turn off TOOM */ TOOM_MUL_CUTOFF = TOOM_SQR_CUTOFF = 100000; CLK_PER_SEC = TIMFUNC(); sleep(1); CLK_PER_SEC = TIMFUNC() - CLK_PER_SEC; printf("CLK_PER_SEC == %llu\n", CLK_PER_SEC); goto exptmod; log = fopen("logs/add.log", "w"); for (cnt = 8; cnt <= 128; cnt += 8) { SLEEP; mp_rand(&a, cnt); mp_rand(&b, cnt); rr = 0; tt = -1; do { gg = TIMFUNC(); DO(mp_add(&a, &b, &c)); gg = (TIMFUNC() - gg) >> 1; if (tt > gg) tt = gg; } while (++rr < 100000); printf("Adding\t\t%4d-bit => %9llu/sec, %9llu cycles\n", mp_count_bits(&a), CLK_PER_SEC / tt, tt); fprintf(log, "%d %9llu\n", cnt * DIGIT_BIT, tt); fflush(log); } fclose(log); log = fopen("logs/sub.log", "w"); for (cnt = 8; cnt <= 128; cnt += 8) { SLEEP; mp_rand(&a, cnt); mp_rand(&b, cnt); rr = 0; tt = -1; do { gg = TIMFUNC(); DO(mp_sub(&a, &b, &c)); gg = (TIMFUNC() - gg) >> 1; if (tt > gg) tt = gg; } while (++rr < 100000); printf("Subtracting\t\t%4d-bit => %9llu/sec, %9llu cycles\n", mp_count_bits(&a), CLK_PER_SEC / tt, tt); fprintf(log, "%d %9llu\n", cnt * DIGIT_BIT, tt); fflush(log); } fclose(log); /* do mult/square twice, first without karatsuba and second with */ multtest: old_kara_m = KARATSUBA_MUL_CUTOFF; old_kara_s = KARATSUBA_SQR_CUTOFF; for (ix = 0; ix < 2; ix++) { printf("With%s Karatsuba\n", (ix == 0) ? "out" : ""); KARATSUBA_MUL_CUTOFF = (ix == 0) ? 9999 : old_kara_m; KARATSUBA_SQR_CUTOFF = (ix == 0) ? 9999 : old_kara_s; log = fopen((ix == 0) ? "logs/mult.log" : "logs/mult_kara.log", "w"); for (cnt = 4; cnt <= 10240 / DIGIT_BIT; cnt += 2) { SLEEP; mp_rand(&a, cnt); mp_rand(&b, cnt); rr = 0; tt = -1; do { gg = TIMFUNC(); DO(mp_mul(&a, &b, &c)); gg = (TIMFUNC() - gg) >> 1; if (tt > gg) tt = gg; } while (++rr < 100); printf("Multiplying\t%4d-bit => %9llu/sec, %9llu cycles\n", mp_count_bits(&a), CLK_PER_SEC / tt, tt); fprintf(log, "%d %9llu\n", mp_count_bits(&a), tt); fflush(log); } fclose(log); log = fopen((ix == 0) ? "logs/sqr.log" : "logs/sqr_kara.log", "w"); for (cnt = 4; cnt <= 10240 / DIGIT_BIT; cnt += 2) { SLEEP; mp_rand(&a, cnt); rr = 0; tt = -1; do { gg = TIMFUNC(); DO(mp_sqr(&a, &b)); gg = (TIMFUNC() - gg) >> 1; if (tt > gg) tt = gg; } while (++rr < 100); printf("Squaring\t%4d-bit => %9llu/sec, %9llu cycles\n", mp_count_bits(&a), CLK_PER_SEC / tt, tt); fprintf(log, "%d %9llu\n", mp_count_bits(&a), tt); fflush(log); } fclose(log); } exptmod: { char *primes[] = { /* 2K large moduli */ "179769313486231590772930519078902473361797697894230657273430081157732675805500963132708477322407536021120113879871393357658789768814416622492847430639474124377767893424865485276302219601246094119453082952085005768838150682342462881473913110540827237163350510684586239334100047359817950870678242457666208137217", "32317006071311007300714876688669951960444102669715484032130345427524655138867890893197201411522913463688717960921898019494119559150490921095088152386448283120630877367300996091750197750389652106796057638384067568276792218642619756161838094338476170470581645852036305042887575891541065808607552399123930385521914333389668342420684974786564569494856176035326322058077805659331026192708460314150258592864177116725943603718461857357598351152301645904403697613233287231227125684710820209725157101726931323469678542580656697935045997268352998638099733077152121140120031150424541696791951097529546801429027668869927491725169", "1044388881413152506691752710716624382579964249047383780384233483283953907971557456848826811934997558340890106714439262837987573438185793607263236087851365277945956976543709998340361590134383718314428070011855946226376318839397712745672334684344586617496807908705803704071284048740118609114467977783598029006686938976881787785946905630190260940599579453432823469303026696443059025015972399867714215541693835559885291486318237914434496734087811872639496475100189041349008417061675093668333850551032972088269550769983616369411933015213796825837188091833656751221318492846368125550225998300412344784862595674492194617023806505913245610825731835380087608622102834270197698202313169017678006675195485079921636419370285375124784014907159135459982790513399611551794271106831134090584272884279791554849782954323534517065223269061394905987693002122963395687782878948440616007412945674919823050571642377154816321380631045902916136926708342856440730447899971901781465763473223850267253059899795996090799469201774624817718449867455659250178329070473119433165550807568221846571746373296884912819520317457002440926616910874148385078411929804522981857338977648103126085902995208257421855249796721729039744118165938433694823325696642096892124547425283", /* 2K moduli mersenne primes */ "6864797660130609714981900799081393217269435300143305409394463459185543183397656052122559640661454554977296311391480858037121987999716643812574028291115057151", "531137992816767098689588206552468627329593117727031923199444138200403559860852242739162502265229285668889329486246501015346579337652707239409519978766587351943831270835393219031728127", "10407932194664399081925240327364085538615262247266704805319112350403608059673360298012239441732324184842421613954281007791383566248323464908139906605677320762924129509389220345773183349661583550472959420547689811211693677147548478866962501384438260291732348885311160828538416585028255604666224831890918801847068222203140521026698435488732958028878050869736186900714720710555703168729087", "1475979915214180235084898622737381736312066145333169775147771216478570297878078949377407337049389289382748507531496480477281264838760259191814463365330269540496961201113430156902396093989090226259326935025281409614983499388222831448598601834318536230923772641390209490231836446899608210795482963763094236630945410832793769905399982457186322944729636418890623372171723742105636440368218459649632948538696905872650486914434637457507280441823676813517852099348660847172579408422316678097670224011990280170474894487426924742108823536808485072502240519452587542875349976558572670229633962575212637477897785501552646522609988869914013540483809865681250419497686697771007", "259117086013202627776246767922441530941818887553125427303974923161874019266586362086201209516800483406550695241733194177441689509238807017410377709597512042313066624082916353517952311186154862265604547691127595848775610568757931191017711408826252153849035830401185072116424747461823031471398340229288074545677907941037288235820705892351068433882986888616658650280927692080339605869308790500409503709875902119018371991620994002568935113136548829739112656797303241986517250116412703509705427773477972349821676443446668383119322540099648994051790241624056519054483690809616061625743042361721863339415852426431208737266591962061753535748892894599629195183082621860853400937932839420261866586142503251450773096274235376822938649407127700846077124211823080804139298087057504713825264571448379371125032081826126566649084251699453951887789613650248405739378594599444335231188280123660406262468609212150349937584782292237144339628858485938215738821232393687046160677362909315071", "190797007524439073807468042969529173669356994749940177394741882673528979787005053706368049835514900244303495954950709725762186311224148828811920216904542206960744666169364221195289538436845390250168663932838805192055137154390912666527533007309292687539092257043362517857366624699975402375462954490293259233303137330643531556539739921926201438606439020075174723029056838272505051571967594608350063404495977660656269020823960825567012344189908927956646011998057988548630107637380993519826582389781888135705408653045219655801758081251164080554609057468028203308718724654081055323215860189611391296030471108443146745671967766308925858547271507311563765171008318248647110097614890313562856541784154881743146033909602737947385055355960331855614540900081456378659068370317267696980001187750995491090350108417050917991562167972281070161305972518044872048331306383715094854938415738549894606070722584737978176686422134354526989443028353644037187375385397838259511833166416134323695660367676897722287918773420968982326089026150031515424165462111337527431154890666327374921446276833564519776797633875503548665093914556482031482248883127023777039667707976559857333357013727342079099064400455741830654320379350833236245819348824064783585692924881021978332974949906122664421376034687815350484991", /* DR moduli */ "14059105607947488696282932836518693308967803494693489478439861164411992439598399594747002144074658928593502845729752797260025831423419686528151609940203368612079", "101745825697019260773923519755878567461315282017759829107608914364075275235254395622580447400994175578963163918967182013639660669771108475957692810857098847138903161308502419410142185759152435680068435915159402496058513611411688900243039", "736335108039604595805923406147184530889923370574768772191969612422073040099331944991573923112581267542507986451953227192970402893063850485730703075899286013451337291468249027691733891486704001513279827771740183629161065194874727962517148100775228363421083691764065477590823919364012917984605619526140821797602431", "38564998830736521417281865696453025806593491967131023221754800625044118265468851210705360385717536794615180260494208076605798671660719333199513807806252394423283413430106003596332513246682903994829528690198205120921557533726473585751382193953592127439965050261476810842071573684505878854588706623484573925925903505747545471088867712185004135201289273405614415899438276535626346098904241020877974002916168099951885406379295536200413493190419727789712076165162175783", "542189391331696172661670440619180536749994166415993334151601745392193484590296600979602378676624808129613777993466242203025054573692562689251250471628358318743978285860720148446448885701001277560572526947619392551574490839286458454994488665744991822837769918095117129546414124448777033941223565831420390846864429504774477949153794689948747680362212954278693335653935890352619041936727463717926744868338358149568368643403037768649616778526013610493696186055899318268339432671541328195724261329606699831016666359440874843103020666106568222401047720269951530296879490444224546654729111504346660859907296364097126834834235287147", "1487259134814709264092032648525971038895865645148901180585340454985524155135260217788758027400478312256339496385275012465661575576202252063145698732079880294664220579764848767704076761853197216563262660046602703973050798218246170835962005598561669706844469447435461092542265792444947706769615695252256130901271870341005768912974433684521436211263358097522726462083917939091760026658925757076733484173202927141441492573799914240222628795405623953109131594523623353044898339481494120112723445689647986475279242446083151413667587008191682564376412347964146113898565886683139407005941383669325997475076910488086663256335689181157957571445067490187939553165903773554290260531009121879044170766615232300936675369451260747671432073394867530820527479172464106442450727640226503746586340279816318821395210726268291535648506190714616083163403189943334431056876038286530365757187367147446004855912033137386225053275419626102417236133948503", "1095121115716677802856811290392395128588168592409109494900178008967955253005183831872715423151551999734857184538199864469605657805519106717529655044054833197687459782636297255219742994736751541815269727940751860670268774903340296040006114013971309257028332849679096824800250742691718610670812374272414086863715763724622797509437062518082383056050144624962776302147890521249477060215148275163688301275847155316042279405557632639366066847442861422164832655874655824221577849928863023018366835675399949740429332468186340518172487073360822220449055340582568461568645259954873303616953776393853174845132081121976327462740354930744487429617202585015510744298530101547706821590188733515880733527449780963163909830077616357506845523215289297624086914545378511082534229620116563260168494523906566709418166011112754529766183554579321224940951177394088465596712620076240067370589036924024728375076210477267488679008016579588696191194060127319035195370137160936882402244399699172017835144537488486396906144217720028992863941288217185353914991583400421682751000603596655790990815525126154394344641336397793791497068253936771017031980867706707490224041075826337383538651825493679503771934836094655802776331664261631740148281763487765852746577808019633679", /* generic unrestricted moduli */ "17933601194860113372237070562165128350027320072176844226673287945873370751245439587792371960615073855669274087805055507977323024886880985062002853331424203", "2893527720709661239493896562339544088620375736490408468011883030469939904368086092336458298221245707898933583190713188177399401852627749210994595974791782790253946539043962213027074922559572312141181787434278708783207966459019479487", "347743159439876626079252796797422223177535447388206607607181663903045907591201940478223621722118173270898487582987137708656414344685816179420855160986340457973820182883508387588163122354089264395604796675278966117567294812714812796820596564876450716066283126720010859041484786529056457896367683122960411136319", "47266428956356393164697365098120418976400602706072312735924071745438532218237979333351774907308168340693326687317443721193266215155735814510792148768576498491199122744351399489453533553203833318691678263241941706256996197460424029012419012634671862283532342656309677173602509498417976091509154360039893165037637034737020327399910409885798185771003505320583967737293415979917317338985837385734747478364242020380416892056650841470869294527543597349250299539682430605173321029026555546832473048600327036845781970289288898317888427517364945316709081173840186150794397479045034008257793436817683392375274635794835245695887", "436463808505957768574894870394349739623346440601945961161254440072143298152040105676491048248110146278752857839930515766167441407021501229924721335644557342265864606569000117714935185566842453630868849121480179691838399545644365571106757731317371758557990781880691336695584799313313687287468894148823761785582982549586183756806449017542622267874275103877481475534991201849912222670102069951687572917937634467778042874315463238062009202992087620963771759666448266532858079402669920025224220613419441069718482837399612644978839925207109870840278194042158748845445131729137117098529028886770063736487420613144045836803985635654192482395882603511950547826439092832800532152534003936926017612446606135655146445620623395788978726744728503058670046885876251527122350275750995227", "11424167473351836398078306042624362277956429440521137061889702611766348760692206243140413411077394583180726863277012016602279290144126785129569474909173584789822341986742719230331946072730319555984484911716797058875905400999504305877245849119687509023232790273637466821052576859232452982061831009770786031785669030271542286603956118755585683996118896215213488875253101894663403069677745948305893849505434201763745232895780711972432011344857521691017896316861403206449421332243658855453435784006517202894181640562433575390821384210960117518650374602256601091379644034244332285065935413233557998331562749140202965844219336298970011513882564935538704289446968322281451907487362046511461221329799897350993370560697505809686438782036235372137015731304779072430260986460269894522159103008260495503005267165927542949439526272736586626709581721032189532726389643625590680105784844246152702670169304203783072275089194754889511973916207", "1214855636816562637502584060163403830270705000634713483015101384881871978446801224798536155406895823305035467591632531067547890948695117172076954220727075688048751022421198712032848890056357845974246560748347918630050853933697792254955890439720297560693579400297062396904306270145886830719309296352765295712183040773146419022875165382778007040109957609739589875590885701126197906063620133954893216612678838507540777138437797705602453719559017633986486649523611975865005712371194067612263330335590526176087004421363598470302731349138773205901447704682181517904064735636518462452242791676541725292378925568296858010151852326316777511935037531017413910506921922450666933202278489024521263798482237150056835746454842662048692127173834433089016107854491097456725016327709663199738238442164843147132789153725513257167915555162094970853584447993125488607696008169807374736711297007473812256272245489405898470297178738029484459690836250560495461579533254473316340608217876781986188705928270735695752830825527963838355419762516246028680280988020401914551825487349990306976304093109384451438813251211051597392127491464898797406789175453067960072008590614886532333015881171367104445044718144312416815712216611576221546455968770801413440778423979", NULL }; log = fopen("logs/expt.log", "w"); logb = fopen("logs/expt_dr.log", "w"); logc = fopen("logs/expt_2k.log", "w"); logd = fopen("logs/expt_2kl.log", "w"); for (n = 0; primes[n]; n++) { SLEEP; mp_read_radix(&a, primes[n], 10); mp_zero(&b); for (rr = 0; rr < (unsigned) mp_count_bits(&a); rr++) { mp_mul_2(&b, &b); b.dp[0] |= lbit(); b.used += 1; } mp_sub_d(&a, 1, &c); mp_mod(&b, &c, &b); mp_set(&c, 3); rr = 0; tt = -1; do { gg = TIMFUNC(); DO(mp_exptmod(&c, &b, &a, &d)); gg = (TIMFUNC() - gg) >> 1; if (tt > gg) tt = gg; } while (++rr < 10); mp_sub_d(&a, 1, &e); mp_sub(&e, &b, &b); mp_exptmod(&c, &b, &a, &e); /* c^(p-1-b) mod a */ mp_mulmod(&e, &d, &a, &d); /* c^b * c^(p-1-b) == c^p-1 == 1 */ if (mp_cmp_d(&d, 1)) { printf("Different (%d)!!!\n", mp_count_bits(&a)); draw(&d); exit(0); } printf("Exponentiating\t%4d-bit => %9llu/sec, %9llu cycles\n", mp_count_bits(&a), CLK_PER_SEC / tt, tt); fprintf(n < 4 ? logd : (n < 9) ? logc : (n < 16) ? logb : log, "%d %9llu\n", mp_count_bits(&a), tt); } } fclose(log); fclose(logb); fclose(logc); fclose(logd); log = fopen("logs/invmod.log", "w"); for (cnt = 4; cnt <= 128; cnt += 4) { SLEEP; mp_rand(&a, cnt); mp_rand(&b, cnt); do { mp_add_d(&b, 1, &b); mp_gcd(&a, &b, &c); } while (mp_cmp_d(&c, 1) != MP_EQ); rr = 0; tt = -1; do { gg = TIMFUNC(); DO(mp_invmod(&b, &a, &c)); gg = (TIMFUNC() - gg) >> 1; if (tt > gg) tt = gg; } while (++rr < 1000); mp_mulmod(&b, &c, &a, &d); if (mp_cmp_d(&d, 1) != MP_EQ) { printf("Failed to invert\n"); return 0; } printf("Inverting mod\t%4d-bit => %9llu/sec, %9llu cycles\n", mp_count_bits(&a), CLK_PER_SEC / tt, tt); fprintf(log, "%d %9llu\n", cnt * DIGIT_BIT, tt); } fclose(log); return 0; } /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/demo/timing.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/dep.pl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #!/usr/bin/perl # # Walk through source, add labels and make classes # #use strict; my %deplist; #open class file and write preamble open(CLASS, ">tommath_class.h") or die "Couldn't open tommath_class.h for writing\n"; print CLASS "#if !(defined(LTM1) && defined(LTM2) && defined(LTM3))\n#if defined(LTM2)\n#define LTM3\n#endif\n#if defined(LTM1)\n#define LTM2\n#endif\n#define LTM1\n\n#if defined(LTM_ALL)\n"; foreach my $filename (glob "bn*.c") { my $define = $filename; print "Processing $filename\n"; # convert filename to upper case so we can use it as a define $define =~ tr/[a-z]/[A-Z]/; $define =~ tr/\./_/; print CLASS "#define $define\n"; # now copy text and apply #ifdef as required my $apply = 0; open(SRC, "<$filename"); open(OUT, ">tmp"); # first line will be the #ifdef my $line = <SRC>; if ($line =~ /include/) { print OUT $line; } else { print OUT "#include <tommath.h>\n#ifdef $define\n$line"; $apply = 1; } while (<SRC>) { if (!($_ =~ /tommath\.h/)) { print OUT $_; } } if ($apply == 1) { print OUT "#endif\n"; } close SRC; close OUT; unlink($filename); rename("tmp", $filename); } print CLASS "#endif\n\n"; # now do classes foreach my $filename (glob "bn*.c") { open(SRC, "<$filename") or die "Can't open source file!\n"; # convert filename to upper case so we can use it as a define $filename =~ tr/[a-z]/[A-Z]/; $filename =~ tr/\./_/; print CLASS "#if defined($filename)\n"; my $list = $filename; # scan for mp_* and make classes while (<SRC>) { my $line = $_; while ($line =~ m/(fast_)*(s_)*mp\_[a-z_0-9]*/) { $line = $'; # now $& is the match, we want to skip over LTM keywords like # mp_int, mp_word, mp_digit if (!($& eq "mp_digit") && !($& eq "mp_word") && !($& eq "mp_int")) { my $a = $&; $a =~ tr/[a-z]/[A-Z]/; $a = "BN_" . $a . "_C"; if (!($list =~ /$a/)) { print CLASS " #define $a\n"; } $list = $list . "," . $a; } } } @deplist{$filename} = $list; print CLASS "#endif\n\n"; close SRC; } print CLASS "#ifdef LTM3\n#define LTM_LAST\n#endif\n#include <tommath_superclass.h>\n#include <tommath_class.h>\n#else\n#define LTM_LAST\n#endif\n"; close CLASS; #now let's make a cool call graph... open(OUT,">callgraph.txt"); $indent = 0; foreach (keys %deplist) { $list = ""; draw_func(@deplist{$_}); print OUT "\n\n"; } close(OUT); sub draw_func() { my @funcs = split(",", $_[0]); if ($list =~ /@funcs[0]/) { return; } else { $list = $list . @funcs[0]; } if ($indent == 0) { } elsif ($indent >= 1) { print OUT "| " x ($indent - 1) . "+--->"; } print OUT @funcs[0] . "\n"; shift @funcs; my $temp = $list; foreach my $i (@funcs) { ++$indent; draw_func(@deplist{$i}); --$indent; } $list = $temp; } |
Added libtommath/etc/2kprime.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | /* Makes safe primes of a 2k nature */ #include <tommath.h> #include <time.h> int sizes[] = {256, 512, 768, 1024, 1536, 2048, 3072, 4096}; int main(void) { char buf[2000]; int x, y; mp_int q, p; FILE *out; clock_t t1; mp_digit z; mp_init_multi(&q, &p, NULL); out = fopen("2kprime.1", "w"); for (x = 0; x < (int)(sizeof(sizes) / sizeof(sizes[0])); x++) { top: mp_2expt(&q, sizes[x]); mp_add_d(&q, 3, &q); z = -3; t1 = clock(); for(;;) { mp_sub_d(&q, 4, &q); z += 4; if (z > MP_MASK) { printf("No primes of size %d found\n", sizes[x]); break; } if (clock() - t1 > CLOCKS_PER_SEC) { printf("."); fflush(stdout); // sleep((clock() - t1 + CLOCKS_PER_SEC/2)/CLOCKS_PER_SEC); t1 = clock(); } /* quick test on q */ mp_prime_is_prime(&q, 1, &y); if (y == 0) { continue; } /* find (q-1)/2 */ mp_sub_d(&q, 1, &p); mp_div_2(&p, &p); mp_prime_is_prime(&p, 3, &y); if (y == 0) { continue; } /* test on q */ mp_prime_is_prime(&q, 3, &y); if (y == 0) { continue; } break; } if (y == 0) { ++sizes[x]; goto top; } mp_toradix(&q, buf, 10); printf("\n\n%d-bits (k = %lu) = %s\n", sizes[x], z, buf); fprintf(out, "%d-bits (k = %lu) = %s\n", sizes[x], z, buf); fflush(out); } return 0; } /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/2kprime.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/etc/drprime.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | /* Makes safe primes of a DR nature */ #include <tommath.h> int sizes[] = { 1+256/DIGIT_BIT, 1+512/DIGIT_BIT, 1+768/DIGIT_BIT, 1+1024/DIGIT_BIT, 1+2048/DIGIT_BIT, 1+4096/DIGIT_BIT }; int main(void) { int res, x, y; char buf[4096]; FILE *out; mp_int a, b; mp_init(&a); mp_init(&b); out = fopen("drprimes.txt", "w"); for (x = 0; x < (int)(sizeof(sizes)/sizeof(sizes[0])); x++) { top: printf("Seeking a %d-bit safe prime\n", sizes[x] * DIGIT_BIT); mp_grow(&a, sizes[x]); mp_zero(&a); for (y = 1; y < sizes[x]; y++) { a.dp[y] = MP_MASK; } /* make a DR modulus */ a.dp[0] = -1; a.used = sizes[x]; /* now loop */ res = 0; for (;;) { a.dp[0] += 4; if (a.dp[0] >= MP_MASK) break; mp_prime_is_prime(&a, 1, &res); if (res == 0) continue; printf("."); fflush(stdout); mp_sub_d(&a, 1, &b); mp_div_2(&b, &b); mp_prime_is_prime(&b, 3, &res); if (res == 0) continue; mp_prime_is_prime(&a, 3, &res); if (res == 1) break; } if (res != 1) { printf("Error not DR modulus\n"); sizes[x] += 1; goto top; } else { mp_toradix(&a, buf, 10); printf("\n\np == %s\n\n", buf); fprintf(out, "%d-bit prime:\np == %s\n\n", mp_count_bits(&a), buf); fflush(out); } } fclose(out); mp_clear(&a); mp_clear(&b); return 0; } /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/drprime.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/etc/makefile.icc.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | CC = icc CFLAGS += -I../ # optimize for SPEED # # -mcpu= can be pentium, pentiumpro (covers PII through PIII) or pentium4 # -ax? specifies make code specifically for ? but compatible with IA-32 # -x? specifies compile solely for ? [not specifically IA-32 compatible] # # where ? is # K - PIII # W - first P4 [Williamette] # N - P4 Northwood # P - P4 Prescott # B - Blend of P4 and PM [mobile] # # Default to just generic max opts CFLAGS += -O3 -xP -ip # default lib name (requires install with root) # LIBNAME=-ltommath # libname when you can't install the lib with install LIBNAME=../libtommath.a #provable primes pprime: pprime.o $(CC) pprime.o $(LIBNAME) -o pprime # portable [well requires clock()] tuning app tune: tune.o $(CC) tune.o $(LIBNAME) -o tune # same app but using RDTSC for higher precision [requires 80586+], coff based gcc installs [e.g. ming, cygwin, djgpp] tune86: tune.c nasm -f coff timer.asm $(CC) -DX86_TIMER $(CFLAGS) tune.c timer.o $(LIBNAME) -o tune86 # for cygwin tune86c: tune.c nasm -f gnuwin32 timer.asm $(CC) -DX86_TIMER $(CFLAGS) tune.c timer.o $(LIBNAME) -o tune86 #make tune86 for linux or any ELF format tune86l: tune.c nasm -f elf -DUSE_ELF timer.asm $(CC) -DX86_TIMER $(CFLAGS) tune.c timer.o $(LIBNAME) -o tune86l # spits out mersenne primes mersenne: mersenne.o $(CC) mersenne.o $(LIBNAME) -o mersenne # fines DR safe primes for the given config drprime: drprime.o $(CC) drprime.o $(LIBNAME) -o drprime # fines 2k safe primes for the given config 2kprime: 2kprime.o $(CC) 2kprime.o $(LIBNAME) -o 2kprime mont: mont.o $(CC) mont.o $(LIBNAME) -o mont clean: rm -f *.log *.o *.obj *.exe pprime tune mersenne drprime tune86 tune86l mont 2kprime pprime.dat *.il |
Added libtommath/etc/mersenne.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | /* Finds Mersenne primes using the Lucas-Lehmer test * * Tom St Denis, [email protected] */ #include <time.h> #include <tommath.h> int is_mersenne (long s, int *pp) { mp_int n, u; int res, k; *pp = 0; if ((res = mp_init (&n)) != MP_OKAY) { return res; } if ((res = mp_init (&u)) != MP_OKAY) { goto LBL_N; } /* n = 2^s - 1 */ if ((res = mp_2expt(&n, s)) != MP_OKAY) { goto LBL_MU; } if ((res = mp_sub_d (&n, 1, &n)) != MP_OKAY) { goto LBL_MU; } /* set u=4 */ mp_set (&u, 4); /* for k=1 to s-2 do */ for (k = 1; k <= s - 2; k++) { /* u = u^2 - 2 mod n */ if ((res = mp_sqr (&u, &u)) != MP_OKAY) { goto LBL_MU; } if ((res = mp_sub_d (&u, 2, &u)) != MP_OKAY) { goto LBL_MU; } /* make sure u is positive */ while (u.sign == MP_NEG) { if ((res = mp_add (&u, &n, &u)) != MP_OKAY) { goto LBL_MU; } } /* reduce */ if ((res = mp_reduce_2k (&u, &n, 1)) != MP_OKAY) { goto LBL_MU; } } /* if u == 0 then its prime */ if (mp_iszero (&u) == 1) { mp_prime_is_prime(&n, 8, pp); if (*pp != 1) printf("FAILURE\n"); } res = MP_OKAY; LBL_MU:mp_clear (&u); LBL_N:mp_clear (&n); return res; } /* square root of a long < 65536 */ long i_sqrt (long x) { long x1, x2; x2 = 16; do { x1 = x2; x2 = x1 - ((x1 * x1) - x) / (2 * x1); } while (x1 != x2); if (x1 * x1 > x) { --x1; } return x1; } /* is the long prime by brute force */ int isprime (long k) { long y, z; y = i_sqrt (k); for (z = 2; z <= y; z++) { if ((k % z) == 0) return 0; } return 1; } int main (void) { int pp; long k; clock_t tt; k = 3; for (;;) { /* start time */ tt = clock (); /* test if 2^k - 1 is prime */ if (is_mersenne (k, &pp) != MP_OKAY) { printf ("Whoa error\n"); return -1; } if (pp == 1) { /* count time */ tt = clock () - tt; /* display if prime */ printf ("2^%-5ld - 1 is prime, test took %ld ticks\n", k, tt); } /* goto next odd exponent */ k += 2; /* but make sure its prime */ while (isprime (k) == 0) { k += 2; } } return 0; } /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/mersenne.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/etc/mont.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | /* tests the montgomery routines */ #include <tommath.h> int main(void) { mp_int modulus, R, p, pp; mp_digit mp; long x, y; srand(time(NULL)); mp_init_multi(&modulus, &R, &p, &pp, NULL); /* loop through various sizes */ for (x = 4; x < 256; x++) { printf("DIGITS == %3ld...", x); fflush(stdout); /* make up the odd modulus */ mp_rand(&modulus, x); modulus.dp[0] |= 1; /* now find the R value */ mp_montgomery_calc_normalization(&R, &modulus); mp_montgomery_setup(&modulus, &mp); /* now run through a bunch tests */ for (y = 0; y < 1000; y++) { mp_rand(&p, x/2); /* p = random */ mp_mul(&p, &R, &pp); /* pp = R * p */ mp_montgomery_reduce(&pp, &modulus, mp); /* should be equal to p */ if (mp_cmp(&pp, &p) != MP_EQ) { printf("FAILURE!\n"); exit(-1); } } printf("PASSED\n"); } return 0; } /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/mont.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/etc/pprime.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 | /* Generates provable primes * * See http://iahu.ca:8080/papers/pp.pdf for more info. * * Tom St Denis, [email protected], http://tom.iahu.ca */ #include <time.h> #include "tommath.h" int n_prime; FILE *primes; /* fast square root */ static mp_digit i_sqrt (mp_word x) { mp_word x1, x2; x2 = x; do { x1 = x2; x2 = x1 - ((x1 * x1) - x) / (2 * x1); } while (x1 != x2); if (x1 * x1 > x) { --x1; } return x1; } /* generates a prime digit */ static void gen_prime (void) { mp_digit r, x, y, next; FILE *out; out = fopen("pprime.dat", "wb"); /* write first set of primes */ r = 3; fwrite(&r, 1, sizeof(mp_digit), out); r = 5; fwrite(&r, 1, sizeof(mp_digit), out); r = 7; fwrite(&r, 1, sizeof(mp_digit), out); r = 11; fwrite(&r, 1, sizeof(mp_digit), out); r = 13; fwrite(&r, 1, sizeof(mp_digit), out); r = 17; fwrite(&r, 1, sizeof(mp_digit), out); r = 19; fwrite(&r, 1, sizeof(mp_digit), out); r = 23; fwrite(&r, 1, sizeof(mp_digit), out); r = 29; fwrite(&r, 1, sizeof(mp_digit), out); r = 31; fwrite(&r, 1, sizeof(mp_digit), out); /* get square root, since if 'r' is composite its factors must be < than this */ y = i_sqrt (r); next = (y + 1) * (y + 1); for (;;) { do { r += 2; /* next candidate */ r &= MP_MASK; if (r < 31) break; /* update sqrt ? */ if (next <= r) { ++y; next = (y + 1) * (y + 1); } /* loop if divisible by 3,5,7,11,13,17,19,23,29 */ if ((r % 3) == 0) { x = 0; continue; } if ((r % 5) == 0) { x = 0; continue; } if ((r % 7) == 0) { x = 0; continue; } if ((r % 11) == 0) { x = 0; continue; } if ((r % 13) == 0) { x = 0; continue; } if ((r % 17) == 0) { x = 0; continue; } if ((r % 19) == 0) { x = 0; continue; } if ((r % 23) == 0) { x = 0; continue; } if ((r % 29) == 0) { x = 0; continue; } /* now check if r is divisible by x + k={1,7,11,13,17,19,23,29} */ for (x = 30; x <= y; x += 30) { if ((r % (x + 1)) == 0) { x = 0; break; } if ((r % (x + 7)) == 0) { x = 0; break; } if ((r % (x + 11)) == 0) { x = 0; break; } if ((r % (x + 13)) == 0) { x = 0; break; } if ((r % (x + 17)) == 0) { x = 0; break; } if ((r % (x + 19)) == 0) { x = 0; break; } if ((r % (x + 23)) == 0) { x = 0; break; } if ((r % (x + 29)) == 0) { x = 0; break; } } } while (x == 0); if (r > 31) { fwrite(&r, 1, sizeof(mp_digit), out); printf("%9d\r", r); fflush(stdout); } if (r < 31) break; } fclose(out); } void load_tab(void) { primes = fopen("pprime.dat", "rb"); if (primes == NULL) { gen_prime(); primes = fopen("pprime.dat", "rb"); } fseek(primes, 0, SEEK_END); n_prime = ftell(primes) / sizeof(mp_digit); } mp_digit prime_digit(void) { int n; mp_digit d; n = abs(rand()) % n_prime; fseek(primes, n * sizeof(mp_digit), SEEK_SET); fread(&d, 1, sizeof(mp_digit), primes); return d; } /* makes a prime of at least k bits */ int pprime (int k, int li, mp_int * p, mp_int * q) { mp_int a, b, c, n, x, y, z, v; int res, ii; static const mp_digit bases[] = { 2, 3, 5, 7, 11, 13, 17, 19 }; /* single digit ? */ if (k <= (int) DIGIT_BIT) { mp_set (p, prime_digit ()); return MP_OKAY; } if ((res = mp_init (&c)) != MP_OKAY) { return res; } if ((res = mp_init (&v)) != MP_OKAY) { goto LBL_C; } /* product of first 50 primes */ if ((res = mp_read_radix (&v, "19078266889580195013601891820992757757219839668357012055907516904309700014933909014729740190", 10)) != MP_OKAY) { goto LBL_V; } if ((res = mp_init (&a)) != MP_OKAY) { goto LBL_V; } /* set the prime */ mp_set (&a, prime_digit ()); if ((res = mp_init (&b)) != MP_OKAY) { goto LBL_A; } if ((res = mp_init (&n)) != MP_OKAY) { goto LBL_B; } if ((res = mp_init (&x)) != MP_OKAY) { goto LBL_N; } if ((res = mp_init (&y)) != MP_OKAY) { goto LBL_X; } if ((res = mp_init (&z)) != MP_OKAY) { goto LBL_Y; } /* now loop making the single digit */ while (mp_count_bits (&a) < k) { fprintf (stderr, "prime has %4d bits left\r", k - mp_count_bits (&a)); fflush (stderr); top: mp_set (&b, prime_digit ()); /* now compute z = a * b * 2 */ if ((res = mp_mul (&a, &b, &z)) != MP_OKAY) { /* z = a * b */ goto LBL_Z; } if ((res = mp_copy (&z, &c)) != MP_OKAY) { /* c = a * b */ goto LBL_Z; } if ((res = mp_mul_2 (&z, &z)) != MP_OKAY) { /* z = 2 * a * b */ goto LBL_Z; } /* n = z + 1 */ if ((res = mp_add_d (&z, 1, &n)) != MP_OKAY) { /* n = z + 1 */ goto LBL_Z; } /* check (n, v) == 1 */ if ((res = mp_gcd (&n, &v, &y)) != MP_OKAY) { /* y = (n, v) */ goto LBL_Z; } if (mp_cmp_d (&y, 1) != MP_EQ) goto top; /* now try base x=bases[ii] */ for (ii = 0; ii < li; ii++) { mp_set (&x, bases[ii]); /* compute x^a mod n */ if ((res = mp_exptmod (&x, &a, &n, &y)) != MP_OKAY) { /* y = x^a mod n */ goto LBL_Z; } /* if y == 1 loop */ if (mp_cmp_d (&y, 1) == MP_EQ) continue; /* now x^2a mod n */ if ((res = mp_sqrmod (&y, &n, &y)) != MP_OKAY) { /* y = x^2a mod n */ goto LBL_Z; } if (mp_cmp_d (&y, 1) == MP_EQ) continue; /* compute x^b mod n */ if ((res = mp_exptmod (&x, &b, &n, &y)) != MP_OKAY) { /* y = x^b mod n */ goto LBL_Z; } /* if y == 1 loop */ if (mp_cmp_d (&y, 1) == MP_EQ) continue; /* now x^2b mod n */ if ((res = mp_sqrmod (&y, &n, &y)) != MP_OKAY) { /* y = x^2b mod n */ goto LBL_Z; } if (mp_cmp_d (&y, 1) == MP_EQ) continue; /* compute x^c mod n == x^ab mod n */ if ((res = mp_exptmod (&x, &c, &n, &y)) != MP_OKAY) { /* y = x^ab mod n */ goto LBL_Z; } /* if y == 1 loop */ if (mp_cmp_d (&y, 1) == MP_EQ) continue; /* now compute (x^c mod n)^2 */ if ((res = mp_sqrmod (&y, &n, &y)) != MP_OKAY) { /* y = x^2ab mod n */ goto LBL_Z; } /* y should be 1 */ if (mp_cmp_d (&y, 1) != MP_EQ) continue; break; } /* no bases worked? */ if (ii == li) goto top; { char buf[4096]; mp_toradix(&n, buf, 10); printf("Certificate of primality for:\n%s\n\n", buf); mp_toradix(&a, buf, 10); printf("A == \n%s\n\n", buf); mp_toradix(&b, buf, 10); printf("B == \n%s\n\nG == %d\n", buf, bases[ii]); printf("----------------------------------------------------------------\n"); } /* a = n */ mp_copy (&n, &a); } /* get q to be the order of the large prime subgroup */ mp_sub_d (&n, 1, q); mp_div_2 (q, q); mp_div (q, &b, q, NULL); mp_exch (&n, p); res = MP_OKAY; LBL_Z:mp_clear (&z); LBL_Y:mp_clear (&y); LBL_X:mp_clear (&x); LBL_N:mp_clear (&n); LBL_B:mp_clear (&b); LBL_A:mp_clear (&a); LBL_V:mp_clear (&v); LBL_C:mp_clear (&c); return res; } int main (void) { mp_int p, q; char buf[4096]; int k, li; clock_t t1; srand (time (NULL)); load_tab(); printf ("Enter # of bits: \n"); fgets (buf, sizeof (buf), stdin); sscanf (buf, "%d", &k); printf ("Enter number of bases to try (1 to 8):\n"); fgets (buf, sizeof (buf), stdin); sscanf (buf, "%d", &li); mp_init (&p); mp_init (&q); t1 = clock (); pprime (k, li, &p, &q); t1 = clock () - t1; printf ("\n\nTook %ld ticks, %d bits\n", t1, mp_count_bits (&p)); mp_toradix (&p, buf, 10); printf ("P == %s\n", buf); mp_toradix (&q, buf, 10); printf ("Q == %s\n", buf); return 0; } /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/pprime.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/etc/timer.asm.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; x86 timer in NASM ; ; Tom St Denis, [email protected] [bits 32] [section .data] time dd 0, 0 [section .text] %ifdef USE_ELF [global t_start] t_start: %else [global _t_start] _t_start: %endif push edx push eax rdtsc mov [time+0],edx mov [time+4],eax pop eax pop edx ret %ifdef USE_ELF [global t_read] t_read: %else [global _t_read] _t_read: %endif rdtsc sub eax,[time+4] sbb edx,[time+0] ret |
Added libtommath/etc/tune.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | /* Tune the Karatsuba parameters * * Tom St Denis, [email protected] */ #include <tommath.h> #include <time.h> /* how many times todo each size mult. Depends on your computer. For slow computers * this can be low like 5 or 10. For fast [re: Athlon] should be 25 - 50 or so */ #define TIMES (1UL<<14UL) /* RDTSC from Scott Duplichan */ static ulong64 TIMFUNC (void) { #if defined __GNUC__ #if defined(__i386__) || defined(__x86_64__) unsigned long long a; __asm__ __volatile__ ("rdtsc\nmovl %%eax,%0\nmovl %%edx,4+%0\n"::"m"(a):"%eax","%edx"); return a; #else /* gcc-IA64 version */ unsigned long result; __asm__ __volatile__("mov %0=ar.itc" : "=r"(result) :: "memory"); while (__builtin_expect ((int) result == -1, 0)) __asm__ __volatile__("mov %0=ar.itc" : "=r"(result) :: "memory"); return result; #endif // Microsoft and Intel Windows compilers #elif defined _M_IX86 __asm rdtsc #elif defined _M_AMD64 return __rdtsc (); #elif defined _M_IA64 #if defined __INTEL_COMPILER #include <ia64intrin.h> #endif return __getReg (3116); #else #error need rdtsc function for this build #endif } #ifndef X86_TIMER /* generic ISO C timer */ ulong64 LBL_T; void t_start(void) { LBL_T = TIMFUNC(); } ulong64 t_read(void) { return TIMFUNC() - LBL_T; } #else extern void t_start(void); extern ulong64 t_read(void); #endif ulong64 time_mult(int size, int s) { unsigned long x; mp_int a, b, c; ulong64 t1; mp_init (&a); mp_init (&b); mp_init (&c); mp_rand (&a, size); mp_rand (&b, size); if (s == 1) { KARATSUBA_MUL_CUTOFF = size; } else { KARATSUBA_MUL_CUTOFF = 100000; } t_start(); for (x = 0; x < TIMES; x++) { mp_mul(&a,&b,&c); } t1 = t_read(); mp_clear (&a); mp_clear (&b); mp_clear (&c); return t1; } ulong64 time_sqr(int size, int s) { unsigned long x; mp_int a, b; ulong64 t1; mp_init (&a); mp_init (&b); mp_rand (&a, size); if (s == 1) { KARATSUBA_SQR_CUTOFF = size; } else { KARATSUBA_SQR_CUTOFF = 100000; } t_start(); for (x = 0; x < TIMES; x++) { mp_sqr(&a,&b); } t1 = t_read(); mp_clear (&a); mp_clear (&b); return t1; } int main (void) { ulong64 t1, t2; int x, y; for (x = 8; ; x += 2) { t1 = time_mult(x, 0); t2 = time_mult(x, 1); printf("%d: %9llu %9llu, %9llu\n", x, t1, t2, t2 - t1); if (t2 < t1) break; } y = x; for (x = 8; ; x += 2) { t1 = time_sqr(x, 0); t2 = time_sqr(x, 1); printf("%d: %9llu %9llu, %9llu\n", x, t1, t2, t2 - t1); if (t2 < t1) break; } printf("KARATSUBA_MUL_CUTOFF = %d\n", y); printf("KARATSUBA_SQR_CUTOFF = %d\n", x); return 0; } /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/etc/tune.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/logs/README.
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | To use the pretty graphs you have to first build/run the ltmtest from the root directory of the package. Todo this type make timing ; ltmtest in the root. It will run for a while [about ten minutes on most PCs] and produce a series of .log files in logs/. After doing that run "gnuplot graphs.dem" to make the PNGs. If you managed todo that all so far just open index.html to view them all :-) Have fun Tom |
Added libtommath/logs/add.log.
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | 480 87 960 111 1440 135 1920 159 2400 200 2880 224 3360 248 3840 272 4320 296 4800 320 5280 344 5760 368 6240 392 6720 416 7200 440 7680 464 |
Added libtommath/logs/addsub.png.
cannot compute difference between binary files
Added libtommath/logs/expt.log.
> > > > > > > | 1 2 3 4 5 6 7 | 513 1435869 769 3544970 1025 7791638 2049 46902238 2561 85334899 3073 141451412 4097 308770310 |
Added libtommath/logs/expt.png.
cannot compute difference between binary files
Added libtommath/logs/expt_2k.log.
> > > > > | 1 2 3 4 5 | 607 2109225 1279 10148314 2203 34126877 3217 82716424 4253 161569606 |
Added libtommath/logs/expt_2kl.log.
> > > > | 1 2 3 4 | 1024 7705271 2048 34286851 4096 165207491 521 1618631 |
Added libtommath/logs/expt_dr.log.
> > > > > > > | 1 2 3 4 5 6 7 | 532 1928550 784 3763908 1036 7564221 1540 16566059 2072 32283784 3080 79851565 4116 157843530 |
Added libtommath/logs/index.html.
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | <html> <head> <title>LibTomMath Log Plots</title> </head> <body> <h1>Addition and Subtraction</h1> <center><img src=addsub.png></center> <hr> <h1>Multipliers</h1> <center><img src=mult.png></center> <hr> <h1>Exptmod</h1> <center><img src=expt.png></center> <hr> <h1>Modular Inverse</h1> <center><img src=invmod.png></center> <hr> </body> </html> /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/logs/index.html,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/logs/invmod.png.
cannot compute difference between binary files
Added libtommath/logs/mult.log.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 271 555 390 855 508 1161 631 1605 749 2117 871 2687 991 3329 1108 4084 1231 4786 1351 5624 1470 6392 1586 7364 1710 8218 1830 9255 1951 10217 2067 11461 2191 12463 2308 13677 2430 14800 2551 16232 2671 17460 2791 18899 2902 20247 3028 21902 3151 23240 3267 24927 3391 26441 3511 28277 3631 29838 3749 31751 3869 33673 3989 35431 4111 37518 4231 39426 4349 41504 4471 43567 4591 45786 4711 47876 4831 50299 4951 52427 5071 54785 5189 57241 5307 59730 5431 62194 5551 64761 5670 67322 5789 70073 5907 72663 6030 75437 6151 78242 6268 81202 6389 83948 6509 86985 6631 89903 6747 93184 6869 96044 6991 99286 7109 102395 7229 105917 7351 108940 7470 112490 7589 115702 7711 119508 7831 122632 7951 126410 8071 129808 8190 133895 8311 137146 8431 141218 8549 144732 8667 149131 8790 152462 8911 156754 9030 160479 9149 165138 9271 168601 9391 173185 9511 176988 9627 181976 9751 185539 9870 190388 9991 194335 10110 199605 10228 203298 |
Added libtommath/logs/mult.png.
cannot compute difference between binary files
Added libtommath/logs/mult_kara.log.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 271 560 391 870 511 1159 631 1605 750 2111 871 2737 991 3361 1111 4054 1231 4778 1351 5600 1471 6404 1591 7323 1710 8255 1831 9239 1948 10257 2070 11397 2190 12531 2308 13665 2429 14870 2550 16175 2671 17539 2787 18879 2911 20350 3031 21807 3150 23415 3270 24897 3388 26567 3511 28205 3627 30076 3751 31744 3869 33657 3991 35425 4111 37522 4229 39363 4351 41503 4470 43491 4590 45827 4711 47795 4828 50166 4951 52318 5070 54911 5191 57036 5308 58237 5431 60248 5551 62678 5671 64786 5791 67294 5908 69343 6031 71607 6151 74166 6271 76590 6391 78734 6511 81175 6631 83742 6750 86403 6868 88873 6990 91150 7110 94211 7228 96922 7351 99445 7469 102216 7589 104968 7711 108113 7827 110758 7950 113714 8071 116511 8186 119643 8310 122679 8425 125581 8551 128715 8669 131778 8788 135116 8910 138138 9031 141628 9148 144754 9268 148367 9391 151551 9511 155033 9631 158652 9751 162125 9871 165248 9988 168627 10111 172427 10231 176412 |
Added libtommath/logs/sqr.log.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 265 562 389 882 509 1207 631 1572 750 1990 859 2433 991 2894 1109 3555 1230 4228 1350 5018 1471 5805 1591 6579 1709 7415 1829 8329 1949 9225 2071 10139 2188 11239 2309 12178 2431 13212 2551 14294 2671 15551 2791 16512 2911 17718 3030 18876 3150 20259 3270 21374 3391 22650 3511 23948 3631 25493 3750 26756 3870 28225 3989 29705 4110 31409 4230 32834 4351 34327 4471 35818 4591 37636 4711 39228 4830 40868 4949 42393 5070 44541 5191 46269 5310 48162 5429 49728 5548 51985 5671 53948 5791 55885 5910 57584 6031 60082 6150 62239 6270 64309 6390 66014 6511 68766 6631 71012 6750 73172 6871 74952 6991 77909 7111 80371 7231 82666 7351 84531 7469 87698 7589 90318 7711 225384 7830 232428 7950 240009 8070 246522 8190 253662 8310 260961 8431 269253 8549 275743 8671 283769 8789 290811 8911 300034 9030 306873 9149 315085 9270 323944 9390 332390 9508 337519 9631 348986 9749 356904 9871 367013 9989 373831 10108 381033 10230 393475 |
Added libtommath/logs/sqr_kara.log.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 271 560 388 878 511 1179 629 1625 751 1988 871 2423 989 2896 1111 3561 1231 4209 1350 5015 1470 5804 1591 6556 1709 7420 1831 8263 1951 9173 2070 10153 2191 11229 2310 12167 2431 13211 2550 14309 2671 15524 2788 16525 2910 17712 3028 18822 3148 20220 3271 21343 3391 22652 3511 23944 3630 25485 3750 26778 3868 28201 3990 29653 4111 31393 4225 32841 4350 34328 4471 35786 4590 37652 4711 39245 4830 40876 4951 42433 5068 44547 5191 46321 5311 48140 5430 49727 5550 52034 5671 53954 5791 55921 5908 57597 6031 60084 6148 62226 6270 64295 6390 66045 6511 68779 6629 71003 6751 73169 6871 74992 6991 77895 7110 80376 7231 82628 7351 84468 7470 87664 7591 90284 7711 91352 7828 93995 7950 96276 8071 98691 8190 101256 8308 103631 8431 105222 8550 108343 8671 110281 8787 112764 8911 115397 9031 117690 9151 120266 9271 122715 9391 124624 9510 127937 9630 130313 9750 132914 9871 136129 9991 138517 10108 141525 10231 144225 |
Added libtommath/logs/sub.log.
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | 480 94 960 116 1440 140 1920 164 2400 205 2880 229 3360 253 3840 277 4320 299 4800 321 5280 345 5760 371 6240 395 6720 419 7200 441 7680 465 |
Added libtommath/makefile.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | #Makefile for GCC # #Tom St Denis #version of library VERSION=0.36 CFLAGS += -I./ -Wall -W -Wshadow -Wsign-compare ifndef IGNORE_SPEED #for speed CFLAGS += -O3 -funroll-loops #for size #CFLAGS += -Os #x86 optimizations [should be valid for any GCC install though] CFLAGS += -fomit-frame-pointer #debug #CFLAGS += -g3 endif #install as this user ifndef INSTALL_GROUP GROUP=wheel else GROUP=$(INSTALL_GROUP) endif ifndef INSTALL_USER USER=root else USER=$(INSTALL_USER) endif default: libtommath.a #default files to install ifndef LIBNAME LIBNAME=libtommath.a endif HEADERS=tommath.h tommath_class.h tommath_superclass.h #LIBPATH-The directory for libtommath to be installed to. #INCPATH-The directory to install the header files for libtommath. #DATAPATH-The directory to install the pdf docs. DESTDIR= LIBPATH=/usr/lib INCPATH=/usr/include DATAPATH=/usr/share/doc/libtommath/pdf OBJECTS=bncore.o bn_mp_init.o bn_mp_clear.o bn_mp_exch.o bn_mp_grow.o bn_mp_shrink.o \ bn_mp_clamp.o bn_mp_zero.o bn_mp_set.o bn_mp_set_int.o bn_mp_init_size.o bn_mp_copy.o \ bn_mp_init_copy.o bn_mp_abs.o bn_mp_neg.o bn_mp_cmp_mag.o bn_mp_cmp.o bn_mp_cmp_d.o \ bn_mp_rshd.o bn_mp_lshd.o bn_mp_mod_2d.o bn_mp_div_2d.o bn_mp_mul_2d.o bn_mp_div_2.o \ bn_mp_mul_2.o bn_s_mp_add.o bn_s_mp_sub.o bn_fast_s_mp_mul_digs.o bn_s_mp_mul_digs.o \ bn_fast_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_s_mp_sqr.o \ bn_mp_add.o bn_mp_sub.o bn_mp_karatsuba_mul.o bn_mp_mul.o bn_mp_karatsuba_sqr.o \ bn_mp_sqr.o bn_mp_div.o bn_mp_mod.o bn_mp_add_d.o bn_mp_sub_d.o bn_mp_mul_d.o \ bn_mp_div_d.o bn_mp_mod_d.o bn_mp_expt_d.o bn_mp_addmod.o bn_mp_submod.o \ bn_mp_mulmod.o bn_mp_sqrmod.o bn_mp_gcd.o bn_mp_lcm.o bn_fast_mp_invmod.o bn_mp_invmod.o \ bn_mp_reduce.o bn_mp_montgomery_setup.o bn_fast_mp_montgomery_reduce.o bn_mp_montgomery_reduce.o \ bn_mp_exptmod_fast.o bn_mp_exptmod.o bn_mp_2expt.o bn_mp_n_root.o bn_mp_jacobi.o bn_reverse.o \ bn_mp_count_bits.o bn_mp_read_unsigned_bin.o bn_mp_read_signed_bin.o bn_mp_to_unsigned_bin.o \ bn_mp_to_signed_bin.o bn_mp_unsigned_bin_size.o bn_mp_signed_bin_size.o \ bn_mp_xor.o bn_mp_and.o bn_mp_or.o bn_mp_rand.o bn_mp_montgomery_calc_normalization.o \ bn_mp_prime_is_divisible.o bn_prime_tab.o bn_mp_prime_fermat.o bn_mp_prime_miller_rabin.o \ bn_mp_prime_is_prime.o bn_mp_prime_next_prime.o bn_mp_dr_reduce.o \ bn_mp_dr_is_modulus.o bn_mp_dr_setup.o bn_mp_reduce_setup.o \ bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_div_3.o bn_s_mp_exptmod.o \ bn_mp_reduce_2k.o bn_mp_reduce_is_2k.o bn_mp_reduce_2k_setup.o \ bn_mp_reduce_2k_l.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_2k_setup_l.o \ bn_mp_radix_smap.o bn_mp_read_radix.o bn_mp_toradix.o bn_mp_radix_size.o \ bn_mp_fread.o bn_mp_fwrite.o bn_mp_cnt_lsb.o bn_error.o \ bn_mp_init_multi.o bn_mp_clear_multi.o bn_mp_exteuclid.o bn_mp_toradix_n.o \ bn_mp_prime_random_ex.o bn_mp_get_int.o bn_mp_sqrt.o bn_mp_is_square.o bn_mp_init_set.o \ bn_mp_init_set_int.o bn_mp_invmod_slow.o bn_mp_prime_rabin_miller_trials.o \ bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin_n.o $(LIBNAME): $(OBJECTS) $(AR) $(ARFLAGS) $@ $(OBJECTS) ranlib $@ #make a profiled library (takes a while!!!) # # This will build the library with profile generation # then run the test demo and rebuild the library. # # So far I've seen improvements in the MP math profiled: make CFLAGS="$(CFLAGS) -fprofile-arcs -DTESTING" timing ./ltmtest rm -f *.a *.o ltmtest make CFLAGS="$(CFLAGS) -fbranch-probabilities" #make a single object profiled library profiled_single: perl gen.pl $(CC) $(CFLAGS) -fprofile-arcs -DTESTING -c mpi.c -o mpi.o $(CC) $(CFLAGS) -DTESTING -DTIMER demo/timing.c mpi.o -o ltmtest ./ltmtest rm -f *.o ltmtest $(CC) $(CFLAGS) -fbranch-probabilities -DTESTING -c mpi.c -o mpi.o $(AR) $(ARFLAGS) $(LIBNAME) mpi.o ranlib $(LIBNAME) install: $(LIBNAME) install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(LIBPATH) install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(INCPATH) install -g $(GROUP) -o $(USER) $(LIBNAME) $(DESTDIR)$(LIBPATH) install -g $(GROUP) -o $(USER) $(HEADERS) $(DESTDIR)$(INCPATH) test: $(LIBNAME) demo/demo.o $(CC) $(CFLAGS) demo/demo.o $(LIBNAME) -o test mtest: test cd mtest ; $(CC) $(CFLAGS) mtest.c -o mtest timing: $(LIBNAME) $(CC) $(CFLAGS) -DTIMER demo/timing.c $(LIBNAME) -o ltmtest # makes the LTM book DVI file, requires tetex, perl and makeindex [part of tetex I think] docdvi: tommath.src cd pics ; make echo "hello" > tommath.ind perl booker.pl latex tommath > /dev/null latex tommath > /dev/null makeindex tommath latex tommath > /dev/null # poster, makes the single page PDF poster poster: poster.tex pdflatex poster rm -f poster.aux poster.log # makes the LTM book PDF file, requires tetex, cleans up the LaTeX temp files docs: docdvi dvipdf tommath rm -f tommath.log tommath.aux tommath.dvi tommath.idx tommath.toc tommath.lof tommath.ind tommath.ilg cd pics ; make clean #LTM user manual mandvi: bn.tex echo "hello" > bn.ind latex bn > /dev/null latex bn > /dev/null makeindex bn latex bn > /dev/null #LTM user manual [pdf] manual: mandvi pdflatex bn >/dev/null rm -f bn.aux bn.dvi bn.log bn.idx bn.lof bn.out bn.toc pretty: perl pretty.build clean: rm -f *.bat *.pdf *.o *.a *.obj *.lib *.exe *.dll etclib/*.o demo/demo.o test ltmtest mpitest mtest/mtest mtest/mtest.exe \ *.idx *.toc *.log *.aux *.dvi *.lof *.ind *.ilg *.ps *.log *.s mpi.c *.da *.dyn *.dpi tommath.tex `find -type f | grep [~] | xargs` *.lo *.la rm -rf .libs cd etc ; make clean cd pics ; make clean #zipup the project (take that!) no_oops: clean cd .. ; cvs commit echo Scanning for scratch/dirty files find . -type f | grep -v CVS | xargs -n 1 bash mess.sh zipup: clean manual poster docs perl gen.pl ; mv mpi.c pre_gen/ ; \ cd .. ; rm -rf ltm* libtommath-$(VERSION) ; mkdir libtommath-$(VERSION) ; \ cp -R ./libtommath/* ./libtommath-$(VERSION)/ ; \ tar -c libtommath-$(VERSION)/* | bzip2 -9vvc > ltm-$(VERSION).tar.bz2 ; \ zip -9 -r ltm-$(VERSION).zip libtommath-$(VERSION)/* |
Added libtommath/makefile.bcc.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # # Borland C++Builder Makefile (makefile.bcc) # LIB = tlib CC = bcc32 CFLAGS = -c -O2 -I. OBJECTS=bncore.obj bn_mp_init.obj bn_mp_clear.obj bn_mp_exch.obj bn_mp_grow.obj bn_mp_shrink.obj \ bn_mp_clamp.obj bn_mp_zero.obj bn_mp_set.obj bn_mp_set_int.obj bn_mp_init_size.obj bn_mp_copy.obj \ bn_mp_init_copy.obj bn_mp_abs.obj bn_mp_neg.obj bn_mp_cmp_mag.obj bn_mp_cmp.obj bn_mp_cmp_d.obj \ bn_mp_rshd.obj bn_mp_lshd.obj bn_mp_mod_2d.obj bn_mp_div_2d.obj bn_mp_mul_2d.obj bn_mp_div_2.obj \ bn_mp_mul_2.obj bn_s_mp_add.obj bn_s_mp_sub.obj bn_fast_s_mp_mul_digs.obj bn_s_mp_mul_digs.obj \ bn_fast_s_mp_mul_high_digs.obj bn_s_mp_mul_high_digs.obj bn_fast_s_mp_sqr.obj bn_s_mp_sqr.obj \ bn_mp_add.obj bn_mp_sub.obj bn_mp_karatsuba_mul.obj bn_mp_mul.obj bn_mp_karatsuba_sqr.obj \ bn_mp_sqr.obj bn_mp_div.obj bn_mp_mod.obj bn_mp_add_d.obj bn_mp_sub_d.obj bn_mp_mul_d.obj \ bn_mp_div_d.obj bn_mp_mod_d.obj bn_mp_expt_d.obj bn_mp_addmod.obj bn_mp_submod.obj \ bn_mp_mulmod.obj bn_mp_sqrmod.obj bn_mp_gcd.obj bn_mp_lcm.obj bn_fast_mp_invmod.obj bn_mp_invmod.obj \ bn_mp_reduce.obj bn_mp_montgomery_setup.obj bn_fast_mp_montgomery_reduce.obj bn_mp_montgomery_reduce.obj \ bn_mp_exptmod_fast.obj bn_mp_exptmod.obj bn_mp_2expt.obj bn_mp_n_root.obj bn_mp_jacobi.obj bn_reverse.obj \ bn_mp_count_bits.obj bn_mp_read_unsigned_bin.obj bn_mp_read_signed_bin.obj bn_mp_to_unsigned_bin.obj \ bn_mp_to_signed_bin.obj bn_mp_unsigned_bin_size.obj bn_mp_signed_bin_size.obj \ bn_mp_xor.obj bn_mp_and.obj bn_mp_or.obj bn_mp_rand.obj bn_mp_montgomery_calc_normalization.obj \ bn_mp_prime_is_divisible.obj bn_prime_tab.obj bn_mp_prime_fermat.obj bn_mp_prime_miller_rabin.obj \ bn_mp_prime_is_prime.obj bn_mp_prime_next_prime.obj bn_mp_dr_reduce.obj \ bn_mp_dr_is_modulus.obj bn_mp_dr_setup.obj bn_mp_reduce_setup.obj \ bn_mp_toom_mul.obj bn_mp_toom_sqr.obj bn_mp_div_3.obj bn_s_mp_exptmod.obj \ bn_mp_reduce_2k.obj bn_mp_reduce_is_2k.obj bn_mp_reduce_2k_setup.obj \ bn_mp_reduce_2k_l.obj bn_mp_reduce_is_2k_l.obj bn_mp_reduce_2k_setup_l.obj \ bn_mp_radix_smap.obj bn_mp_read_radix.obj bn_mp_toradix.obj bn_mp_radix_size.obj \ bn_mp_fread.obj bn_mp_fwrite.obj bn_mp_cnt_lsb.obj bn_error.obj \ bn_mp_init_multi.obj bn_mp_clear_multi.obj bn_mp_exteuclid.obj bn_mp_toradix_n.obj \ bn_mp_prime_random_ex.obj bn_mp_get_int.obj bn_mp_sqrt.obj bn_mp_is_square.obj \ bn_mp_init_set.obj bn_mp_init_set_int.obj bn_mp_invmod_slow.obj bn_mp_prime_rabin_miller_trials.obj \ bn_mp_to_signed_bin_n.obj bn_mp_to_unsigned_bin_n.obj TARGET = libtommath.lib $(TARGET): $(OBJECTS) .c.objbjbjbj: $(CC) $(CFLAGS) $< $(LIB) $(TARGET) -+$@ |
Added libtommath/makefile.cygwin_dll.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #Makefile for Cygwin-GCC # #This makefile will build a Windows DLL [doesn't require cygwin to run] in the file #libtommath.dll. The import library is in libtommath.dll.a. Remember to add #"-Wl,--enable-auto-import" to your client build to avoid the auto-import warnings # #Tom St Denis CFLAGS += -I./ -Wall -W -Wshadow -O3 -funroll-loops -mno-cygwin #x86 optimizations [should be valid for any GCC install though] CFLAGS += -fomit-frame-pointer default: windll OBJECTS=bncore.o bn_mp_init.o bn_mp_clear.o bn_mp_exch.o bn_mp_grow.o bn_mp_shrink.o \ bn_mp_clamp.o bn_mp_zero.o bn_mp_set.o bn_mp_set_int.o bn_mp_init_size.o bn_mp_copy.o \ bn_mp_init_copy.o bn_mp_abs.o bn_mp_neg.o bn_mp_cmp_mag.o bn_mp_cmp.o bn_mp_cmp_d.o \ bn_mp_rshd.o bn_mp_lshd.o bn_mp_mod_2d.o bn_mp_div_2d.o bn_mp_mul_2d.o bn_mp_div_2.o \ bn_mp_mul_2.o bn_s_mp_add.o bn_s_mp_sub.o bn_fast_s_mp_mul_digs.o bn_s_mp_mul_digs.o \ bn_fast_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_s_mp_sqr.o \ bn_mp_add.o bn_mp_sub.o bn_mp_karatsuba_mul.o bn_mp_mul.o bn_mp_karatsuba_sqr.o \ bn_mp_sqr.o bn_mp_div.o bn_mp_mod.o bn_mp_add_d.o bn_mp_sub_d.o bn_mp_mul_d.o \ bn_mp_div_d.o bn_mp_mod_d.o bn_mp_expt_d.o bn_mp_addmod.o bn_mp_submod.o \ bn_mp_mulmod.o bn_mp_sqrmod.o bn_mp_gcd.o bn_mp_lcm.o bn_fast_mp_invmod.o bn_mp_invmod.o \ bn_mp_reduce.o bn_mp_montgomery_setup.o bn_fast_mp_montgomery_reduce.o bn_mp_montgomery_reduce.o \ bn_mp_exptmod_fast.o bn_mp_exptmod.o bn_mp_2expt.o bn_mp_n_root.o bn_mp_jacobi.o bn_reverse.o \ bn_mp_count_bits.o bn_mp_read_unsigned_bin.o bn_mp_read_signed_bin.o bn_mp_to_unsigned_bin.o \ bn_mp_to_signed_bin.o bn_mp_unsigned_bin_size.o bn_mp_signed_bin_size.o \ bn_mp_xor.o bn_mp_and.o bn_mp_or.o bn_mp_rand.o bn_mp_montgomery_calc_normalization.o \ bn_mp_prime_is_divisible.o bn_prime_tab.o bn_mp_prime_fermat.o bn_mp_prime_miller_rabin.o \ bn_mp_prime_is_prime.o bn_mp_prime_next_prime.o bn_mp_dr_reduce.o \ bn_mp_dr_is_modulus.o bn_mp_dr_setup.o bn_mp_reduce_setup.o \ bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_div_3.o bn_s_mp_exptmod.o \ bn_mp_reduce_2k.o bn_mp_reduce_is_2k.o bn_mp_reduce_2k_setup.o \ bn_mp_reduce_2k_l.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_2k_setup_l.o \ bn_mp_radix_smap.o bn_mp_read_radix.o bn_mp_toradix.o bn_mp_radix_size.o \ bn_mp_fread.o bn_mp_fwrite.o bn_mp_cnt_lsb.o bn_error.o \ bn_mp_init_multi.o bn_mp_clear_multi.o bn_mp_exteuclid.o bn_mp_toradix_n.o \ bn_mp_prime_random_ex.o bn_mp_get_int.o bn_mp_sqrt.o bn_mp_is_square.o bn_mp_init_set.o \ bn_mp_init_set_int.o bn_mp_invmod_slow.o bn_mp_prime_rabin_miller_trials.o \ bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin_n.o # make a Windows DLL via Cygwin windll: $(OBJECTS) gcc -mno-cygwin -mdll -o libtommath.dll -Wl,--out-implib=libtommath.dll.a -Wl,--export-all-symbols *.o ranlib libtommath.dll.a # build the test program using the windows DLL test: $(OBJECTS) windll gcc $(CFLAGS) demo/demo.c libtommath.dll.a -Wl,--enable-auto-import -o test -s cd mtest ; $(CC) -O3 -fomit-frame-pointer -funroll-loops mtest.c -o mtest -s /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/makefile.cygwin_dll,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/makefile.icc.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #Makefile for ICC # #Tom St Denis CC=icc CFLAGS += -I./ # optimize for SPEED # # -mcpu= can be pentium, pentiumpro (covers PII through PIII) or pentium4 # -ax? specifies make code specifically for ? but compatible with IA-32 # -x? specifies compile solely for ? [not specifically IA-32 compatible] # # where ? is # K - PIII # W - first P4 [Williamette] # N - P4 Northwood # P - P4 Prescott # B - Blend of P4 and PM [mobile] # # Default to just generic max opts CFLAGS += -O3 -xP -ip #install as this user USER=root GROUP=root default: libtommath.a #default files to install LIBNAME=libtommath.a HEADERS=tommath.h #LIBPATH-The directory for libtomcrypt to be installed to. #INCPATH-The directory to install the header files for libtommath. #DATAPATH-The directory to install the pdf docs. DESTDIR= LIBPATH=/usr/lib INCPATH=/usr/include DATAPATH=/usr/share/doc/libtommath/pdf OBJECTS=bncore.o bn_mp_init.o bn_mp_clear.o bn_mp_exch.o bn_mp_grow.o bn_mp_shrink.o \ bn_mp_clamp.o bn_mp_zero.o bn_mp_set.o bn_mp_set_int.o bn_mp_init_size.o bn_mp_copy.o \ bn_mp_init_copy.o bn_mp_abs.o bn_mp_neg.o bn_mp_cmp_mag.o bn_mp_cmp.o bn_mp_cmp_d.o \ bn_mp_rshd.o bn_mp_lshd.o bn_mp_mod_2d.o bn_mp_div_2d.o bn_mp_mul_2d.o bn_mp_div_2.o \ bn_mp_mul_2.o bn_s_mp_add.o bn_s_mp_sub.o bn_fast_s_mp_mul_digs.o bn_s_mp_mul_digs.o \ bn_fast_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_s_mp_sqr.o \ bn_mp_add.o bn_mp_sub.o bn_mp_karatsuba_mul.o bn_mp_mul.o bn_mp_karatsuba_sqr.o \ bn_mp_sqr.o bn_mp_div.o bn_mp_mod.o bn_mp_add_d.o bn_mp_sub_d.o bn_mp_mul_d.o \ bn_mp_div_d.o bn_mp_mod_d.o bn_mp_expt_d.o bn_mp_addmod.o bn_mp_submod.o \ bn_mp_mulmod.o bn_mp_sqrmod.o bn_mp_gcd.o bn_mp_lcm.o bn_fast_mp_invmod.o bn_mp_invmod.o \ bn_mp_reduce.o bn_mp_montgomery_setup.o bn_fast_mp_montgomery_reduce.o bn_mp_montgomery_reduce.o \ bn_mp_exptmod_fast.o bn_mp_exptmod.o bn_mp_2expt.o bn_mp_n_root.o bn_mp_jacobi.o bn_reverse.o \ bn_mp_count_bits.o bn_mp_read_unsigned_bin.o bn_mp_read_signed_bin.o bn_mp_to_unsigned_bin.o \ bn_mp_to_signed_bin.o bn_mp_unsigned_bin_size.o bn_mp_signed_bin_size.o \ bn_mp_xor.o bn_mp_and.o bn_mp_or.o bn_mp_rand.o bn_mp_montgomery_calc_normalization.o \ bn_mp_prime_is_divisible.o bn_prime_tab.o bn_mp_prime_fermat.o bn_mp_prime_miller_rabin.o \ bn_mp_prime_is_prime.o bn_mp_prime_next_prime.o bn_mp_dr_reduce.o \ bn_mp_dr_is_modulus.o bn_mp_dr_setup.o bn_mp_reduce_setup.o \ bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_div_3.o bn_s_mp_exptmod.o \ bn_mp_reduce_2k.o bn_mp_reduce_is_2k.o bn_mp_reduce_2k_setup.o \ bn_mp_reduce_2k_l.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_2k_setup_l.o \ bn_mp_radix_smap.o bn_mp_read_radix.o bn_mp_toradix.o bn_mp_radix_size.o \ bn_mp_fread.o bn_mp_fwrite.o bn_mp_cnt_lsb.o bn_error.o \ bn_mp_init_multi.o bn_mp_clear_multi.o bn_mp_exteuclid.o bn_mp_toradix_n.o \ bn_mp_prime_random_ex.o bn_mp_get_int.o bn_mp_sqrt.o bn_mp_is_square.o bn_mp_init_set.o \ bn_mp_init_set_int.o bn_mp_invmod_slow.o bn_mp_prime_rabin_miller_trials.o \ bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin_n.o libtommath.a: $(OBJECTS) $(AR) $(ARFLAGS) libtommath.a $(OBJECTS) ranlib libtommath.a #make a profiled library (takes a while!!!) # # This will build the library with profile generation # then run the test demo and rebuild the library. # # So far I've seen improvements in the MP math profiled: make -f makefile.icc CFLAGS="$(CFLAGS) -prof_gen -DTESTING" timing ./ltmtest rm -f *.a *.o ltmtest make -f makefile.icc CFLAGS="$(CFLAGS) -prof_use" #make a single object profiled library profiled_single: perl gen.pl $(CC) $(CFLAGS) -prof_gen -DTESTING -c mpi.c -o mpi.o $(CC) $(CFLAGS) -DTESTING -DTIMER demo/demo.c mpi.o -o ltmtest ./ltmtest rm -f *.o ltmtest $(CC) $(CFLAGS) -prof_use -ip -DTESTING -c mpi.c -o mpi.o $(AR) $(ARFLAGS) libtommath.a mpi.o ranlib libtommath.a install: libtommath.a install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(LIBPATH) install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(INCPATH) install -g $(GROUP) -o $(USER) $(LIBNAME) $(DESTDIR)$(LIBPATH) install -g $(GROUP) -o $(USER) $(HEADERS) $(DESTDIR)$(INCPATH) test: libtommath.a demo/demo.o $(CC) demo/demo.o libtommath.a -o test mtest: test cd mtest ; $(CC) $(CFLAGS) mtest.c -o mtest timing: libtommath.a $(CC) $(CFLAGS) -DTIMER demo/timing.c libtommath.a -o ltmtest clean: rm -f *.bat *.pdf *.o *.a *.obj *.lib *.exe *.dll etclib/*.o demo/demo.o test ltmtest mpitest mtest/mtest mtest/mtest.exe \ *.idx *.toc *.log *.aux *.dvi *.lof *.ind *.ilg *.ps *.log *.s mpi.c *.il etc/*.il *.dyn cd etc ; make clean cd pics ; make clean |
Added libtommath/makefile.msvc.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #MSVC Makefile # #Tom St Denis CFLAGS = /I. /Ox /DWIN32 /W3 /Fo$@ default: library OBJECTS=bncore.obj bn_mp_init.obj bn_mp_clear.obj bn_mp_exch.obj bn_mp_grow.obj bn_mp_shrink.obj \ bn_mp_clamp.obj bn_mp_zero.obj bn_mp_set.obj bn_mp_set_int.obj bn_mp_init_size.obj bn_mp_copy.obj \ bn_mp_init_copy.obj bn_mp_abs.obj bn_mp_neg.obj bn_mp_cmp_mag.obj bn_mp_cmp.obj bn_mp_cmp_d.obj \ bn_mp_rshd.obj bn_mp_lshd.obj bn_mp_mod_2d.obj bn_mp_div_2d.obj bn_mp_mul_2d.obj bn_mp_div_2.obj \ bn_mp_mul_2.obj bn_s_mp_add.obj bn_s_mp_sub.obj bn_fast_s_mp_mul_digs.obj bn_s_mp_mul_digs.obj \ bn_fast_s_mp_mul_high_digs.obj bn_s_mp_mul_high_digs.obj bn_fast_s_mp_sqr.obj bn_s_mp_sqr.obj \ bn_mp_add.obj bn_mp_sub.obj bn_mp_karatsuba_mul.obj bn_mp_mul.obj bn_mp_karatsuba_sqr.obj \ bn_mp_sqr.obj bn_mp_div.obj bn_mp_mod.obj bn_mp_add_d.obj bn_mp_sub_d.obj bn_mp_mul_d.obj \ bn_mp_div_d.obj bn_mp_mod_d.obj bn_mp_expt_d.obj bn_mp_addmod.obj bn_mp_submod.obj \ bn_mp_mulmod.obj bn_mp_sqrmod.obj bn_mp_gcd.obj bn_mp_lcm.obj bn_fast_mp_invmod.obj bn_mp_invmod.obj \ bn_mp_reduce.obj bn_mp_montgomery_setup.obj bn_fast_mp_montgomery_reduce.obj bn_mp_montgomery_reduce.obj \ bn_mp_exptmod_fast.obj bn_mp_exptmod.obj bn_mp_2expt.obj bn_mp_n_root.obj bn_mp_jacobi.obj bn_reverse.obj \ bn_mp_count_bits.obj bn_mp_read_unsigned_bin.obj bn_mp_read_signed_bin.obj bn_mp_to_unsigned_bin.obj \ bn_mp_to_signed_bin.obj bn_mp_unsigned_bin_size.obj bn_mp_signed_bin_size.obj \ bn_mp_xor.obj bn_mp_and.obj bn_mp_or.obj bn_mp_rand.obj bn_mp_montgomery_calc_normalization.obj \ bn_mp_prime_is_divisible.obj bn_prime_tab.obj bn_mp_prime_fermat.obj bn_mp_prime_miller_rabin.obj \ bn_mp_prime_is_prime.obj bn_mp_prime_next_prime.obj bn_mp_dr_reduce.obj \ bn_mp_dr_is_modulus.obj bn_mp_dr_setup.obj bn_mp_reduce_setup.obj \ bn_mp_toom_mul.obj bn_mp_toom_sqr.obj bn_mp_div_3.obj bn_s_mp_exptmod.obj \ bn_mp_reduce_2k.obj bn_mp_reduce_is_2k.obj bn_mp_reduce_2k_setup.obj \ bn_mp_reduce_2k_l.obj bn_mp_reduce_is_2k_l.obj bn_mp_reduce_2k_setup_l.obj \ bn_mp_radix_smap.obj bn_mp_read_radix.obj bn_mp_toradix.obj bn_mp_radix_size.obj \ bn_mp_fread.obj bn_mp_fwrite.obj bn_mp_cnt_lsb.obj bn_error.obj \ bn_mp_init_multi.obj bn_mp_clear_multi.obj bn_mp_exteuclid.obj bn_mp_toradix_n.obj \ bn_mp_prime_random_ex.obj bn_mp_get_int.obj bn_mp_sqrt.obj bn_mp_is_square.obj \ bn_mp_init_set.obj bn_mp_init_set_int.obj bn_mp_invmod_slow.obj bn_mp_prime_rabin_miller_trials.obj \ bn_mp_to_signed_bin_n.obj bn_mp_to_unsigned_bin_n.obj HEADERS=tommath.h tommath_class.h tommath_superclass.h library: $(OBJECTS) lib /out:tommath.lib $(OBJECTS) |
Added libtommath/makefile.shared.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #Makefile for GCC # #Tom St Denis VERSION=0:36 CC = libtool --mode=compile gcc CFLAGS += -I./ -Wall -W -Wshadow -Wsign-compare ifndef IGNORE_SPEED #for speed CFLAGS += -O3 -funroll-loops #for size #CFLAGS += -Os #x86 optimizations [should be valid for any GCC install though] CFLAGS += -fomit-frame-pointer endif #install as this user ifndef INSTALL_GROUP GROUP=wheel else GROUP=$(INSTALL_GROUP) endif ifndef INSTALL_USER USER=root else USER=$(INSTALL_USER) endif default: libtommath.la #default files to install ifndef LIBNAME LIBNAME=libtommath.la endif ifndef LIBNAME_S LIBNAME_S=libtommath.a endif HEADERS=tommath.h tommath_class.h tommath_superclass.h #LIBPATH-The directory for libtommath to be installed to. #INCPATH-The directory to install the header files for libtommath. #DATAPATH-The directory to install the pdf docs. DESTDIR= LIBPATH=/usr/lib INCPATH=/usr/include DATAPATH=/usr/share/doc/libtommath/pdf OBJECTS=bncore.o bn_mp_init.o bn_mp_clear.o bn_mp_exch.o bn_mp_grow.o bn_mp_shrink.o \ bn_mp_clamp.o bn_mp_zero.o bn_mp_set.o bn_mp_set_int.o bn_mp_init_size.o bn_mp_copy.o \ bn_mp_init_copy.o bn_mp_abs.o bn_mp_neg.o bn_mp_cmp_mag.o bn_mp_cmp.o bn_mp_cmp_d.o \ bn_mp_rshd.o bn_mp_lshd.o bn_mp_mod_2d.o bn_mp_div_2d.o bn_mp_mul_2d.o bn_mp_div_2.o \ bn_mp_mul_2.o bn_s_mp_add.o bn_s_mp_sub.o bn_fast_s_mp_mul_digs.o bn_s_mp_mul_digs.o \ bn_fast_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs.o bn_fast_s_mp_sqr.o bn_s_mp_sqr.o \ bn_mp_add.o bn_mp_sub.o bn_mp_karatsuba_mul.o bn_mp_mul.o bn_mp_karatsuba_sqr.o \ bn_mp_sqr.o bn_mp_div.o bn_mp_mod.o bn_mp_add_d.o bn_mp_sub_d.o bn_mp_mul_d.o \ bn_mp_div_d.o bn_mp_mod_d.o bn_mp_expt_d.o bn_mp_addmod.o bn_mp_submod.o \ bn_mp_mulmod.o bn_mp_sqrmod.o bn_mp_gcd.o bn_mp_lcm.o bn_fast_mp_invmod.o bn_mp_invmod.o \ bn_mp_reduce.o bn_mp_montgomery_setup.o bn_fast_mp_montgomery_reduce.o bn_mp_montgomery_reduce.o \ bn_mp_exptmod_fast.o bn_mp_exptmod.o bn_mp_2expt.o bn_mp_n_root.o bn_mp_jacobi.o bn_reverse.o \ bn_mp_count_bits.o bn_mp_read_unsigned_bin.o bn_mp_read_signed_bin.o bn_mp_to_unsigned_bin.o \ bn_mp_to_signed_bin.o bn_mp_unsigned_bin_size.o bn_mp_signed_bin_size.o \ bn_mp_xor.o bn_mp_and.o bn_mp_or.o bn_mp_rand.o bn_mp_montgomery_calc_normalization.o \ bn_mp_prime_is_divisible.o bn_prime_tab.o bn_mp_prime_fermat.o bn_mp_prime_miller_rabin.o \ bn_mp_prime_is_prime.o bn_mp_prime_next_prime.o bn_mp_dr_reduce.o \ bn_mp_dr_is_modulus.o bn_mp_dr_setup.o bn_mp_reduce_setup.o \ bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_div_3.o bn_s_mp_exptmod.o \ bn_mp_reduce_2k.o bn_mp_reduce_is_2k.o bn_mp_reduce_2k_setup.o \ bn_mp_reduce_2k_l.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_2k_setup_l.o \ bn_mp_radix_smap.o bn_mp_read_radix.o bn_mp_toradix.o bn_mp_radix_size.o \ bn_mp_fread.o bn_mp_fwrite.o bn_mp_cnt_lsb.o bn_error.o \ bn_mp_init_multi.o bn_mp_clear_multi.o bn_mp_exteuclid.o bn_mp_toradix_n.o \ bn_mp_prime_random_ex.o bn_mp_get_int.o bn_mp_sqrt.o bn_mp_is_square.o bn_mp_init_set.o \ bn_mp_init_set_int.o bn_mp_invmod_slow.o bn_mp_prime_rabin_miller_trials.o \ bn_mp_to_signed_bin_n.o bn_mp_to_unsigned_bin_n.o $(LIBNAME): $(OBJECTS) libtool --mode=link gcc *.lo -o $(LIBNAME) -rpath $(LIBPATH) -version-info $(VERSION) libtool --mode=link gcc *.o -o $(LIBNAME_S) ranlib $(LIBNAME_S) libtool --mode=install install -c $(LIBNAME) $(LIBPATH)/$@ install -d -g $(GROUP) -o $(USER) $(DESTDIR)$(INCPATH) install -g $(GROUP) -o $(USER) $(HEADERS) $(DESTDIR)$(INCPATH) test: $(LIBNAME) demo/demo.o gcc $(CFLAGS) -c demo/demo.c -o demo/demo.o libtool --mode=link gcc -o test demo/demo.o $(LIBNAME_S) mtest: test cd mtest ; gcc $(CFLAGS) mtest.c -o mtest timing: $(LIBNAME) gcc $(CFLAGS) -DTIMER demo/timing.c $(LIBNAME_S) -o ltmtest |
Added libtommath/mess.sh.
> > > > | 1 2 3 4 | #!/bin/bash if cvs log $1 >/dev/null 2>/dev/null; then exit 0; else echo "$1 shouldn't be here" ; exit 1; fi |
Added libtommath/mtest/logtab.h.
> > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | const float s_logv_2[] = { 0.000000000, 0.000000000, 1.000000000, 0.630929754, /* 0 1 2 3 */ 0.500000000, 0.430676558, 0.386852807, 0.356207187, /* 4 5 6 7 */ 0.333333333, 0.315464877, 0.301029996, 0.289064826, /* 8 9 10 11 */ 0.278942946, 0.270238154, 0.262649535, 0.255958025, /* 12 13 14 15 */ 0.250000000, 0.244650542, 0.239812467, 0.235408913, /* 16 17 18 19 */ 0.231378213, 0.227670249, 0.224243824, 0.221064729, /* 20 21 22 23 */ 0.218104292, 0.215338279, 0.212746054, 0.210309918, /* 24 25 26 27 */ 0.208014598, 0.205846832, 0.203795047, 0.201849087, /* 28 29 30 31 */ 0.200000000, 0.198239863, 0.196561632, 0.194959022, /* 32 33 34 35 */ 0.193426404, 0.191958720, 0.190551412, 0.189200360, /* 36 37 38 39 */ 0.187901825, 0.186652411, 0.185449023, 0.184288833, /* 40 41 42 43 */ 0.183169251, 0.182087900, 0.181042597, 0.180031327, /* 44 45 46 47 */ 0.179052232, 0.178103594, 0.177183820, 0.176291434, /* 48 49 50 51 */ 0.175425064, 0.174583430, 0.173765343, 0.172969690, /* 52 53 54 55 */ 0.172195434, 0.171441601, 0.170707280, 0.169991616, /* 56 57 58 59 */ 0.169293808, 0.168613099, 0.167948779, 0.167300179, /* 60 61 62 63 */ 0.166666667 }; /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/logtab.h,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/mtest/mpi-config.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | /* Default configuration for MPI library */ /* $Id: mpi-config.h,v 1.1.1.1.2.1 2005/09/26 20:16:54 kennykb Exp $ */ #ifndef MPI_CONFIG_H_ #define MPI_CONFIG_H_ /* For boolean options, 0 = no 1 = yes Other options are documented individually. */ #ifndef MP_IOFUNC #define MP_IOFUNC 0 /* include mp_print() ? */ #endif #ifndef MP_MODARITH #define MP_MODARITH 1 /* include modular arithmetic ? */ #endif #ifndef MP_NUMTH #define MP_NUMTH 1 /* include number theoretic functions? */ #endif #ifndef MP_LOGTAB #define MP_LOGTAB 1 /* use table of logs instead of log()? */ #endif #ifndef MP_MEMSET #define MP_MEMSET 1 /* use memset() to zero buffers? */ #endif #ifndef MP_MEMCPY #define MP_MEMCPY 1 /* use memcpy() to copy buffers? */ #endif #ifndef MP_CRYPTO #define MP_CRYPTO 1 /* erase memory on free? */ #endif #ifndef MP_ARGCHK /* 0 = no parameter checks 1 = runtime checks, continue execution and return an error to caller 2 = assertions; dump core on parameter errors */ #define MP_ARGCHK 2 /* how to check input arguments */ #endif #ifndef MP_DEBUG #define MP_DEBUG 0 /* print diagnostic output? */ #endif #ifndef MP_DEFPREC #define MP_DEFPREC 64 /* default precision, in digits */ #endif #ifndef MP_MACRO #define MP_MACRO 1 /* use macros for frequent calls? */ #endif #ifndef MP_SQUARE #define MP_SQUARE 1 /* use separate squaring code? */ #endif #ifndef MP_PTAB_SIZE /* When building mpprime.c, we build in a table of small prime values to use for primality testing. The more you include, the more space they take up. See primes.c for the possible values (currently 16, 32, 64, 128, 256, and 6542) */ #define MP_PTAB_SIZE 128 /* how many built-in primes? */ #endif #ifndef MP_COMPAT_MACROS #define MP_COMPAT_MACROS 1 /* define compatibility macros? */ #endif #endif /* ifndef MPI_CONFIG_H_ */ /* crc==3287762869, version==2, Sat Feb 02 06:43:53 2002 */ /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi-config.h,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/mtest/mpi-types.h.
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* Type definitions generated by 'types.pl' */ typedef char mp_sign; typedef unsigned short mp_digit; /* 2 byte type */ typedef unsigned int mp_word; /* 4 byte type */ typedef unsigned int mp_size; typedef int mp_err; #define MP_DIGIT_BIT (CHAR_BIT*sizeof(mp_digit)) #define MP_DIGIT_MAX USHRT_MAX #define MP_WORD_BIT (CHAR_BIT*sizeof(mp_word)) #define MP_WORD_MAX UINT_MAX #define MP_DIGIT_SIZE 2 #define DIGIT_FMT "%04X" #define RADIX (MP_DIGIT_MAX+1) /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi-types.h,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/mtest/mpi.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 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 | /* mpi.c by Michael J. Fromberger <[email protected]> Copyright (C) 1998 Michael J. Fromberger, All Rights Reserved Arbitrary precision integer arithmetic library $Id: mpi.c,v 1.1.1.1.2.1 2005/09/26 20:16:54 kennykb Exp $ */ #include "mpi.h" #include <stdlib.h> #include <string.h> #include <ctype.h> #if MP_DEBUG #include <stdio.h> #define DIAG(T,V) {fprintf(stderr,T);mp_print(V,stderr);fputc('\n',stderr);} #else #define DIAG(T,V) #endif /* If MP_LOGTAB is not defined, use the math library to compute the logarithms on the fly. Otherwise, use the static table below. Pick which works best for your system. */ #if MP_LOGTAB /* {{{ s_logv_2[] - log table for 2 in various bases */ /* A table of the logs of 2 for various bases (the 0 and 1 entries of this table are meaningless and should not be referenced). This table is used to compute output lengths for the mp_toradix() function. Since a number n in radix r takes up about log_r(n) digits, we estimate the output size by taking the least integer greater than log_r(n), where: log_r(n) = log_2(n) * log_r(2) This table, therefore, is a table of log_r(2) for 2 <= r <= 36, which are the output bases supported. */ #include "logtab.h" /* }}} */ #define LOG_V_2(R) s_logv_2[(R)] #else #include <math.h> #define LOG_V_2(R) (log(2.0)/log(R)) #endif /* Default precision for newly created mp_int's */ static unsigned int s_mp_defprec = MP_DEFPREC; /* {{{ Digit arithmetic macros */ /* When adding and multiplying digits, the results can be larger than can be contained in an mp_digit. Thus, an mp_word is used. These macros mask off the upper and lower digits of the mp_word (the mp_word may be more than 2 mp_digits wide, but we only concern ourselves with the low-order 2 mp_digits) If your mp_word DOES have more than 2 mp_digits, you need to uncomment the first line, and comment out the second. */ /* #define CARRYOUT(W) (((W)>>DIGIT_BIT)&MP_DIGIT_MAX) */ #define CARRYOUT(W) ((W)>>DIGIT_BIT) #define ACCUM(W) ((W)&MP_DIGIT_MAX) /* }}} */ /* {{{ Comparison constants */ #define MP_LT -1 #define MP_EQ 0 #define MP_GT 1 /* }}} */ /* {{{ Constant strings */ /* Constant strings returned by mp_strerror() */ static const char *mp_err_string[] = { "unknown result code", /* say what? */ "boolean true", /* MP_OKAY, MP_YES */ "boolean false", /* MP_NO */ "out of memory", /* MP_MEM */ "argument out of range", /* MP_RANGE */ "invalid input parameter", /* MP_BADARG */ "result is undefined" /* MP_UNDEF */ }; /* Value to digit maps for radix conversion */ /* s_dmap_1 - standard digits and letters */ static const char *s_dmap_1 = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; #if 0 /* s_dmap_2 - base64 ordering for digits */ static const char *s_dmap_2 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; #endif /* }}} */ /* {{{ Static function declarations */ /* If MP_MACRO is false, these will be defined as actual functions; otherwise, suitable macro definitions will be used. This works around the fact that ANSI C89 doesn't support an 'inline' keyword (although I hear C9x will ... about bloody time). At present, the macro definitions are identical to the function bodies, but they'll expand in place, instead of generating a function call. I chose these particular functions to be made into macros because some profiling showed they are called a lot on a typical workload, and yet they are primarily housekeeping. */ #if MP_MACRO == 0 void s_mp_setz(mp_digit *dp, mp_size count); /* zero digits */ void s_mp_copy(mp_digit *sp, mp_digit *dp, mp_size count); /* copy */ void *s_mp_alloc(size_t nb, size_t ni); /* general allocator */ void s_mp_free(void *ptr); /* general free function */ #else /* Even if these are defined as macros, we need to respect the settings of the MP_MEMSET and MP_MEMCPY configuration options... */ #if MP_MEMSET == 0 #define s_mp_setz(dp, count) \ {int ix;for(ix=0;ix<(count);ix++)(dp)[ix]=0;} #else #define s_mp_setz(dp, count) memset(dp, 0, (count) * sizeof(mp_digit)) #endif /* MP_MEMSET */ #if MP_MEMCPY == 0 #define s_mp_copy(sp, dp, count) \ {int ix;for(ix=0;ix<(count);ix++)(dp)[ix]=(sp)[ix];} #else #define s_mp_copy(sp, dp, count) memcpy(dp, sp, (count) * sizeof(mp_digit)) #endif /* MP_MEMCPY */ #define s_mp_alloc(nb, ni) calloc(nb, ni) #define s_mp_free(ptr) {if(ptr) free(ptr);} #endif /* MP_MACRO */ mp_err s_mp_grow(mp_int *mp, mp_size min); /* increase allocated size */ mp_err s_mp_pad(mp_int *mp, mp_size min); /* left pad with zeroes */ void s_mp_clamp(mp_int *mp); /* clip leading zeroes */ void s_mp_exch(mp_int *a, mp_int *b); /* swap a and b in place */ mp_err s_mp_lshd(mp_int *mp, mp_size p); /* left-shift by p digits */ void s_mp_rshd(mp_int *mp, mp_size p); /* right-shift by p digits */ void s_mp_div_2d(mp_int *mp, mp_digit d); /* divide by 2^d in place */ void s_mp_mod_2d(mp_int *mp, mp_digit d); /* modulo 2^d in place */ mp_err s_mp_mul_2d(mp_int *mp, mp_digit d); /* multiply by 2^d in place*/ void s_mp_div_2(mp_int *mp); /* divide by 2 in place */ mp_err s_mp_mul_2(mp_int *mp); /* multiply by 2 in place */ mp_digit s_mp_norm(mp_int *a, mp_int *b); /* normalize for division */ mp_err s_mp_add_d(mp_int *mp, mp_digit d); /* unsigned digit addition */ mp_err s_mp_sub_d(mp_int *mp, mp_digit d); /* unsigned digit subtract */ mp_err s_mp_mul_d(mp_int *mp, mp_digit d); /* unsigned digit multiply */ mp_err s_mp_div_d(mp_int *mp, mp_digit d, mp_digit *r); /* unsigned digit divide */ mp_err s_mp_reduce(mp_int *x, mp_int *m, mp_int *mu); /* Barrett reduction */ mp_err s_mp_add(mp_int *a, mp_int *b); /* magnitude addition */ mp_err s_mp_sub(mp_int *a, mp_int *b); /* magnitude subtract */ mp_err s_mp_mul(mp_int *a, mp_int *b); /* magnitude multiply */ #if 0 void s_mp_kmul(mp_digit *a, mp_digit *b, mp_digit *out, mp_size len); /* multiply buffers in place */ #endif #if MP_SQUARE mp_err s_mp_sqr(mp_int *a); /* magnitude square */ #else #define s_mp_sqr(a) s_mp_mul(a, a) #endif mp_err s_mp_div(mp_int *a, mp_int *b); /* magnitude divide */ mp_err s_mp_2expt(mp_int *a, mp_digit k); /* a = 2^k */ int s_mp_cmp(mp_int *a, mp_int *b); /* magnitude comparison */ int s_mp_cmp_d(mp_int *a, mp_digit d); /* magnitude digit compare */ int s_mp_ispow2(mp_int *v); /* is v a power of 2? */ int s_mp_ispow2d(mp_digit d); /* is d a power of 2? */ int s_mp_tovalue(char ch, int r); /* convert ch to value */ char s_mp_todigit(int val, int r, int low); /* convert val to digit */ int s_mp_outlen(int bits, int r); /* output length in bytes */ /* }}} */ /* {{{ Default precision manipulation */ unsigned int mp_get_prec(void) { return s_mp_defprec; } /* end mp_get_prec() */ void mp_set_prec(unsigned int prec) { if(prec == 0) s_mp_defprec = MP_DEFPREC; else s_mp_defprec = prec; } /* end mp_set_prec() */ /* }}} */ /*------------------------------------------------------------------------*/ /* {{{ mp_init(mp) */ /* mp_init(mp) Initialize a new zero-valued mp_int. Returns MP_OKAY if successful, MP_MEM if memory could not be allocated for the structure. */ mp_err mp_init(mp_int *mp) { return mp_init_size(mp, s_mp_defprec); } /* end mp_init() */ /* }}} */ /* {{{ mp_init_array(mp[], count) */ mp_err mp_init_array(mp_int mp[], int count) { mp_err res; int pos; ARGCHK(mp !=NULL && count > 0, MP_BADARG); for(pos = 0; pos < count; ++pos) { if((res = mp_init(&mp[pos])) != MP_OKAY) goto CLEANUP; } return MP_OKAY; CLEANUP: while(--pos >= 0) mp_clear(&mp[pos]); return res; } /* end mp_init_array() */ /* }}} */ /* {{{ mp_init_size(mp, prec) */ /* mp_init_size(mp, prec) Initialize a new zero-valued mp_int with at least the given precision; returns MP_OKAY if successful, or MP_MEM if memory could not be allocated for the structure. */ mp_err mp_init_size(mp_int *mp, mp_size prec) { ARGCHK(mp != NULL && prec > 0, MP_BADARG); if((DIGITS(mp) = s_mp_alloc(prec, sizeof(mp_digit))) == NULL) return MP_MEM; SIGN(mp) = MP_ZPOS; USED(mp) = 1; ALLOC(mp) = prec; return MP_OKAY; } /* end mp_init_size() */ /* }}} */ /* {{{ mp_init_copy(mp, from) */ /* mp_init_copy(mp, from) Initialize mp as an exact copy of from. Returns MP_OKAY if successful, MP_MEM if memory could not be allocated for the new structure. */ mp_err mp_init_copy(mp_int *mp, mp_int *from) { ARGCHK(mp != NULL && from != NULL, MP_BADARG); if(mp == from) return MP_OKAY; if((DIGITS(mp) = s_mp_alloc(USED(from), sizeof(mp_digit))) == NULL) return MP_MEM; s_mp_copy(DIGITS(from), DIGITS(mp), USED(from)); USED(mp) = USED(from); ALLOC(mp) = USED(from); SIGN(mp) = SIGN(from); return MP_OKAY; } /* end mp_init_copy() */ /* }}} */ /* {{{ mp_copy(from, to) */ /* mp_copy(from, to) Copies the mp_int 'from' to the mp_int 'to'. It is presumed that 'to' has already been initialized (if not, use mp_init_copy() instead). If 'from' and 'to' are identical, nothing happens. */ mp_err mp_copy(mp_int *from, mp_int *to) { ARGCHK(from != NULL && to != NULL, MP_BADARG); if(from == to) return MP_OKAY; { /* copy */ mp_digit *tmp; /* If the allocated buffer in 'to' already has enough space to hold all the used digits of 'from', we'll re-use it to avoid hitting the memory allocater more than necessary; otherwise, we'd have to grow anyway, so we just allocate a hunk and make the copy as usual */ if(ALLOC(to) >= USED(from)) { s_mp_setz(DIGITS(to) + USED(from), ALLOC(to) - USED(from)); s_mp_copy(DIGITS(from), DIGITS(to), USED(from)); } else { if((tmp = s_mp_alloc(USED(from), sizeof(mp_digit))) == NULL) return MP_MEM; s_mp_copy(DIGITS(from), tmp, USED(from)); if(DIGITS(to) != NULL) { #if MP_CRYPTO s_mp_setz(DIGITS(to), ALLOC(to)); #endif s_mp_free(DIGITS(to)); } DIGITS(to) = tmp; ALLOC(to) = USED(from); } /* Copy the precision and sign from the original */ USED(to) = USED(from); SIGN(to) = SIGN(from); } /* end copy */ return MP_OKAY; } /* end mp_copy() */ /* }}} */ /* {{{ mp_exch(mp1, mp2) */ /* mp_exch(mp1, mp2) Exchange mp1 and mp2 without allocating any intermediate memory (well, unless you count the stack space needed for this call and the locals it creates...). This cannot fail. */ void mp_exch(mp_int *mp1, mp_int *mp2) { #if MP_ARGCHK == 2 assert(mp1 != NULL && mp2 != NULL); #else if(mp1 == NULL || mp2 == NULL) return; #endif s_mp_exch(mp1, mp2); } /* end mp_exch() */ /* }}} */ /* {{{ mp_clear(mp) */ /* mp_clear(mp) Release the storage used by an mp_int, and void its fields so that if someone calls mp_clear() again for the same int later, we won't get tollchocked. */ void mp_clear(mp_int *mp) { if(mp == NULL) return; if(DIGITS(mp) != NULL) { #if MP_CRYPTO s_mp_setz(DIGITS(mp), ALLOC(mp)); #endif s_mp_free(DIGITS(mp)); DIGITS(mp) = NULL; } USED(mp) = 0; ALLOC(mp) = 0; } /* end mp_clear() */ /* }}} */ /* {{{ mp_clear_array(mp[], count) */ void mp_clear_array(mp_int mp[], int count) { ARGCHK(mp != NULL && count > 0, MP_BADARG); while(--count >= 0) mp_clear(&mp[count]); } /* end mp_clear_array() */ /* }}} */ /* {{{ mp_zero(mp) */ /* mp_zero(mp) Set mp to zero. Does not change the allocated size of the structure, and therefore cannot fail (except on a bad argument, which we ignore) */ void mp_zero(mp_int *mp) { if(mp == NULL) return; s_mp_setz(DIGITS(mp), ALLOC(mp)); USED(mp) = 1; SIGN(mp) = MP_ZPOS; } /* end mp_zero() */ /* }}} */ /* {{{ mp_set(mp, d) */ void mp_set(mp_int *mp, mp_digit d) { if(mp == NULL) return; mp_zero(mp); DIGIT(mp, 0) = d; } /* end mp_set() */ /* }}} */ /* {{{ mp_set_int(mp, z) */ mp_err mp_set_int(mp_int *mp, long z) { int ix; unsigned long v = abs(z); mp_err res; ARGCHK(mp != NULL, MP_BADARG); mp_zero(mp); if(z == 0) return MP_OKAY; /* shortcut for zero */ for(ix = sizeof(long) - 1; ix >= 0; ix--) { if((res = s_mp_mul_2d(mp, CHAR_BIT)) != MP_OKAY) return res; res = s_mp_add_d(mp, (mp_digit)((v >> (ix * CHAR_BIT)) & UCHAR_MAX)); if(res != MP_OKAY) return res; } if(z < 0) SIGN(mp) = MP_NEG; return MP_OKAY; } /* end mp_set_int() */ /* }}} */ /*------------------------------------------------------------------------*/ /* {{{ Digit arithmetic */ /* {{{ mp_add_d(a, d, b) */ /* mp_add_d(a, d, b) Compute the sum b = a + d, for a single digit d. Respects the sign of its primary addend (single digits are unsigned anyway). */ mp_err mp_add_d(mp_int *a, mp_digit d, mp_int *b) { mp_err res = MP_OKAY; ARGCHK(a != NULL && b != NULL, MP_BADARG); if((res = mp_copy(a, b)) != MP_OKAY) return res; if(SIGN(b) == MP_ZPOS) { res = s_mp_add_d(b, d); } else if(s_mp_cmp_d(b, d) >= 0) { res = s_mp_sub_d(b, d); } else { SIGN(b) = MP_ZPOS; DIGIT(b, 0) = d - DIGIT(b, 0); } return res; } /* end mp_add_d() */ /* }}} */ /* {{{ mp_sub_d(a, d, b) */ /* mp_sub_d(a, d, b) Compute the difference b = a - d, for a single digit d. Respects the sign of its subtrahend (single digits are unsigned anyway). */ mp_err mp_sub_d(mp_int *a, mp_digit d, mp_int *b) { mp_err res; ARGCHK(a != NULL && b != NULL, MP_BADARG); if((res = mp_copy(a, b)) != MP_OKAY) return res; if(SIGN(b) == MP_NEG) { if((res = s_mp_add_d(b, d)) != MP_OKAY) return res; } else if(s_mp_cmp_d(b, d) >= 0) { if((res = s_mp_sub_d(b, d)) != MP_OKAY) return res; } else { mp_neg(b, b); DIGIT(b, 0) = d - DIGIT(b, 0); SIGN(b) = MP_NEG; } if(s_mp_cmp_d(b, 0) == 0) SIGN(b) = MP_ZPOS; return MP_OKAY; } /* end mp_sub_d() */ /* }}} */ /* {{{ mp_mul_d(a, d, b) */ /* mp_mul_d(a, d, b) Compute the product b = a * d, for a single digit d. Respects the sign of its multiplicand (single digits are unsigned anyway) */ mp_err mp_mul_d(mp_int *a, mp_digit d, mp_int *b) { mp_err res; ARGCHK(a != NULL && b != NULL, MP_BADARG); if(d == 0) { mp_zero(b); return MP_OKAY; } if((res = mp_copy(a, b)) != MP_OKAY) return res; res = s_mp_mul_d(b, d); return res; } /* end mp_mul_d() */ /* }}} */ /* {{{ mp_mul_2(a, c) */ mp_err mp_mul_2(mp_int *a, mp_int *c) { mp_err res; ARGCHK(a != NULL && c != NULL, MP_BADARG); if((res = mp_copy(a, c)) != MP_OKAY) return res; return s_mp_mul_2(c); } /* end mp_mul_2() */ /* }}} */ /* {{{ mp_div_d(a, d, q, r) */ /* mp_div_d(a, d, q, r) Compute the quotient q = a / d and remainder r = a mod d, for a single digit d. Respects the sign of its divisor (single digits are unsigned anyway). */ mp_err mp_div_d(mp_int *a, mp_digit d, mp_int *q, mp_digit *r) { mp_err res; mp_digit rem; int pow; ARGCHK(a != NULL, MP_BADARG); if(d == 0) return MP_RANGE; /* Shortcut for powers of two ... */ if((pow = s_mp_ispow2d(d)) >= 0) { mp_digit mask; mask = (1 << pow) - 1; rem = DIGIT(a, 0) & mask; if(q) { mp_copy(a, q); s_mp_div_2d(q, pow); } if(r) *r = rem; return MP_OKAY; } /* If the quotient is actually going to be returned, we'll try to avoid hitting the memory allocator by copying the dividend into it and doing the division there. This can't be any _worse_ than always copying, and will sometimes be better (since it won't make another copy) If it's not going to be returned, we need to allocate a temporary to hold the quotient, which will just be discarded. */ if(q) { if((res = mp_copy(a, q)) != MP_OKAY) return res; res = s_mp_div_d(q, d, &rem); if(s_mp_cmp_d(q, 0) == MP_EQ) SIGN(q) = MP_ZPOS; } else { mp_int qp; if((res = mp_init_copy(&qp, a)) != MP_OKAY) return res; res = s_mp_div_d(&qp, d, &rem); if(s_mp_cmp_d(&qp, 0) == 0) SIGN(&qp) = MP_ZPOS; mp_clear(&qp); } if(r) *r = rem; return res; } /* end mp_div_d() */ /* }}} */ /* {{{ mp_div_2(a, c) */ /* mp_div_2(a, c) Compute c = a / 2, disregarding the remainder. */ mp_err mp_div_2(mp_int *a, mp_int *c) { mp_err res; ARGCHK(a != NULL && c != NULL, MP_BADARG); if((res = mp_copy(a, c)) != MP_OKAY) return res; s_mp_div_2(c); return MP_OKAY; } /* end mp_div_2() */ /* }}} */ /* {{{ mp_expt_d(a, d, b) */ mp_err mp_expt_d(mp_int *a, mp_digit d, mp_int *c) { mp_int s, x; mp_err res; ARGCHK(a != NULL && c != NULL, MP_BADARG); if((res = mp_init(&s)) != MP_OKAY) return res; if((res = mp_init_copy(&x, a)) != MP_OKAY) goto X; DIGIT(&s, 0) = 1; while(d != 0) { if(d & 1) { if((res = s_mp_mul(&s, &x)) != MP_OKAY) goto CLEANUP; } d >>= 1; if((res = s_mp_sqr(&x)) != MP_OKAY) goto CLEANUP; } s_mp_exch(&s, c); CLEANUP: mp_clear(&x); X: mp_clear(&s); return res; } /* end mp_expt_d() */ /* }}} */ /* }}} */ /*------------------------------------------------------------------------*/ /* {{{ Full arithmetic */ /* {{{ mp_abs(a, b) */ /* mp_abs(a, b) Compute b = |a|. 'a' and 'b' may be identical. */ mp_err mp_abs(mp_int *a, mp_int *b) { mp_err res; ARGCHK(a != NULL && b != NULL, MP_BADARG); if((res = mp_copy(a, b)) != MP_OKAY) return res; SIGN(b) = MP_ZPOS; return MP_OKAY; } /* end mp_abs() */ /* }}} */ /* {{{ mp_neg(a, b) */ /* mp_neg(a, b) Compute b = -a. 'a' and 'b' may be identical. */ mp_err mp_neg(mp_int *a, mp_int *b) { mp_err res; ARGCHK(a != NULL && b != NULL, MP_BADARG); if((res = mp_copy(a, b)) != MP_OKAY) return res; if(s_mp_cmp_d(b, 0) == MP_EQ) SIGN(b) = MP_ZPOS; else SIGN(b) = (SIGN(b) == MP_NEG) ? MP_ZPOS : MP_NEG; return MP_OKAY; } /* end mp_neg() */ /* }}} */ /* {{{ mp_add(a, b, c) */ /* mp_add(a, b, c) Compute c = a + b. All parameters may be identical. */ mp_err mp_add(mp_int *a, mp_int *b, mp_int *c) { mp_err res; int cmp; ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); if(SIGN(a) == SIGN(b)) { /* same sign: add values, keep sign */ /* Commutativity of addition lets us do this in either order, so we avoid having to use a temporary even if the result is supposed to replace the output */ if(c == b) { if((res = s_mp_add(c, a)) != MP_OKAY) return res; } else { if(c != a && (res = mp_copy(a, c)) != MP_OKAY) return res; if((res = s_mp_add(c, b)) != MP_OKAY) return res; } } else if((cmp = s_mp_cmp(a, b)) > 0) { /* different sign: a > b */ /* If the output is going to be clobbered, we will use a temporary variable; otherwise, we'll do it without touching the memory allocator at all, if possible */ if(c == b) { mp_int tmp; if((res = mp_init_copy(&tmp, a)) != MP_OKAY) return res; if((res = s_mp_sub(&tmp, b)) != MP_OKAY) { mp_clear(&tmp); return res; } s_mp_exch(&tmp, c); mp_clear(&tmp); } else { if(c != a && (res = mp_copy(a, c)) != MP_OKAY) return res; if((res = s_mp_sub(c, b)) != MP_OKAY) return res; } } else if(cmp == 0) { /* different sign, a == b */ mp_zero(c); return MP_OKAY; } else { /* different sign: a < b */ /* See above... */ if(c == a) { mp_int tmp; if((res = mp_init_copy(&tmp, b)) != MP_OKAY) return res; if((res = s_mp_sub(&tmp, a)) != MP_OKAY) { mp_clear(&tmp); return res; } s_mp_exch(&tmp, c); mp_clear(&tmp); } else { if(c != b && (res = mp_copy(b, c)) != MP_OKAY) return res; if((res = s_mp_sub(c, a)) != MP_OKAY) return res; } } if(USED(c) == 1 && DIGIT(c, 0) == 0) SIGN(c) = MP_ZPOS; return MP_OKAY; } /* end mp_add() */ /* }}} */ /* {{{ mp_sub(a, b, c) */ /* mp_sub(a, b, c) Compute c = a - b. All parameters may be identical. */ mp_err mp_sub(mp_int *a, mp_int *b, mp_int *c) { mp_err res; int cmp; ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); if(SIGN(a) != SIGN(b)) { if(c == a) { if((res = s_mp_add(c, b)) != MP_OKAY) return res; } else { if(c != b && ((res = mp_copy(b, c)) != MP_OKAY)) return res; if((res = s_mp_add(c, a)) != MP_OKAY) return res; SIGN(c) = SIGN(a); } } else if((cmp = s_mp_cmp(a, b)) > 0) { /* Same sign, a > b */ if(c == b) { mp_int tmp; if((res = mp_init_copy(&tmp, a)) != MP_OKAY) return res; if((res = s_mp_sub(&tmp, b)) != MP_OKAY) { mp_clear(&tmp); return res; } s_mp_exch(&tmp, c); mp_clear(&tmp); } else { if(c != a && ((res = mp_copy(a, c)) != MP_OKAY)) return res; if((res = s_mp_sub(c, b)) != MP_OKAY) return res; } } else if(cmp == 0) { /* Same sign, equal magnitude */ mp_zero(c); return MP_OKAY; } else { /* Same sign, b > a */ if(c == a) { mp_int tmp; if((res = mp_init_copy(&tmp, b)) != MP_OKAY) return res; if((res = s_mp_sub(&tmp, a)) != MP_OKAY) { mp_clear(&tmp); return res; } s_mp_exch(&tmp, c); mp_clear(&tmp); } else { if(c != b && ((res = mp_copy(b, c)) != MP_OKAY)) return res; if((res = s_mp_sub(c, a)) != MP_OKAY) return res; } SIGN(c) = !SIGN(b); } if(USED(c) == 1 && DIGIT(c, 0) == 0) SIGN(c) = MP_ZPOS; return MP_OKAY; } /* end mp_sub() */ /* }}} */ /* {{{ mp_mul(a, b, c) */ /* mp_mul(a, b, c) Compute c = a * b. All parameters may be identical. */ mp_err mp_mul(mp_int *a, mp_int *b, mp_int *c) { mp_err res; mp_sign sgn; ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); sgn = (SIGN(a) == SIGN(b)) ? MP_ZPOS : MP_NEG; if(c == b) { if((res = s_mp_mul(c, a)) != MP_OKAY) return res; } else { if((res = mp_copy(a, c)) != MP_OKAY) return res; if((res = s_mp_mul(c, b)) != MP_OKAY) return res; } if(sgn == MP_ZPOS || s_mp_cmp_d(c, 0) == MP_EQ) SIGN(c) = MP_ZPOS; else SIGN(c) = sgn; return MP_OKAY; } /* end mp_mul() */ /* }}} */ /* {{{ mp_mul_2d(a, d, c) */ /* mp_mul_2d(a, d, c) Compute c = a * 2^d. a may be the same as c. */ mp_err mp_mul_2d(mp_int *a, mp_digit d, mp_int *c) { mp_err res; ARGCHK(a != NULL && c != NULL, MP_BADARG); if((res = mp_copy(a, c)) != MP_OKAY) return res; if(d == 0) return MP_OKAY; return s_mp_mul_2d(c, d); } /* end mp_mul() */ /* }}} */ /* {{{ mp_sqr(a, b) */ #if MP_SQUARE mp_err mp_sqr(mp_int *a, mp_int *b) { mp_err res; ARGCHK(a != NULL && b != NULL, MP_BADARG); if((res = mp_copy(a, b)) != MP_OKAY) return res; if((res = s_mp_sqr(b)) != MP_OKAY) return res; SIGN(b) = MP_ZPOS; return MP_OKAY; } /* end mp_sqr() */ #endif /* }}} */ /* {{{ mp_div(a, b, q, r) */ /* mp_div(a, b, q, r) Compute q = a / b and r = a mod b. Input parameters may be re-used as output parameters. If q or r is NULL, that portion of the computation will be discarded (although it will still be computed) Pay no attention to the hacker behind the curtain. */ mp_err mp_div(mp_int *a, mp_int *b, mp_int *q, mp_int *r) { mp_err res; mp_int qtmp, rtmp; int cmp; ARGCHK(a != NULL && b != NULL, MP_BADARG); if(mp_cmp_z(b) == MP_EQ) return MP_RANGE; /* If a <= b, we can compute the solution without division, and avoid any memory allocation */ if((cmp = s_mp_cmp(a, b)) < 0) { if(r) { if((res = mp_copy(a, r)) != MP_OKAY) return res; } if(q) mp_zero(q); return MP_OKAY; } else if(cmp == 0) { /* Set quotient to 1, with appropriate sign */ if(q) { int qneg = (SIGN(a) != SIGN(b)); mp_set(q, 1); if(qneg) SIGN(q) = MP_NEG; } if(r) mp_zero(r); return MP_OKAY; } /* If we get here, it means we actually have to do some division */ /* Set up some temporaries... */ if((res = mp_init_copy(&qtmp, a)) != MP_OKAY) return res; if((res = mp_init_copy(&rtmp, b)) != MP_OKAY) goto CLEANUP; if((res = s_mp_div(&qtmp, &rtmp)) != MP_OKAY) goto CLEANUP; /* Compute the signs for the output */ SIGN(&rtmp) = SIGN(a); /* Sr = Sa */ if(SIGN(a) == SIGN(b)) SIGN(&qtmp) = MP_ZPOS; /* Sq = MP_ZPOS if Sa = Sb */ else SIGN(&qtmp) = MP_NEG; /* Sq = MP_NEG if Sa != Sb */ if(s_mp_cmp_d(&qtmp, 0) == MP_EQ) SIGN(&qtmp) = MP_ZPOS; if(s_mp_cmp_d(&rtmp, 0) == MP_EQ) SIGN(&rtmp) = MP_ZPOS; /* Copy output, if it is needed */ if(q) s_mp_exch(&qtmp, q); if(r) s_mp_exch(&rtmp, r); CLEANUP: mp_clear(&rtmp); mp_clear(&qtmp); return res; } /* end mp_div() */ /* }}} */ /* {{{ mp_div_2d(a, d, q, r) */ mp_err mp_div_2d(mp_int *a, mp_digit d, mp_int *q, mp_int *r) { mp_err res; ARGCHK(a != NULL, MP_BADARG); if(q) { if((res = mp_copy(a, q)) != MP_OKAY) return res; s_mp_div_2d(q, d); } if(r) { if((res = mp_copy(a, r)) != MP_OKAY) return res; s_mp_mod_2d(r, d); } return MP_OKAY; } /* end mp_div_2d() */ /* }}} */ /* {{{ mp_expt(a, b, c) */ /* mp_expt(a, b, c) Compute c = a ** b, that is, raise a to the b power. Uses a standard iterative square-and-multiply technique. */ mp_err mp_expt(mp_int *a, mp_int *b, mp_int *c) { mp_int s, x; mp_err res; mp_digit d; int dig, bit; ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); if(mp_cmp_z(b) < 0) return MP_RANGE; if((res = mp_init(&s)) != MP_OKAY) return res; mp_set(&s, 1); if((res = mp_init_copy(&x, a)) != MP_OKAY) goto X; /* Loop over low-order digits in ascending order */ for(dig = 0; dig < (USED(b) - 1); dig++) { d = DIGIT(b, dig); /* Loop over bits of each non-maximal digit */ for(bit = 0; bit < DIGIT_BIT; bit++) { if(d & 1) { if((res = s_mp_mul(&s, &x)) != MP_OKAY) goto CLEANUP; } d >>= 1; if((res = s_mp_sqr(&x)) != MP_OKAY) goto CLEANUP; } } /* Consider now the last digit... */ d = DIGIT(b, dig); while(d) { if(d & 1) { if((res = s_mp_mul(&s, &x)) != MP_OKAY) goto CLEANUP; } d >>= 1; if((res = s_mp_sqr(&x)) != MP_OKAY) goto CLEANUP; } if(mp_iseven(b)) SIGN(&s) = SIGN(a); res = mp_copy(&s, c); CLEANUP: mp_clear(&x); X: mp_clear(&s); return res; } /* end mp_expt() */ /* }}} */ /* {{{ mp_2expt(a, k) */ /* Compute a = 2^k */ mp_err mp_2expt(mp_int *a, mp_digit k) { ARGCHK(a != NULL, MP_BADARG); return s_mp_2expt(a, k); } /* end mp_2expt() */ /* }}} */ /* {{{ mp_mod(a, m, c) */ /* mp_mod(a, m, c) Compute c = a (mod m). Result will always be 0 <= c < m. */ mp_err mp_mod(mp_int *a, mp_int *m, mp_int *c) { mp_err res; int mag; ARGCHK(a != NULL && m != NULL && c != NULL, MP_BADARG); if(SIGN(m) == MP_NEG) return MP_RANGE; /* If |a| > m, we need to divide to get the remainder and take the absolute value. If |a| < m, we don't need to do any division, just copy and adjust the sign (if a is negative). If |a| == m, we can simply set the result to zero. This order is intended to minimize the average path length of the comparison chain on common workloads -- the most frequent cases are that |a| != m, so we do those first. */ if((mag = s_mp_cmp(a, m)) > 0) { if((res = mp_div(a, m, NULL, c)) != MP_OKAY) return res; if(SIGN(c) == MP_NEG) { if((res = mp_add(c, m, c)) != MP_OKAY) return res; } } else if(mag < 0) { if((res = mp_copy(a, c)) != MP_OKAY) return res; if(mp_cmp_z(a) < 0) { if((res = mp_add(c, m, c)) != MP_OKAY) return res; } } else { mp_zero(c); } return MP_OKAY; } /* end mp_mod() */ /* }}} */ /* {{{ mp_mod_d(a, d, c) */ /* mp_mod_d(a, d, c) Compute c = a (mod d). Result will always be 0 <= c < d */ mp_err mp_mod_d(mp_int *a, mp_digit d, mp_digit *c) { mp_err res; mp_digit rem; ARGCHK(a != NULL && c != NULL, MP_BADARG); if(s_mp_cmp_d(a, d) > 0) { if((res = mp_div_d(a, d, NULL, &rem)) != MP_OKAY) return res; } else { if(SIGN(a) == MP_NEG) rem = d - DIGIT(a, 0); else rem = DIGIT(a, 0); } if(c) *c = rem; return MP_OKAY; } /* end mp_mod_d() */ /* }}} */ /* {{{ mp_sqrt(a, b) */ /* mp_sqrt(a, b) Compute the integer square root of a, and store the result in b. Uses an integer-arithmetic version of Newton's iterative linear approximation technique to determine this value; the result has the following two properties: b^2 <= a (b+1)^2 >= a It is a range error to pass a negative value. */ mp_err mp_sqrt(mp_int *a, mp_int *b) { mp_int x, t; mp_err res; ARGCHK(a != NULL && b != NULL, MP_BADARG); /* Cannot take square root of a negative value */ if(SIGN(a) == MP_NEG) return MP_RANGE; /* Special cases for zero and one, trivial */ if(mp_cmp_d(a, 0) == MP_EQ || mp_cmp_d(a, 1) == MP_EQ) return mp_copy(a, b); /* Initialize the temporaries we'll use below */ if((res = mp_init_size(&t, USED(a))) != MP_OKAY) return res; /* Compute an initial guess for the iteration as a itself */ if((res = mp_init_copy(&x, a)) != MP_OKAY) goto X; s_mp_rshd(&x, (USED(&x)/2)+1); mp_add_d(&x, 1, &x); for(;;) { /* t = (x * x) - a */ mp_copy(&x, &t); /* can't fail, t is big enough for original x */ if((res = mp_sqr(&t, &t)) != MP_OKAY || (res = mp_sub(&t, a, &t)) != MP_OKAY) goto CLEANUP; /* t = t / 2x */ s_mp_mul_2(&x); if((res = mp_div(&t, &x, &t, NULL)) != MP_OKAY) goto CLEANUP; s_mp_div_2(&x); /* Terminate the loop, if the quotient is zero */ if(mp_cmp_z(&t) == MP_EQ) break; /* x = x - t */ if((res = mp_sub(&x, &t, &x)) != MP_OKAY) goto CLEANUP; } /* Copy result to output parameter */ mp_sub_d(&x, 1, &x); s_mp_exch(&x, b); CLEANUP: mp_clear(&x); X: mp_clear(&t); return res; } /* end mp_sqrt() */ /* }}} */ /* }}} */ /*------------------------------------------------------------------------*/ /* {{{ Modular arithmetic */ #if MP_MODARITH /* {{{ mp_addmod(a, b, m, c) */ /* mp_addmod(a, b, m, c) Compute c = (a + b) mod m */ mp_err mp_addmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c) { mp_err res; ARGCHK(a != NULL && b != NULL && m != NULL && c != NULL, MP_BADARG); if((res = mp_add(a, b, c)) != MP_OKAY) return res; if((res = mp_mod(c, m, c)) != MP_OKAY) return res; return MP_OKAY; } /* }}} */ /* {{{ mp_submod(a, b, m, c) */ /* mp_submod(a, b, m, c) Compute c = (a - b) mod m */ mp_err mp_submod(mp_int *a, mp_int *b, mp_int *m, mp_int *c) { mp_err res; ARGCHK(a != NULL && b != NULL && m != NULL && c != NULL, MP_BADARG); if((res = mp_sub(a, b, c)) != MP_OKAY) return res; if((res = mp_mod(c, m, c)) != MP_OKAY) return res; return MP_OKAY; } /* }}} */ /* {{{ mp_mulmod(a, b, m, c) */ /* mp_mulmod(a, b, m, c) Compute c = (a * b) mod m */ mp_err mp_mulmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c) { mp_err res; ARGCHK(a != NULL && b != NULL && m != NULL && c != NULL, MP_BADARG); if((res = mp_mul(a, b, c)) != MP_OKAY) return res; if((res = mp_mod(c, m, c)) != MP_OKAY) return res; return MP_OKAY; } /* }}} */ /* {{{ mp_sqrmod(a, m, c) */ #if MP_SQUARE mp_err mp_sqrmod(mp_int *a, mp_int *m, mp_int *c) { mp_err res; ARGCHK(a != NULL && m != NULL && c != NULL, MP_BADARG); if((res = mp_sqr(a, c)) != MP_OKAY) return res; if((res = mp_mod(c, m, c)) != MP_OKAY) return res; return MP_OKAY; } /* end mp_sqrmod() */ #endif /* }}} */ /* {{{ mp_exptmod(a, b, m, c) */ /* mp_exptmod(a, b, m, c) Compute c = (a ** b) mod m. Uses a standard square-and-multiply method with modular reductions at each step. (This is basically the same code as mp_expt(), except for the addition of the reductions) The modular reductions are done using Barrett's algorithm (see s_mp_reduce() below for details) */ mp_err mp_exptmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c) { mp_int s, x, mu; mp_err res; mp_digit d, *db = DIGITS(b); mp_size ub = USED(b); int dig, bit; ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); if(mp_cmp_z(b) < 0 || mp_cmp_z(m) <= 0) return MP_RANGE; if((res = mp_init(&s)) != MP_OKAY) return res; if((res = mp_init_copy(&x, a)) != MP_OKAY) goto X; if((res = mp_mod(&x, m, &x)) != MP_OKAY || (res = mp_init(&mu)) != MP_OKAY) goto MU; mp_set(&s, 1); /* mu = b^2k / m */ s_mp_add_d(&mu, 1); s_mp_lshd(&mu, 2 * USED(m)); if((res = mp_div(&mu, m, &mu, NULL)) != MP_OKAY) goto CLEANUP; /* Loop over digits of b in ascending order, except highest order */ for(dig = 0; dig < (ub - 1); dig++) { d = *db++; /* Loop over the bits of the lower-order digits */ for(bit = 0; bit < DIGIT_BIT; bit++) { if(d & 1) { if((res = s_mp_mul(&s, &x)) != MP_OKAY) goto CLEANUP; if((res = s_mp_reduce(&s, m, &mu)) != MP_OKAY) goto CLEANUP; } d >>= 1; if((res = s_mp_sqr(&x)) != MP_OKAY) goto CLEANUP; if((res = s_mp_reduce(&x, m, &mu)) != MP_OKAY) goto CLEANUP; } } /* Now do the last digit... */ d = *db; while(d) { if(d & 1) { if((res = s_mp_mul(&s, &x)) != MP_OKAY) goto CLEANUP; if((res = s_mp_reduce(&s, m, &mu)) != MP_OKAY) goto CLEANUP; } d >>= 1; if((res = s_mp_sqr(&x)) != MP_OKAY) goto CLEANUP; if((res = s_mp_reduce(&x, m, &mu)) != MP_OKAY) goto CLEANUP; } s_mp_exch(&s, c); CLEANUP: mp_clear(&mu); MU: mp_clear(&x); X: mp_clear(&s); return res; } /* end mp_exptmod() */ /* }}} */ /* {{{ mp_exptmod_d(a, d, m, c) */ mp_err mp_exptmod_d(mp_int *a, mp_digit d, mp_int *m, mp_int *c) { mp_int s, x; mp_err res; ARGCHK(a != NULL && c != NULL, MP_BADARG); if((res = mp_init(&s)) != MP_OKAY) return res; if((res = mp_init_copy(&x, a)) != MP_OKAY) goto X; mp_set(&s, 1); while(d != 0) { if(d & 1) { if((res = s_mp_mul(&s, &x)) != MP_OKAY || (res = mp_mod(&s, m, &s)) != MP_OKAY) goto CLEANUP; } d /= 2; if((res = s_mp_sqr(&x)) != MP_OKAY || (res = mp_mod(&x, m, &x)) != MP_OKAY) goto CLEANUP; } s_mp_exch(&s, c); CLEANUP: mp_clear(&x); X: mp_clear(&s); return res; } /* end mp_exptmod_d() */ /* }}} */ #endif /* if MP_MODARITH */ /* }}} */ /*------------------------------------------------------------------------*/ /* {{{ Comparison functions */ /* {{{ mp_cmp_z(a) */ /* mp_cmp_z(a) Compare a <=> 0. Returns <0 if a<0, 0 if a=0, >0 if a>0. */ int mp_cmp_z(mp_int *a) { if(SIGN(a) == MP_NEG) return MP_LT; else if(USED(a) == 1 && DIGIT(a, 0) == 0) return MP_EQ; else return MP_GT; } /* end mp_cmp_z() */ /* }}} */ /* {{{ mp_cmp_d(a, d) */ /* mp_cmp_d(a, d) Compare a <=> d. Returns <0 if a<d, 0 if a=d, >0 if a>d */ int mp_cmp_d(mp_int *a, mp_digit d) { ARGCHK(a != NULL, MP_EQ); if(SIGN(a) == MP_NEG) return MP_LT; return s_mp_cmp_d(a, d); } /* end mp_cmp_d() */ /* }}} */ /* {{{ mp_cmp(a, b) */ int mp_cmp(mp_int *a, mp_int *b) { ARGCHK(a != NULL && b != NULL, MP_EQ); if(SIGN(a) == SIGN(b)) { int mag; if((mag = s_mp_cmp(a, b)) == MP_EQ) return MP_EQ; if(SIGN(a) == MP_ZPOS) return mag; else return -mag; } else if(SIGN(a) == MP_ZPOS) { return MP_GT; } else { return MP_LT; } } /* end mp_cmp() */ /* }}} */ /* {{{ mp_cmp_mag(a, b) */ /* mp_cmp_mag(a, b) Compares |a| <=> |b|, and returns an appropriate comparison result */ int mp_cmp_mag(mp_int *a, mp_int *b) { ARGCHK(a != NULL && b != NULL, MP_EQ); return s_mp_cmp(a, b); } /* end mp_cmp_mag() */ /* }}} */ /* {{{ mp_cmp_int(a, z) */ /* This just converts z to an mp_int, and uses the existing comparison routines. This is sort of inefficient, but it's not clear to me how frequently this wil get used anyway. For small positive constants, you can always use mp_cmp_d(), and for zero, there is mp_cmp_z(). */ int mp_cmp_int(mp_int *a, long z) { mp_int tmp; int out; ARGCHK(a != NULL, MP_EQ); mp_init(&tmp); mp_set_int(&tmp, z); out = mp_cmp(a, &tmp); mp_clear(&tmp); return out; } /* end mp_cmp_int() */ /* }}} */ /* {{{ mp_isodd(a) */ /* mp_isodd(a) Returns a true (non-zero) value if a is odd, false (zero) otherwise. */ int mp_isodd(mp_int *a) { ARGCHK(a != NULL, 0); return (DIGIT(a, 0) & 1); } /* end mp_isodd() */ /* }}} */ /* {{{ mp_iseven(a) */ int mp_iseven(mp_int *a) { return !mp_isodd(a); } /* end mp_iseven() */ /* }}} */ /* }}} */ /*------------------------------------------------------------------------*/ /* {{{ Number theoretic functions */ #if MP_NUMTH /* {{{ mp_gcd(a, b, c) */ /* Like the old mp_gcd() function, except computes the GCD using the binary algorithm due to Josef Stein in 1961 (via Knuth). */ mp_err mp_gcd(mp_int *a, mp_int *b, mp_int *c) { mp_err res; mp_int u, v, t; mp_size k = 0; ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); if(mp_cmp_z(a) == MP_EQ && mp_cmp_z(b) == MP_EQ) return MP_RANGE; if(mp_cmp_z(a) == MP_EQ) { return mp_copy(b, c); } else if(mp_cmp_z(b) == MP_EQ) { return mp_copy(a, c); } if((res = mp_init(&t)) != MP_OKAY) return res; if((res = mp_init_copy(&u, a)) != MP_OKAY) goto U; if((res = mp_init_copy(&v, b)) != MP_OKAY) goto V; SIGN(&u) = MP_ZPOS; SIGN(&v) = MP_ZPOS; /* Divide out common factors of 2 until at least 1 of a, b is even */ while(mp_iseven(&u) && mp_iseven(&v)) { s_mp_div_2(&u); s_mp_div_2(&v); ++k; } /* Initialize t */ if(mp_isodd(&u)) { if((res = mp_copy(&v, &t)) != MP_OKAY) goto CLEANUP; /* t = -v */ if(SIGN(&v) == MP_ZPOS) SIGN(&t) = MP_NEG; else SIGN(&t) = MP_ZPOS; } else { if((res = mp_copy(&u, &t)) != MP_OKAY) goto CLEANUP; } for(;;) { while(mp_iseven(&t)) { s_mp_div_2(&t); } if(mp_cmp_z(&t) == MP_GT) { if((res = mp_copy(&t, &u)) != MP_OKAY) goto CLEANUP; } else { if((res = mp_copy(&t, &v)) != MP_OKAY) goto CLEANUP; /* v = -t */ if(SIGN(&t) == MP_ZPOS) SIGN(&v) = MP_NEG; else SIGN(&v) = MP_ZPOS; } if((res = mp_sub(&u, &v, &t)) != MP_OKAY) goto CLEANUP; if(s_mp_cmp_d(&t, 0) == MP_EQ) break; } s_mp_2expt(&v, k); /* v = 2^k */ res = mp_mul(&u, &v, c); /* c = u * v */ CLEANUP: mp_clear(&v); V: mp_clear(&u); U: mp_clear(&t); return res; } /* end mp_bgcd() */ /* }}} */ /* {{{ mp_lcm(a, b, c) */ /* We compute the least common multiple using the rule: ab = [a, b](a, b) ... by computing the product, and dividing out the gcd. */ mp_err mp_lcm(mp_int *a, mp_int *b, mp_int *c) { mp_int gcd, prod; mp_err res; ARGCHK(a != NULL && b != NULL && c != NULL, MP_BADARG); /* Set up temporaries */ if((res = mp_init(&gcd)) != MP_OKAY) return res; if((res = mp_init(&prod)) != MP_OKAY) goto GCD; if((res = mp_mul(a, b, &prod)) != MP_OKAY) goto CLEANUP; if((res = mp_gcd(a, b, &gcd)) != MP_OKAY) goto CLEANUP; res = mp_div(&prod, &gcd, c, NULL); CLEANUP: mp_clear(&prod); GCD: mp_clear(&gcd); return res; } /* end mp_lcm() */ /* }}} */ /* {{{ mp_xgcd(a, b, g, x, y) */ /* mp_xgcd(a, b, g, x, y) Compute g = (a, b) and values x and y satisfying Bezout's identity (that is, ax + by = g). This uses the extended binary GCD algorithm based on the Stein algorithm used for mp_gcd() */ mp_err mp_xgcd(mp_int *a, mp_int *b, mp_int *g, mp_int *x, mp_int *y) { mp_int gx, xc, yc, u, v, A, B, C, D; mp_int *clean[9]; mp_err res; int last = -1; if(mp_cmp_z(b) == 0) return MP_RANGE; /* Initialize all these variables we need */ if((res = mp_init(&u)) != MP_OKAY) goto CLEANUP; clean[++last] = &u; if((res = mp_init(&v)) != MP_OKAY) goto CLEANUP; clean[++last] = &v; if((res = mp_init(&gx)) != MP_OKAY) goto CLEANUP; clean[++last] = &gx; if((res = mp_init(&A)) != MP_OKAY) goto CLEANUP; clean[++last] = &A; if((res = mp_init(&B)) != MP_OKAY) goto CLEANUP; clean[++last] = &B; if((res = mp_init(&C)) != MP_OKAY) goto CLEANUP; clean[++last] = &C; if((res = mp_init(&D)) != MP_OKAY) goto CLEANUP; clean[++last] = &D; if((res = mp_init_copy(&xc, a)) != MP_OKAY) goto CLEANUP; clean[++last] = &xc; mp_abs(&xc, &xc); if((res = mp_init_copy(&yc, b)) != MP_OKAY) goto CLEANUP; clean[++last] = &yc; mp_abs(&yc, &yc); mp_set(&gx, 1); /* Divide by two until at least one of them is even */ while(mp_iseven(&xc) && mp_iseven(&yc)) { s_mp_div_2(&xc); s_mp_div_2(&yc); if((res = s_mp_mul_2(&gx)) != MP_OKAY) goto CLEANUP; } mp_copy(&xc, &u); mp_copy(&yc, &v); mp_set(&A, 1); mp_set(&D, 1); /* Loop through binary GCD algorithm */ for(;;) { while(mp_iseven(&u)) { s_mp_div_2(&u); if(mp_iseven(&A) && mp_iseven(&B)) { s_mp_div_2(&A); s_mp_div_2(&B); } else { if((res = mp_add(&A, &yc, &A)) != MP_OKAY) goto CLEANUP; s_mp_div_2(&A); if((res = mp_sub(&B, &xc, &B)) != MP_OKAY) goto CLEANUP; s_mp_div_2(&B); } } while(mp_iseven(&v)) { s_mp_div_2(&v); if(mp_iseven(&C) && mp_iseven(&D)) { s_mp_div_2(&C); s_mp_div_2(&D); } else { if((res = mp_add(&C, &yc, &C)) != MP_OKAY) goto CLEANUP; s_mp_div_2(&C); if((res = mp_sub(&D, &xc, &D)) != MP_OKAY) goto CLEANUP; s_mp_div_2(&D); } } if(mp_cmp(&u, &v) >= 0) { if((res = mp_sub(&u, &v, &u)) != MP_OKAY) goto CLEANUP; if((res = mp_sub(&A, &C, &A)) != MP_OKAY) goto CLEANUP; if((res = mp_sub(&B, &D, &B)) != MP_OKAY) goto CLEANUP; } else { if((res = mp_sub(&v, &u, &v)) != MP_OKAY) goto CLEANUP; if((res = mp_sub(&C, &A, &C)) != MP_OKAY) goto CLEANUP; if((res = mp_sub(&D, &B, &D)) != MP_OKAY) goto CLEANUP; } /* If we're done, copy results to output */ if(mp_cmp_z(&u) == 0) { if(x) if((res = mp_copy(&C, x)) != MP_OKAY) goto CLEANUP; if(y) if((res = mp_copy(&D, y)) != MP_OKAY) goto CLEANUP; if(g) if((res = mp_mul(&gx, &v, g)) != MP_OKAY) goto CLEANUP; break; } } CLEANUP: while(last >= 0) mp_clear(clean[last--]); return res; } /* end mp_xgcd() */ /* }}} */ /* {{{ mp_invmod(a, m, c) */ /* mp_invmod(a, m, c) Compute c = a^-1 (mod m), if there is an inverse for a (mod m). This is equivalent to the question of whether (a, m) = 1. If not, MP_UNDEF is returned, and there is no inverse. */ mp_err mp_invmod(mp_int *a, mp_int *m, mp_int *c) { mp_int g, x; mp_err res; ARGCHK(a && m && c, MP_BADARG); if(mp_cmp_z(a) == 0 || mp_cmp_z(m) == 0) return MP_RANGE; if((res = mp_init(&g)) != MP_OKAY) return res; if((res = mp_init(&x)) != MP_OKAY) goto X; if((res = mp_xgcd(a, m, &g, &x, NULL)) != MP_OKAY) goto CLEANUP; if(mp_cmp_d(&g, 1) != MP_EQ) { res = MP_UNDEF; goto CLEANUP; } res = mp_mod(&x, m, c); SIGN(c) = SIGN(a); CLEANUP: mp_clear(&x); X: mp_clear(&g); return res; } /* end mp_invmod() */ /* }}} */ #endif /* if MP_NUMTH */ /* }}} */ /*------------------------------------------------------------------------*/ /* {{{ mp_print(mp, ofp) */ #if MP_IOFUNC /* mp_print(mp, ofp) Print a textual representation of the given mp_int on the output stream 'ofp'. Output is generated using the internal radix. */ void mp_print(mp_int *mp, FILE *ofp) { int ix; if(mp == NULL || ofp == NULL) return; fputc((SIGN(mp) == MP_NEG) ? '-' : '+', ofp); for(ix = USED(mp) - 1; ix >= 0; ix--) { fprintf(ofp, DIGIT_FMT, DIGIT(mp, ix)); } } /* end mp_print() */ #endif /* if MP_IOFUNC */ /* }}} */ /*------------------------------------------------------------------------*/ /* {{{ More I/O Functions */ /* {{{ mp_read_signed_bin(mp, str, len) */ /* mp_read_signed_bin(mp, str, len) Read in a raw value (base 256) into the given mp_int */ mp_err mp_read_signed_bin(mp_int *mp, unsigned char *str, int len) { mp_err res; ARGCHK(mp != NULL && str != NULL && len > 0, MP_BADARG); if((res = mp_read_unsigned_bin(mp, str + 1, len - 1)) == MP_OKAY) { /* Get sign from first byte */ if(str[0]) SIGN(mp) = MP_NEG; else SIGN(mp) = MP_ZPOS; } return res; } /* end mp_read_signed_bin() */ /* }}} */ /* {{{ mp_signed_bin_size(mp) */ int mp_signed_bin_size(mp_int *mp) { ARGCHK(mp != NULL, 0); return mp_unsigned_bin_size(mp) + 1; } /* end mp_signed_bin_size() */ /* }}} */ /* {{{ mp_to_signed_bin(mp, str) */ mp_err mp_to_signed_bin(mp_int *mp, unsigned char *str) { ARGCHK(mp != NULL && str != NULL, MP_BADARG); /* Caller responsible for allocating enough memory (use mp_raw_size(mp)) */ str[0] = (char)SIGN(mp); return mp_to_unsigned_bin(mp, str + 1); } /* end mp_to_signed_bin() */ /* }}} */ /* {{{ mp_read_unsigned_bin(mp, str, len) */ /* mp_read_unsigned_bin(mp, str, len) Read in an unsigned value (base 256) into the given mp_int */ mp_err mp_read_unsigned_bin(mp_int *mp, unsigned char *str, int len) { int ix; mp_err res; ARGCHK(mp != NULL && str != NULL && len > 0, MP_BADARG); mp_zero(mp); for(ix = 0; ix < len; ix++) { if((res = s_mp_mul_2d(mp, CHAR_BIT)) != MP_OKAY) return res; if((res = mp_add_d(mp, str[ix], mp)) != MP_OKAY) return res; } return MP_OKAY; } /* end mp_read_unsigned_bin() */ /* }}} */ /* {{{ mp_unsigned_bin_size(mp) */ int mp_unsigned_bin_size(mp_int *mp) { mp_digit topdig; int count; ARGCHK(mp != NULL, 0); /* Special case for the value zero */ if(USED(mp) == 1 && DIGIT(mp, 0) == 0) return 1; count = (USED(mp) - 1) * sizeof(mp_digit); topdig = DIGIT(mp, USED(mp) - 1); while(topdig != 0) { ++count; topdig >>= CHAR_BIT; } return count; } /* end mp_unsigned_bin_size() */ /* }}} */ /* {{{ mp_to_unsigned_bin(mp, str) */ mp_err mp_to_unsigned_bin(mp_int *mp, unsigned char *str) { mp_digit *dp, *end, d; unsigned char *spos; ARGCHK(mp != NULL && str != NULL, MP_BADARG); dp = DIGITS(mp); end = dp + USED(mp) - 1; spos = str; /* Special case for zero, quick test */ if(dp == end && *dp == 0) { *str = '\0'; return MP_OKAY; } /* Generate digits in reverse order */ while(dp < end) { int ix; d = *dp; for(ix = 0; ix < sizeof(mp_digit); ++ix) { *spos = d & UCHAR_MAX; d >>= CHAR_BIT; ++spos; } ++dp; } /* Now handle last digit specially, high order zeroes are not written */ d = *end; while(d != 0) { *spos = d & UCHAR_MAX; d >>= CHAR_BIT; ++spos; } /* Reverse everything to get digits in the correct order */ while(--spos > str) { unsigned char t = *str; *str = *spos; *spos = t; ++str; } return MP_OKAY; } /* end mp_to_unsigned_bin() */ /* }}} */ /* {{{ mp_count_bits(mp) */ int mp_count_bits(mp_int *mp) { int len; mp_digit d; ARGCHK(mp != NULL, MP_BADARG); len = DIGIT_BIT * (USED(mp) - 1); d = DIGIT(mp, USED(mp) - 1); while(d != 0) { ++len; d >>= 1; } return len; } /* end mp_count_bits() */ /* }}} */ /* {{{ mp_read_radix(mp, str, radix) */ /* mp_read_radix(mp, str, radix) Read an integer from the given string, and set mp to the resulting value. The input is presumed to be in base 10. Leading non-digit characters are ignored, and the function reads until a non-digit character or the end of the string. */ mp_err mp_read_radix(mp_int *mp, unsigned char *str, int radix) { int ix = 0, val = 0; mp_err res; mp_sign sig = MP_ZPOS; ARGCHK(mp != NULL && str != NULL && radix >= 2 && radix <= MAX_RADIX, MP_BADARG); mp_zero(mp); /* Skip leading non-digit characters until a digit or '-' or '+' */ while(str[ix] && (s_mp_tovalue(str[ix], radix) < 0) && str[ix] != '-' && str[ix] != '+') { ++ix; } if(str[ix] == '-') { sig = MP_NEG; ++ix; } else if(str[ix] == '+') { sig = MP_ZPOS; /* this is the default anyway... */ ++ix; } while((val = s_mp_tovalue(str[ix], radix)) >= 0) { if((res = s_mp_mul_d(mp, radix)) != MP_OKAY) return res; if((res = s_mp_add_d(mp, val)) != MP_OKAY) return res; ++ix; } if(s_mp_cmp_d(mp, 0) == MP_EQ) SIGN(mp) = MP_ZPOS; else SIGN(mp) = sig; return MP_OKAY; } /* end mp_read_radix() */ /* }}} */ /* {{{ mp_radix_size(mp, radix) */ int mp_radix_size(mp_int *mp, int radix) { int len; ARGCHK(mp != NULL, 0); len = s_mp_outlen(mp_count_bits(mp), radix) + 1; /* for NUL terminator */ if(mp_cmp_z(mp) < 0) ++len; /* for sign */ return len; } /* end mp_radix_size() */ /* }}} */ /* {{{ mp_value_radix_size(num, qty, radix) */ /* num = number of digits qty = number of bits per digit radix = target base Return the number of digits in the specified radix that would be needed to express 'num' digits of 'qty' bits each. */ int mp_value_radix_size(int num, int qty, int radix) { ARGCHK(num >= 0 && qty > 0 && radix >= 2 && radix <= MAX_RADIX, 0); return s_mp_outlen(num * qty, radix); } /* end mp_value_radix_size() */ /* }}} */ /* {{{ mp_toradix(mp, str, radix) */ mp_err mp_toradix(mp_int *mp, unsigned char *str, int radix) { int ix, pos = 0; ARGCHK(mp != NULL && str != NULL, MP_BADARG); ARGCHK(radix > 1 && radix <= MAX_RADIX, MP_RANGE); if(mp_cmp_z(mp) == MP_EQ) { str[0] = '0'; str[1] = '\0'; } else { mp_err res; mp_int tmp; mp_sign sgn; mp_digit rem, rdx = (mp_digit)radix; char ch; if((res = mp_init_copy(&tmp, mp)) != MP_OKAY) return res; /* Save sign for later, and take absolute value */ sgn = SIGN(&tmp); SIGN(&tmp) = MP_ZPOS; /* Generate output digits in reverse order */ while(mp_cmp_z(&tmp) != 0) { if((res = s_mp_div_d(&tmp, rdx, &rem)) != MP_OKAY) { mp_clear(&tmp); return res; } /* Generate digits, use capital letters */ ch = s_mp_todigit(rem, radix, 0); str[pos++] = ch; } /* Add - sign if original value was negative */ if(sgn == MP_NEG) str[pos++] = '-'; /* Add trailing NUL to end the string */ str[pos--] = '\0'; /* Reverse the digits and sign indicator */ ix = 0; while(ix < pos) { char tmp = str[ix]; str[ix] = str[pos]; str[pos] = tmp; ++ix; --pos; } mp_clear(&tmp); } return MP_OKAY; } /* end mp_toradix() */ /* }}} */ /* {{{ mp_char2value(ch, r) */ int mp_char2value(char ch, int r) { return s_mp_tovalue(ch, r); } /* end mp_tovalue() */ /* }}} */ /* }}} */ /* {{{ mp_strerror(ec) */ /* mp_strerror(ec) Return a string describing the meaning of error code 'ec'. The string returned is allocated in static memory, so the caller should not attempt to modify or free the memory associated with this string. */ const char *mp_strerror(mp_err ec) { int aec = (ec < 0) ? -ec : ec; /* Code values are negative, so the senses of these comparisons are accurate */ if(ec < MP_LAST_CODE || ec > MP_OKAY) { return mp_err_string[0]; /* unknown error code */ } else { return mp_err_string[aec + 1]; } } /* end mp_strerror() */ /* }}} */ /*========================================================================*/ /*------------------------------------------------------------------------*/ /* Static function definitions (internal use only) */ /* {{{ Memory management */ /* {{{ s_mp_grow(mp, min) */ /* Make sure there are at least 'min' digits allocated to mp */ mp_err s_mp_grow(mp_int *mp, mp_size min) { if(min > ALLOC(mp)) { mp_digit *tmp; /* Set min to next nearest default precision block size */ min = ((min + (s_mp_defprec - 1)) / s_mp_defprec) * s_mp_defprec; if((tmp = s_mp_alloc(min, sizeof(mp_digit))) == NULL) return MP_MEM; s_mp_copy(DIGITS(mp), tmp, USED(mp)); #if MP_CRYPTO s_mp_setz(DIGITS(mp), ALLOC(mp)); #endif s_mp_free(DIGITS(mp)); DIGITS(mp) = tmp; ALLOC(mp) = min; } return MP_OKAY; } /* end s_mp_grow() */ /* }}} */ /* {{{ s_mp_pad(mp, min) */ /* Make sure the used size of mp is at least 'min', growing if needed */ mp_err s_mp_pad(mp_int *mp, mp_size min) { if(min > USED(mp)) { mp_err res; /* Make sure there is room to increase precision */ if(min > ALLOC(mp) && (res = s_mp_grow(mp, min)) != MP_OKAY) return res; /* Increase precision; should already be 0-filled */ USED(mp) = min; } return MP_OKAY; } /* end s_mp_pad() */ /* }}} */ /* {{{ s_mp_setz(dp, count) */ #if MP_MACRO == 0 /* Set 'count' digits pointed to by dp to be zeroes */ void s_mp_setz(mp_digit *dp, mp_size count) { #if MP_MEMSET == 0 int ix; for(ix = 0; ix < count; ix++) dp[ix] = 0; #else memset(dp, 0, count * sizeof(mp_digit)); #endif } /* end s_mp_setz() */ #endif /* }}} */ /* {{{ s_mp_copy(sp, dp, count) */ #if MP_MACRO == 0 /* Copy 'count' digits from sp to dp */ void s_mp_copy(mp_digit *sp, mp_digit *dp, mp_size count) { #if MP_MEMCPY == 0 int ix; for(ix = 0; ix < count; ix++) dp[ix] = sp[ix]; #else memcpy(dp, sp, count * sizeof(mp_digit)); #endif } /* end s_mp_copy() */ #endif /* }}} */ /* {{{ s_mp_alloc(nb, ni) */ #if MP_MACRO == 0 /* Allocate ni records of nb bytes each, and return a pointer to that */ void *s_mp_alloc(size_t nb, size_t ni) { return calloc(nb, ni); } /* end s_mp_alloc() */ #endif /* }}} */ /* {{{ s_mp_free(ptr) */ #if MP_MACRO == 0 /* Free the memory pointed to by ptr */ void s_mp_free(void *ptr) { if(ptr) free(ptr); } /* end s_mp_free() */ #endif /* }}} */ /* {{{ s_mp_clamp(mp) */ /* Remove leading zeroes from the given value */ void s_mp_clamp(mp_int *mp) { mp_size du = USED(mp); mp_digit *zp = DIGITS(mp) + du - 1; while(du > 1 && !*zp--) --du; USED(mp) = du; } /* end s_mp_clamp() */ /* }}} */ /* {{{ s_mp_exch(a, b) */ /* Exchange the data for a and b; (b, a) = (a, b) */ void s_mp_exch(mp_int *a, mp_int *b) { mp_int tmp; tmp = *a; *a = *b; *b = tmp; } /* end s_mp_exch() */ /* }}} */ /* }}} */ /* {{{ Arithmetic helpers */ /* {{{ s_mp_lshd(mp, p) */ /* Shift mp leftward by p digits, growing if needed, and zero-filling the in-shifted digits at the right end. This is a convenient alternative to multiplication by powers of the radix */ mp_err s_mp_lshd(mp_int *mp, mp_size p) { mp_err res; mp_size pos; mp_digit *dp; int ix; if(p == 0) return MP_OKAY; if((res = s_mp_pad(mp, USED(mp) + p)) != MP_OKAY) return res; pos = USED(mp) - 1; dp = DIGITS(mp); /* Shift all the significant figures over as needed */ for(ix = pos - p; ix >= 0; ix--) dp[ix + p] = dp[ix]; /* Fill the bottom digits with zeroes */ for(ix = 0; ix < p; ix++) dp[ix] = 0; return MP_OKAY; } /* end s_mp_lshd() */ /* }}} */ /* {{{ s_mp_rshd(mp, p) */ /* Shift mp rightward by p digits. Maintains the invariant that digits above the precision are all zero. Digits shifted off the end are lost. Cannot fail. */ void s_mp_rshd(mp_int *mp, mp_size p) { mp_size ix; mp_digit *dp; if(p == 0) return; /* Shortcut when all digits are to be shifted off */ if(p >= USED(mp)) { s_mp_setz(DIGITS(mp), ALLOC(mp)); USED(mp) = 1; SIGN(mp) = MP_ZPOS; return; } /* Shift all the significant figures over as needed */ dp = DIGITS(mp); for(ix = p; ix < USED(mp); ix++) dp[ix - p] = dp[ix]; /* Fill the top digits with zeroes */ ix -= p; while(ix < USED(mp)) dp[ix++] = 0; /* Strip off any leading zeroes */ s_mp_clamp(mp); } /* end s_mp_rshd() */ /* }}} */ /* {{{ s_mp_div_2(mp) */ /* Divide by two -- take advantage of radix properties to do it fast */ void s_mp_div_2(mp_int *mp) { s_mp_div_2d(mp, 1); } /* end s_mp_div_2() */ /* }}} */ /* {{{ s_mp_mul_2(mp) */ mp_err s_mp_mul_2(mp_int *mp) { int ix; mp_digit kin = 0, kout, *dp = DIGITS(mp); mp_err res; /* Shift digits leftward by 1 bit */ for(ix = 0; ix < USED(mp); ix++) { kout = (dp[ix] >> (DIGIT_BIT - 1)) & 1; dp[ix] = (dp[ix] << 1) | kin; kin = kout; } /* Deal with rollover from last digit */ if(kin) { if(ix >= ALLOC(mp)) { if((res = s_mp_grow(mp, ALLOC(mp) + 1)) != MP_OKAY) return res; dp = DIGITS(mp); } dp[ix] = kin; USED(mp) += 1; } return MP_OKAY; } /* end s_mp_mul_2() */ /* }}} */ /* {{{ s_mp_mod_2d(mp, d) */ /* Remainder the integer by 2^d, where d is a number of bits. This amounts to a bitwise AND of the value, and does not require the full division code */ void s_mp_mod_2d(mp_int *mp, mp_digit d) { unsigned int ndig = (d / DIGIT_BIT), nbit = (d % DIGIT_BIT); unsigned int ix; mp_digit dmask, *dp = DIGITS(mp); if(ndig >= USED(mp)) return; /* Flush all the bits above 2^d in its digit */ dmask = (1 << nbit) - 1; dp[ndig] &= dmask; /* Flush all digits above the one with 2^d in it */ for(ix = ndig + 1; ix < USED(mp); ix++) dp[ix] = 0; s_mp_clamp(mp); } /* end s_mp_mod_2d() */ /* }}} */ /* {{{ s_mp_mul_2d(mp, d) */ /* Multiply by the integer 2^d, where d is a number of bits. This amounts to a bitwise shift of the value, and does not require the full multiplication code. */ mp_err s_mp_mul_2d(mp_int *mp, mp_digit d) { mp_err res; mp_digit save, next, mask, *dp; mp_size used; int ix; if((res = s_mp_lshd(mp, d / DIGIT_BIT)) != MP_OKAY) return res; dp = DIGITS(mp); used = USED(mp); d %= DIGIT_BIT; mask = (1 << d) - 1; /* If the shift requires another digit, make sure we've got one to work with */ if((dp[used - 1] >> (DIGIT_BIT - d)) & mask) { if((res = s_mp_grow(mp, used + 1)) != MP_OKAY) return res; dp = DIGITS(mp); } /* Do the shifting... */ save = 0; for(ix = 0; ix < used; ix++) { next = (dp[ix] >> (DIGIT_BIT - d)) & mask; dp[ix] = (dp[ix] << d) | save; save = next; } /* If, at this point, we have a nonzero carryout into the next digit, we'll increase the size by one digit, and store it... */ if(save) { dp[used] = save; USED(mp) += 1; } s_mp_clamp(mp); return MP_OKAY; } /* end s_mp_mul_2d() */ /* }}} */ /* {{{ s_mp_div_2d(mp, d) */ /* Divide the integer by 2^d, where d is a number of bits. This amounts to a bitwise shift of the value, and does not require the full division code (used in Barrett reduction, see below) */ void s_mp_div_2d(mp_int *mp, mp_digit d) { int ix; mp_digit save, next, mask, *dp = DIGITS(mp); s_mp_rshd(mp, d / DIGIT_BIT); d %= DIGIT_BIT; mask = (1 << d) - 1; save = 0; for(ix = USED(mp) - 1; ix >= 0; ix--) { next = dp[ix] & mask; dp[ix] = (dp[ix] >> d) | (save << (DIGIT_BIT - d)); save = next; } s_mp_clamp(mp); } /* end s_mp_div_2d() */ /* }}} */ /* {{{ s_mp_norm(a, b) */ /* s_mp_norm(a, b) Normalize a and b for division, where b is the divisor. In order that we might make good guesses for quotient digits, we want the leading digit of b to be at least half the radix, which we accomplish by multiplying a and b by a constant. This constant is returned (so that it can be divided back out of the remainder at the end of the division process). We multiply by the smallest power of 2 that gives us a leading digit at least half the radix. By choosing a power of 2, we simplify the multiplication and division steps to simple shifts. */ mp_digit s_mp_norm(mp_int *a, mp_int *b) { mp_digit t, d = 0; t = DIGIT(b, USED(b) - 1); while(t < (RADIX / 2)) { t <<= 1; ++d; } if(d != 0) { s_mp_mul_2d(a, d); s_mp_mul_2d(b, d); } return d; } /* end s_mp_norm() */ /* }}} */ /* }}} */ /* {{{ Primitive digit arithmetic */ /* {{{ s_mp_add_d(mp, d) */ /* Add d to |mp| in place */ mp_err s_mp_add_d(mp_int *mp, mp_digit d) /* unsigned digit addition */ { mp_word w, k = 0; mp_size ix = 1, used = USED(mp); mp_digit *dp = DIGITS(mp); w = dp[0] + d; dp[0] = ACCUM(w); k = CARRYOUT(w); while(ix < used && k) { w = dp[ix] + k; dp[ix] = ACCUM(w); k = CARRYOUT(w); ++ix; } if(k != 0) { mp_err res; if((res = s_mp_pad(mp, USED(mp) + 1)) != MP_OKAY) return res; DIGIT(mp, ix) = k; } return MP_OKAY; } /* end s_mp_add_d() */ /* }}} */ /* {{{ s_mp_sub_d(mp, d) */ /* Subtract d from |mp| in place, assumes |mp| > d */ mp_err s_mp_sub_d(mp_int *mp, mp_digit d) /* unsigned digit subtract */ { mp_word w, b = 0; mp_size ix = 1, used = USED(mp); mp_digit *dp = DIGITS(mp); /* Compute initial subtraction */ w = (RADIX + dp[0]) - d; b = CARRYOUT(w) ? 0 : 1; dp[0] = ACCUM(w); /* Propagate borrows leftward */ while(b && ix < used) { w = (RADIX + dp[ix]) - b; b = CARRYOUT(w) ? 0 : 1; dp[ix] = ACCUM(w); ++ix; } /* Remove leading zeroes */ s_mp_clamp(mp); /* If we have a borrow out, it's a violation of the input invariant */ if(b) return MP_RANGE; else return MP_OKAY; } /* end s_mp_sub_d() */ /* }}} */ /* {{{ s_mp_mul_d(a, d) */ /* Compute a = a * d, single digit multiplication */ mp_err s_mp_mul_d(mp_int *a, mp_digit d) { mp_word w, k = 0; mp_size ix, max; mp_err res; mp_digit *dp = DIGITS(a); /* Single-digit multiplication will increase the precision of the output by at most one digit. However, we can detect when this will happen -- if the high-order digit of a, times d, gives a two-digit result, then the precision of the result will increase; otherwise it won't. We use this fact to avoid calling s_mp_pad() unless absolutely necessary. */ max = USED(a); w = dp[max - 1] * d; if(CARRYOUT(w) != 0) { if((res = s_mp_pad(a, max + 1)) != MP_OKAY) return res; dp = DIGITS(a); } for(ix = 0; ix < max; ix++) { w = (dp[ix] * d) + k; dp[ix] = ACCUM(w); k = CARRYOUT(w); } /* If there is a precision increase, take care of it here; the above test guarantees we have enough storage to do this safely. */ if(k) { dp[max] = k; USED(a) = max + 1; } s_mp_clamp(a); return MP_OKAY; } /* end s_mp_mul_d() */ /* }}} */ /* {{{ s_mp_div_d(mp, d, r) */ /* s_mp_div_d(mp, d, r) Compute the quotient mp = mp / d and remainder r = mp mod d, for a single digit d. If r is null, the remainder will be discarded. */ mp_err s_mp_div_d(mp_int *mp, mp_digit d, mp_digit *r) { mp_word w = 0, t; mp_int quot; mp_err res; mp_digit *dp = DIGITS(mp), *qp; int ix; if(d == 0) return MP_RANGE; /* Make room for the quotient */ if((res = mp_init_size(", USED(mp))) != MP_OKAY) return res; USED(") = USED(mp); /* so clamping will work below */ qp = DIGITS("); /* Divide without subtraction */ for(ix = USED(mp) - 1; ix >= 0; ix--) { w = (w << DIGIT_BIT) | dp[ix]; if(w >= d) { t = w / d; w = w % d; } else { t = 0; } qp[ix] = t; } /* Deliver the remainder, if desired */ if(r) *r = w; s_mp_clamp("); mp_exch(", mp); mp_clear("); return MP_OKAY; } /* end s_mp_div_d() */ /* }}} */ /* }}} */ /* {{{ Primitive full arithmetic */ /* {{{ s_mp_add(a, b) */ /* Compute a = |a| + |b| */ mp_err s_mp_add(mp_int *a, mp_int *b) /* magnitude addition */ { mp_word w = 0; mp_digit *pa, *pb; mp_size ix, used = USED(b); mp_err res; /* Make sure a has enough precision for the output value */ if((used > USED(a)) && (res = s_mp_pad(a, used)) != MP_OKAY) return res; /* Add up all digits up to the precision of b. If b had initially the same precision as a, or greater, we took care of it by the padding step above, so there is no problem. If b had initially less precision, we'll have to make sure the carry out is duly propagated upward among the higher-order digits of the sum. */ pa = DIGITS(a); pb = DIGITS(b); for(ix = 0; ix < used; ++ix) { w += *pa + *pb++; *pa++ = ACCUM(w); w = CARRYOUT(w); } /* If we run out of 'b' digits before we're actually done, make sure the carries get propagated upward... */ used = USED(a); while(w && ix < used) { w += *pa; *pa++ = ACCUM(w); w = CARRYOUT(w); ++ix; } /* If there's an overall carry out, increase precision and include it. We could have done this initially, but why touch the memory allocator unless we're sure we have to? */ if(w) { if((res = s_mp_pad(a, used + 1)) != MP_OKAY) return res; DIGIT(a, ix) = w; /* pa may not be valid after s_mp_pad() call */ } return MP_OKAY; } /* end s_mp_add() */ /* }}} */ /* {{{ s_mp_sub(a, b) */ /* Compute a = |a| - |b|, assumes |a| >= |b| */ mp_err s_mp_sub(mp_int *a, mp_int *b) /* magnitude subtract */ { mp_word w = 0; mp_digit *pa, *pb; mp_size ix, used = USED(b); /* Subtract and propagate borrow. Up to the precision of b, this accounts for the digits of b; after that, we just make sure the carries get to the right place. This saves having to pad b out to the precision of a just to make the loops work right... */ pa = DIGITS(a); pb = DIGITS(b); for(ix = 0; ix < used; ++ix) { w = (RADIX + *pa) - w - *pb++; *pa++ = ACCUM(w); w = CARRYOUT(w) ? 0 : 1; } used = USED(a); while(ix < used) { w = RADIX + *pa - w; *pa++ = ACCUM(w); w = CARRYOUT(w) ? 0 : 1; ++ix; } /* Clobber any leading zeroes we created */ s_mp_clamp(a); /* If there was a borrow out, then |b| > |a| in violation of our input invariant. We've already done the work, but we'll at least complain about it... */ if(w) return MP_RANGE; else return MP_OKAY; } /* end s_mp_sub() */ /* }}} */ mp_err s_mp_reduce(mp_int *x, mp_int *m, mp_int *mu) { mp_int q; mp_err res; mp_size um = USED(m); if((res = mp_init_copy(&q, x)) != MP_OKAY) return res; s_mp_rshd(&q, um - 1); /* q1 = x / b^(k-1) */ s_mp_mul(&q, mu); /* q2 = q1 * mu */ s_mp_rshd(&q, um + 1); /* q3 = q2 / b^(k+1) */ /* x = x mod b^(k+1), quick (no division) */ s_mp_mod_2d(x, (mp_digit)(DIGIT_BIT * (um + 1))); /* q = q * m mod b^(k+1), quick (no division), uses the short multiplier */ #ifndef SHRT_MUL s_mp_mul(&q, m); s_mp_mod_2d(&q, (mp_digit)(DIGIT_BIT * (um + 1))); #else s_mp_mul_dig(&q, m, um + 1); #endif /* x = x - q */ if((res = mp_sub(x, &q, x)) != MP_OKAY) goto CLEANUP; /* If x < 0, add b^(k+1) to it */ if(mp_cmp_z(x) < 0) { mp_set(&q, 1); if((res = s_mp_lshd(&q, um + 1)) != MP_OKAY) goto CLEANUP; if((res = mp_add(x, &q, x)) != MP_OKAY) goto CLEANUP; } /* Back off if it's too big */ while(mp_cmp(x, m) >= 0) { if((res = s_mp_sub(x, m)) != MP_OKAY) break; } CLEANUP: mp_clear(&q); return res; } /* end s_mp_reduce() */ /* {{{ s_mp_mul(a, b) */ /* Compute a = |a| * |b| */ mp_err s_mp_mul(mp_int *a, mp_int *b) { mp_word w, k = 0; mp_int tmp; mp_err res; mp_size ix, jx, ua = USED(a), ub = USED(b); mp_digit *pa, *pb, *pt, *pbt; if((res = mp_init_size(&tmp, ua + ub)) != MP_OKAY) return res; /* This has the effect of left-padding with zeroes... */ USED(&tmp) = ua + ub; /* We're going to need the base value each iteration */ pbt = DIGITS(&tmp); /* Outer loop: Digits of b */ pb = DIGITS(b); for(ix = 0; ix < ub; ++ix, ++pb) { if(*pb == 0) continue; /* Inner product: Digits of a */ pa = DIGITS(a); for(jx = 0; jx < ua; ++jx, ++pa) { pt = pbt + ix + jx; w = *pb * *pa + k + *pt; *pt = ACCUM(w); k = CARRYOUT(w); } pbt[ix + jx] = k; k = 0; } s_mp_clamp(&tmp); s_mp_exch(&tmp, a); mp_clear(&tmp); return MP_OKAY; } /* end s_mp_mul() */ /* }}} */ /* {{{ s_mp_kmul(a, b, out, len) */ #if 0 void s_mp_kmul(mp_digit *a, mp_digit *b, mp_digit *out, mp_size len) { mp_word w, k = 0; mp_size ix, jx; mp_digit *pa, *pt; for(ix = 0; ix < len; ++ix, ++b) { if(*b == 0) continue; pa = a; for(jx = 0; jx < len; ++jx, ++pa) { pt = out + ix + jx; w = *b * *pa + k + *pt; *pt = ACCUM(w); k = CARRYOUT(w); } out[ix + jx] = k; k = 0; } } /* end s_mp_kmul() */ #endif /* }}} */ /* {{{ s_mp_sqr(a) */ /* Computes the square of a, in place. This can be done more efficiently than a general multiplication, because many of the computation steps are redundant when squaring. The inner product step is a bit more complicated, but we save a fair number of iterations of the multiplication loop. */ #if MP_SQUARE mp_err s_mp_sqr(mp_int *a) { mp_word w, k = 0; mp_int tmp; mp_err res; mp_size ix, jx, kx, used = USED(a); mp_digit *pa1, *pa2, *pt, *pbt; if((res = mp_init_size(&tmp, 2 * used)) != MP_OKAY) return res; /* Left-pad with zeroes */ USED(&tmp) = 2 * used; /* We need the base value each time through the loop */ pbt = DIGITS(&tmp); pa1 = DIGITS(a); for(ix = 0; ix < used; ++ix, ++pa1) { if(*pa1 == 0) continue; w = DIGIT(&tmp, ix + ix) + (*pa1 * *pa1); pbt[ix + ix] = ACCUM(w); k = CARRYOUT(w); /* The inner product is computed as: (C, S) = t[i,j] + 2 a[i] a[j] + C This can overflow what can be represented in an mp_word, and since C arithmetic does not provide any way to check for overflow, we have to check explicitly for overflow conditions before they happen. */ for(jx = ix + 1, pa2 = DIGITS(a) + jx; jx < used; ++jx, ++pa2) { mp_word u = 0, v; /* Store this in a temporary to avoid indirections later */ pt = pbt + ix + jx; /* Compute the multiplicative step */ w = *pa1 * *pa2; /* If w is more than half MP_WORD_MAX, the doubling will overflow, and we need to record a carry out into the next word */ u = (w >> (MP_WORD_BIT - 1)) & 1; /* Double what we've got, overflow will be ignored as defined for C arithmetic (we've already noted if it is to occur) */ w *= 2; /* Compute the additive step */ v = *pt + k; /* If we do not already have an overflow carry, check to see if the addition will cause one, and set the carry out if so */ u |= ((MP_WORD_MAX - v) < w); /* Add in the rest, again ignoring overflow */ w += v; /* Set the i,j digit of the output */ *pt = ACCUM(w); /* Save carry information for the next iteration of the loop. This is why k must be an mp_word, instead of an mp_digit */ k = CARRYOUT(w) | (u << DIGIT_BIT); } /* for(jx ...) */ /* Set the last digit in the cycle and reset the carry */ k = DIGIT(&tmp, ix + jx) + k; pbt[ix + jx] = ACCUM(k); k = CARRYOUT(k); /* If we are carrying out, propagate the carry to the next digit in the output. This may cascade, so we have to be somewhat circumspect -- but we will have enough precision in the output that we won't overflow */ kx = 1; while(k) { k = pbt[ix + jx + kx] + 1; pbt[ix + jx + kx] = ACCUM(k); k = CARRYOUT(k); ++kx; } } /* for(ix ...) */ s_mp_clamp(&tmp); s_mp_exch(&tmp, a); mp_clear(&tmp); return MP_OKAY; } /* end s_mp_sqr() */ #endif /* }}} */ /* {{{ s_mp_div(a, b) */ /* s_mp_div(a, b) Compute a = a / b and b = a mod b. Assumes b > a. */ mp_err s_mp_div(mp_int *a, mp_int *b) { mp_int quot, rem, t; mp_word q; mp_err res; mp_digit d; int ix; if(mp_cmp_z(b) == 0) return MP_RANGE; /* Shortcut if b is power of two */ if((ix = s_mp_ispow2(b)) >= 0) { mp_copy(a, b); /* need this for remainder */ s_mp_div_2d(a, (mp_digit)ix); s_mp_mod_2d(b, (mp_digit)ix); return MP_OKAY; } /* Allocate space to store the quotient */ if((res = mp_init_size(", USED(a))) != MP_OKAY) return res; /* A working temporary for division */ if((res = mp_init_size(&t, USED(a))) != MP_OKAY) goto T; /* Allocate space for the remainder */ if((res = mp_init_size(&rem, USED(a))) != MP_OKAY) goto REM; /* Normalize to optimize guessing */ d = s_mp_norm(a, b); /* Perform the division itself...woo! */ ix = USED(a) - 1; while(ix >= 0) { /* Find a partial substring of a which is at least b */ while(s_mp_cmp(&rem, b) < 0 && ix >= 0) { if((res = s_mp_lshd(&rem, 1)) != MP_OKAY) goto CLEANUP; if((res = s_mp_lshd(", 1)) != MP_OKAY) goto CLEANUP; DIGIT(&rem, 0) = DIGIT(a, ix); s_mp_clamp(&rem); --ix; } /* If we didn't find one, we're finished dividing */ if(s_mp_cmp(&rem, b) < 0) break; /* Compute a guess for the next quotient digit */ q = DIGIT(&rem, USED(&rem) - 1); if(q <= DIGIT(b, USED(b) - 1) && USED(&rem) > 1) q = (q << DIGIT_BIT) | DIGIT(&rem, USED(&rem) - 2); q /= DIGIT(b, USED(b) - 1); /* The guess can be as much as RADIX + 1 */ if(q >= RADIX) q = RADIX - 1; /* See what that multiplies out to */ mp_copy(b, &t); if((res = s_mp_mul_d(&t, q)) != MP_OKAY) goto CLEANUP; /* If it's too big, back it off. We should not have to do this more than once, or, in rare cases, twice. Knuth describes a method by which this could be reduced to a maximum of once, but I didn't implement that here. */ while(s_mp_cmp(&t, &rem) > 0) { --q; s_mp_sub(&t, b); } /* At this point, q should be the right next digit */ if((res = s_mp_sub(&rem, &t)) != MP_OKAY) goto CLEANUP; /* Include the digit in the quotient. We allocated enough memory for any quotient we could ever possibly get, so we should not have to check for failures here */ DIGIT(", 0) = q; } /* Denormalize remainder */ if(d != 0) s_mp_div_2d(&rem, d); s_mp_clamp("); s_mp_clamp(&rem); /* Copy quotient back to output */ s_mp_exch(", a); /* Copy remainder back to output */ s_mp_exch(&rem, b); CLEANUP: mp_clear(&rem); REM: mp_clear(&t); T: mp_clear("); return res; } /* end s_mp_div() */ /* }}} */ /* {{{ s_mp_2expt(a, k) */ mp_err s_mp_2expt(mp_int *a, mp_digit k) { mp_err res; mp_size dig, bit; dig = k / DIGIT_BIT; bit = k % DIGIT_BIT; mp_zero(a); if((res = s_mp_pad(a, dig + 1)) != MP_OKAY) return res; DIGIT(a, dig) |= (1 << bit); return MP_OKAY; } /* end s_mp_2expt() */ /* }}} */ /* }}} */ /* }}} */ /* {{{ Primitive comparisons */ /* {{{ s_mp_cmp(a, b) */ /* Compare |a| <=> |b|, return 0 if equal, <0 if a<b, >0 if a>b */ int s_mp_cmp(mp_int *a, mp_int *b) { mp_size ua = USED(a), ub = USED(b); if(ua > ub) return MP_GT; else if(ua < ub) return MP_LT; else { int ix = ua - 1; mp_digit *ap = DIGITS(a) + ix, *bp = DIGITS(b) + ix; while(ix >= 0) { if(*ap > *bp) return MP_GT; else if(*ap < *bp) return MP_LT; --ap; --bp; --ix; } return MP_EQ; } } /* end s_mp_cmp() */ /* }}} */ /* {{{ s_mp_cmp_d(a, d) */ /* Compare |a| <=> d, return 0 if equal, <0 if a<d, >0 if a>d */ int s_mp_cmp_d(mp_int *a, mp_digit d) { mp_size ua = USED(a); mp_digit *ap = DIGITS(a); if(ua > 1) return MP_GT; if(*ap < d) return MP_LT; else if(*ap > d) return MP_GT; else return MP_EQ; } /* end s_mp_cmp_d() */ /* }}} */ /* {{{ s_mp_ispow2(v) */ /* Returns -1 if the value is not a power of two; otherwise, it returns k such that v = 2^k, i.e. lg(v). */ int s_mp_ispow2(mp_int *v) { mp_digit d, *dp; mp_size uv = USED(v); int extra = 0, ix; d = DIGIT(v, uv - 1); /* most significant digit of v */ while(d && ((d & 1) == 0)) { d >>= 1; ++extra; } if(d == 1) { ix = uv - 2; dp = DIGITS(v) + ix; while(ix >= 0) { if(*dp) return -1; /* not a power of two */ --dp; --ix; } return ((uv - 1) * DIGIT_BIT) + extra; } return -1; } /* end s_mp_ispow2() */ /* }}} */ /* {{{ s_mp_ispow2d(d) */ int s_mp_ispow2d(mp_digit d) { int pow = 0; while((d & 1) == 0) { ++pow; d >>= 1; } if(d == 1) return pow; return -1; } /* end s_mp_ispow2d() */ /* }}} */ /* }}} */ /* {{{ Primitive I/O helpers */ /* {{{ s_mp_tovalue(ch, r) */ /* Convert the given character to its digit value, in the given radix. If the given character is not understood in the given radix, -1 is returned. Otherwise the digit's numeric value is returned. The results will be odd if you use a radix < 2 or > 62, you are expected to know what you're up to. */ int s_mp_tovalue(char ch, int r) { int val, xch; if(r > 36) xch = ch; else xch = toupper(ch); if(isdigit(xch)) val = xch - '0'; else if(isupper(xch)) val = xch - 'A' + 10; else if(islower(xch)) val = xch - 'a' + 36; else if(xch == '+') val = 62; else if(xch == '/') val = 63; else return -1; if(val < 0 || val >= r) return -1; return val; } /* end s_mp_tovalue() */ /* }}} */ /* {{{ s_mp_todigit(val, r, low) */ /* Convert val to a radix-r digit, if possible. If val is out of range for r, returns zero. Otherwise, returns an ASCII character denoting the value in the given radix. The results may be odd if you use a radix < 2 or > 64, you are expected to know what you're doing. */ char s_mp_todigit(int val, int r, int low) { char ch; if(val < 0 || val >= r) return 0; ch = s_dmap_1[val]; if(r <= 36 && low) ch = tolower(ch); return ch; } /* end s_mp_todigit() */ /* }}} */ /* {{{ s_mp_outlen(bits, radix) */ /* Return an estimate for how long a string is needed to hold a radix r representation of a number with 'bits' significant bits. Does not include space for a sign or a NUL terminator. */ int s_mp_outlen(int bits, int r) { return (int)((double)bits * LOG_V_2(r)); } /* end s_mp_outlen() */ /* }}} */ /* }}} */ /*------------------------------------------------------------------------*/ /* HERE THERE BE DRAGONS */ /* crc==4242132123, version==2, Sat Feb 02 06:43:52 2002 */ /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/mtest/mpi.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | /* mpi.h by Michael J. Fromberger <[email protected]> Copyright (C) 1998 Michael J. Fromberger, All Rights Reserved Arbitrary precision integer arithmetic library $Id: mpi.h,v 1.1.1.1.2.1 2005/09/26 20:16:54 kennykb Exp $ */ #ifndef _H_MPI_ #define _H_MPI_ #include "mpi-config.h" #define MP_LT -1 #define MP_EQ 0 #define MP_GT 1 #if MP_DEBUG #undef MP_IOFUNC #define MP_IOFUNC 1 #endif #if MP_IOFUNC #include <stdio.h> #include <ctype.h> #endif #include <limits.h> #define MP_NEG 1 #define MP_ZPOS 0 /* Included for compatibility... */ #define NEG MP_NEG #define ZPOS MP_ZPOS #define MP_OKAY 0 /* no error, all is well */ #define MP_YES 0 /* yes (boolean result) */ #define MP_NO -1 /* no (boolean result) */ #define MP_MEM -2 /* out of memory */ #define MP_RANGE -3 /* argument out of range */ #define MP_BADARG -4 /* invalid parameter */ #define MP_UNDEF -5 /* answer is undefined */ #define MP_LAST_CODE MP_UNDEF #include "mpi-types.h" /* Included for compatibility... */ #define DIGIT_BIT MP_DIGIT_BIT #define DIGIT_MAX MP_DIGIT_MAX /* Macros for accessing the mp_int internals */ #define SIGN(MP) ((MP)->sign) #define USED(MP) ((MP)->used) #define ALLOC(MP) ((MP)->alloc) #define DIGITS(MP) ((MP)->dp) #define DIGIT(MP,N) (MP)->dp[(N)] #if MP_ARGCHK == 1 #define ARGCHK(X,Y) {if(!(X)){return (Y);}} #elif MP_ARGCHK == 2 #include <assert.h> #define ARGCHK(X,Y) assert(X) #else #define ARGCHK(X,Y) /* */ #endif /* This defines the maximum I/O base (minimum is 2) */ #define MAX_RADIX 64 typedef struct { mp_sign sign; /* sign of this quantity */ mp_size alloc; /* how many digits allocated */ mp_size used; /* how many digits used */ mp_digit *dp; /* the digits themselves */ } mp_int; /*------------------------------------------------------------------------*/ /* Default precision */ unsigned int mp_get_prec(void); void mp_set_prec(unsigned int prec); /*------------------------------------------------------------------------*/ /* Memory management */ mp_err mp_init(mp_int *mp); mp_err mp_init_array(mp_int mp[], int count); mp_err mp_init_size(mp_int *mp, mp_size prec); mp_err mp_init_copy(mp_int *mp, mp_int *from); mp_err mp_copy(mp_int *from, mp_int *to); void mp_exch(mp_int *mp1, mp_int *mp2); void mp_clear(mp_int *mp); void mp_clear_array(mp_int mp[], int count); void mp_zero(mp_int *mp); void mp_set(mp_int *mp, mp_digit d); mp_err mp_set_int(mp_int *mp, long z); mp_err mp_shrink(mp_int *a); /*------------------------------------------------------------------------*/ /* Single digit arithmetic */ mp_err mp_add_d(mp_int *a, mp_digit d, mp_int *b); mp_err mp_sub_d(mp_int *a, mp_digit d, mp_int *b); mp_err mp_mul_d(mp_int *a, mp_digit d, mp_int *b); mp_err mp_mul_2(mp_int *a, mp_int *c); mp_err mp_div_d(mp_int *a, mp_digit d, mp_int *q, mp_digit *r); mp_err mp_div_2(mp_int *a, mp_int *c); mp_err mp_expt_d(mp_int *a, mp_digit d, mp_int *c); /*------------------------------------------------------------------------*/ /* Sign manipulations */ mp_err mp_abs(mp_int *a, mp_int *b); mp_err mp_neg(mp_int *a, mp_int *b); /*------------------------------------------------------------------------*/ /* Full arithmetic */ mp_err mp_add(mp_int *a, mp_int *b, mp_int *c); mp_err mp_sub(mp_int *a, mp_int *b, mp_int *c); mp_err mp_mul(mp_int *a, mp_int *b, mp_int *c); mp_err mp_mul_2d(mp_int *a, mp_digit d, mp_int *c); #if MP_SQUARE mp_err mp_sqr(mp_int *a, mp_int *b); #else #define mp_sqr(a, b) mp_mul(a, a, b) #endif mp_err mp_div(mp_int *a, mp_int *b, mp_int *q, mp_int *r); mp_err mp_div_2d(mp_int *a, mp_digit d, mp_int *q, mp_int *r); mp_err mp_expt(mp_int *a, mp_int *b, mp_int *c); mp_err mp_2expt(mp_int *a, mp_digit k); mp_err mp_sqrt(mp_int *a, mp_int *b); /*------------------------------------------------------------------------*/ /* Modular arithmetic */ #if MP_MODARITH mp_err mp_mod(mp_int *a, mp_int *m, mp_int *c); mp_err mp_mod_d(mp_int *a, mp_digit d, mp_digit *c); mp_err mp_addmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c); mp_err mp_submod(mp_int *a, mp_int *b, mp_int *m, mp_int *c); mp_err mp_mulmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c); #if MP_SQUARE mp_err mp_sqrmod(mp_int *a, mp_int *m, mp_int *c); #else #define mp_sqrmod(a, m, c) mp_mulmod(a, a, m, c) #endif mp_err mp_exptmod(mp_int *a, mp_int *b, mp_int *m, mp_int *c); mp_err mp_exptmod_d(mp_int *a, mp_digit d, mp_int *m, mp_int *c); #endif /* MP_MODARITH */ /*------------------------------------------------------------------------*/ /* Comparisons */ int mp_cmp_z(mp_int *a); int mp_cmp_d(mp_int *a, mp_digit d); int mp_cmp(mp_int *a, mp_int *b); int mp_cmp_mag(mp_int *a, mp_int *b); int mp_cmp_int(mp_int *a, long z); int mp_isodd(mp_int *a); int mp_iseven(mp_int *a); /*------------------------------------------------------------------------*/ /* Number theoretic */ #if MP_NUMTH mp_err mp_gcd(mp_int *a, mp_int *b, mp_int *c); mp_err mp_lcm(mp_int *a, mp_int *b, mp_int *c); mp_err mp_xgcd(mp_int *a, mp_int *b, mp_int *g, mp_int *x, mp_int *y); mp_err mp_invmod(mp_int *a, mp_int *m, mp_int *c); #endif /* end MP_NUMTH */ /*------------------------------------------------------------------------*/ /* Input and output */ #if MP_IOFUNC void mp_print(mp_int *mp, FILE *ofp); #endif /* end MP_IOFUNC */ /*------------------------------------------------------------------------*/ /* Base conversion */ #define BITS 1 #define BYTES CHAR_BIT mp_err mp_read_signed_bin(mp_int *mp, unsigned char *str, int len); int mp_signed_bin_size(mp_int *mp); mp_err mp_to_signed_bin(mp_int *mp, unsigned char *str); mp_err mp_read_unsigned_bin(mp_int *mp, unsigned char *str, int len); int mp_unsigned_bin_size(mp_int *mp); mp_err mp_to_unsigned_bin(mp_int *mp, unsigned char *str); int mp_count_bits(mp_int *mp); #if MP_COMPAT_MACROS #define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len)) #define mp_raw_size(mp) mp_signed_bin_size(mp) #define mp_toraw(mp, str) mp_to_signed_bin((mp), (str)) #define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len)) #define mp_mag_size(mp) mp_unsigned_bin_size(mp) #define mp_tomag(mp, str) mp_to_unsigned_bin((mp), (str)) #endif mp_err mp_read_radix(mp_int *mp, unsigned char *str, int radix); int mp_radix_size(mp_int *mp, int radix); int mp_value_radix_size(int num, int qty, int radix); mp_err mp_toradix(mp_int *mp, unsigned char *str, int radix); int mp_char2value(char ch, int r); #define mp_tobinary(M, S) mp_toradix((M), (S), 2) #define mp_tooctal(M, S) mp_toradix((M), (S), 8) #define mp_todecimal(M, S) mp_toradix((M), (S), 10) #define mp_tohex(M, S) mp_toradix((M), (S), 16) /*------------------------------------------------------------------------*/ /* Error strings */ const char *mp_strerror(mp_err ec); #endif /* end _H_MPI_ */ /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mpi.h,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/mtest/mtest.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 | /* makes a bignum test harness with NUM tests per operation * * the output is made in the following format [one parameter per line] operation operand1 operand2 [... operandN] result1 result2 [... resultN] So for example "a * b mod n" would be mulmod a b n a*b mod n e.g. if a=3, b=4 n=11 then mulmod 3 4 11 1 */ #ifdef MP_8BIT #define THE_MASK 127 #else #define THE_MASK 32767 #endif #include <stdio.h> #include <stdlib.h> #include <time.h> #include "mpi.c" FILE *rng; void rand_num(mp_int *a) { int n, size; unsigned char buf[2048]; size = 1 + ((fgetc(rng)<<8) + fgetc(rng)) % 101; buf[0] = (fgetc(rng)&1)?1:0; fread(buf+1, 1, size, rng); while (buf[1] == 0) buf[1] = fgetc(rng); mp_read_raw(a, buf, 1+size); } void rand_num2(mp_int *a) { int n, size; unsigned char buf[2048]; size = 10 + ((fgetc(rng)<<8) + fgetc(rng)) % 101; buf[0] = (fgetc(rng)&1)?1:0; fread(buf+1, 1, size, rng); while (buf[1] == 0) buf[1] = fgetc(rng); mp_read_raw(a, buf, 1+size); } #define mp_to64(a, b) mp_toradix(a, b, 64) int main(void) { int n, tmp; mp_int a, b, c, d, e; clock_t t1; char buf[4096]; mp_init(&a); mp_init(&b); mp_init(&c); mp_init(&d); mp_init(&e); /* initial (2^n - 1)^2 testing, makes sure the comba multiplier works [it has the new carry code] */ /* mp_set(&a, 1); for (n = 1; n < 8192; n++) { mp_mul(&a, &a, &c); printf("mul\n"); mp_to64(&a, buf); printf("%s\n%s\n", buf, buf); mp_to64(&c, buf); printf("%s\n", buf); mp_add_d(&a, 1, &a); mp_mul_2(&a, &a); mp_sub_d(&a, 1, &a); } */ rng = fopen("/dev/urandom", "rb"); if (rng == NULL) { rng = fopen("/dev/random", "rb"); if (rng == NULL) { fprintf(stderr, "\nWarning: stdin used as random source\n\n"); rng = stdin; } } t1 = clock(); for (;;) { #if 0 if (clock() - t1 > CLOCKS_PER_SEC) { sleep(2); t1 = clock(); } #endif n = fgetc(rng) % 15; if (n == 0) { /* add tests */ rand_num(&a); rand_num(&b); mp_add(&a, &b, &c); printf("add\n"); mp_to64(&a, buf); printf("%s\n", buf); mp_to64(&b, buf); printf("%s\n", buf); mp_to64(&c, buf); printf("%s\n", buf); } else if (n == 1) { /* sub tests */ rand_num(&a); rand_num(&b); mp_sub(&a, &b, &c); printf("sub\n"); mp_to64(&a, buf); printf("%s\n", buf); mp_to64(&b, buf); printf("%s\n", buf); mp_to64(&c, buf); printf("%s\n", buf); } else if (n == 2) { /* mul tests */ rand_num(&a); rand_num(&b); mp_mul(&a, &b, &c); printf("mul\n"); mp_to64(&a, buf); printf("%s\n", buf); mp_to64(&b, buf); printf("%s\n", buf); mp_to64(&c, buf); printf("%s\n", buf); } else if (n == 3) { /* div tests */ rand_num(&a); rand_num(&b); mp_div(&a, &b, &c, &d); printf("div\n"); mp_to64(&a, buf); printf("%s\n", buf); mp_to64(&b, buf); printf("%s\n", buf); mp_to64(&c, buf); printf("%s\n", buf); mp_to64(&d, buf); printf("%s\n", buf); } else if (n == 4) { /* sqr tests */ rand_num(&a); mp_sqr(&a, &b); printf("sqr\n"); mp_to64(&a, buf); printf("%s\n", buf); mp_to64(&b, buf); printf("%s\n", buf); } else if (n == 5) { /* mul_2d test */ rand_num(&a); mp_copy(&a, &b); n = fgetc(rng) & 63; mp_mul_2d(&b, n, &b); mp_to64(&a, buf); printf("mul2d\n"); printf("%s\n", buf); printf("%d\n", n); mp_to64(&b, buf); printf("%s\n", buf); } else if (n == 6) { /* div_2d test */ rand_num(&a); mp_copy(&a, &b); n = fgetc(rng) & 63; mp_div_2d(&b, n, &b, NULL); mp_to64(&a, buf); printf("div2d\n"); printf("%s\n", buf); printf("%d\n", n); mp_to64(&b, buf); printf("%s\n", buf); } else if (n == 7) { /* gcd test */ rand_num(&a); rand_num(&b); a.sign = MP_ZPOS; b.sign = MP_ZPOS; mp_gcd(&a, &b, &c); printf("gcd\n"); mp_to64(&a, buf); printf("%s\n", buf); mp_to64(&b, buf); printf("%s\n", buf); mp_to64(&c, buf); printf("%s\n", buf); } else if (n == 8) { /* lcm test */ rand_num(&a); rand_num(&b); a.sign = MP_ZPOS; b.sign = MP_ZPOS; mp_lcm(&a, &b, &c); printf("lcm\n"); mp_to64(&a, buf); printf("%s\n", buf); mp_to64(&b, buf); printf("%s\n", buf); mp_to64(&c, buf); printf("%s\n", buf); } else if (n == 9) { /* exptmod test */ rand_num2(&a); rand_num2(&b); rand_num2(&c); // if (c.dp[0]&1) mp_add_d(&c, 1, &c); a.sign = b.sign = c.sign = 0; mp_exptmod(&a, &b, &c, &d); printf("expt\n"); mp_to64(&a, buf); printf("%s\n", buf); mp_to64(&b, buf); printf("%s\n", buf); mp_to64(&c, buf); printf("%s\n", buf); mp_to64(&d, buf); printf("%s\n", buf); } else if (n == 10) { /* invmod test */ rand_num2(&a); rand_num2(&b); b.sign = MP_ZPOS; a.sign = MP_ZPOS; mp_gcd(&a, &b, &c); if (mp_cmp_d(&c, 1) != 0) continue; if (mp_cmp_d(&b, 1) == 0) continue; mp_invmod(&a, &b, &c); printf("invmod\n"); mp_to64(&a, buf); printf("%s\n", buf); mp_to64(&b, buf); printf("%s\n", buf); mp_to64(&c, buf); printf("%s\n", buf); } else if (n == 11) { rand_num(&a); mp_mul_2(&a, &a); mp_div_2(&a, &b); printf("div2\n"); mp_to64(&a, buf); printf("%s\n", buf); mp_to64(&b, buf); printf("%s\n", buf); } else if (n == 12) { rand_num2(&a); mp_mul_2(&a, &b); printf("mul2\n"); mp_to64(&a, buf); printf("%s\n", buf); mp_to64(&b, buf); printf("%s\n", buf); } else if (n == 13) { rand_num2(&a); tmp = abs(rand()) & THE_MASK; mp_add_d(&a, tmp, &b); printf("add_d\n"); mp_to64(&a, buf); printf("%s\n%d\n", buf, tmp); mp_to64(&b, buf); printf("%s\n", buf); } else if (n == 14) { rand_num2(&a); tmp = abs(rand()) & THE_MASK; mp_sub_d(&a, tmp, &b); printf("sub_d\n"); mp_to64(&a, buf); printf("%s\n%d\n", buf, tmp); mp_to64(&b, buf); printf("%s\n", buf); } } fclose(rng); return 0; } /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/mtest/mtest.c,v $ */ /* $Revision: 1.1.1.1.2.1 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/pics/expt_state.tif.
cannot compute difference between binary files
Added libtommath/pics/primality.tif.
cannot compute difference between binary files
Added libtommath/poster.pdf.
cannot compute difference between binary files
Added libtommath/pre_gen/mpi.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 6619 6620 6621 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 6808 6809 6810 6811 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 7013 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 7025 7026 7027 7028 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 7044 7045 7046 7047 7048 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 7084 7085 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 7096 7097 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 7123 7124 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 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 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 7430 7431 7432 7433 7434 7435 7436 7437 7438 7439 7440 7441 7442 7443 7444 7445 7446 7447 7448 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 7464 7465 7466 7467 7468 7469 7470 7471 7472 7473 7474 7475 7476 7477 7478 7479 7480 7481 7482 7483 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 7534 7535 7536 7537 7538 7539 7540 7541 7542 7543 7544 7545 7546 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 7583 7584 7585 7586 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 7659 7660 7661 7662 7663 7664 7665 7666 7667 7668 7669 7670 7671 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 7829 7830 7831 7832 7833 7834 7835 7836 7837 7838 7839 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 7881 7882 7883 7884 7885 7886 7887 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 7944 7945 7946 7947 7948 7949 7950 7951 7952 7953 7954 7955 7956 7957 7958 7959 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 8032 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 8053 8054 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 8100 8101 8102 8103 8104 8105 8106 8107 8108 8109 8110 8111 8112 8113 8114 8115 8116 8117 8118 8119 8120 8121 8122 8123 8124 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 8214 8215 8216 8217 8218 8219 8220 8221 8222 8223 8224 8225 8226 8227 8228 8229 8230 8231 8232 8233 8234 8235 8236 8237 8238 8239 8240 8241 8242 8243 8244 8245 8246 8247 8248 8249 8250 8251 8252 8253 8254 8255 8256 8257 8258 8259 8260 8261 8262 8263 8264 8265 8266 8267 8268 8269 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 8314 8315 8316 8317 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 8542 8543 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 8601 8602 8603 8604 8605 8606 8607 8608 8609 8610 8611 8612 8613 8614 8615 8616 8617 8618 8619 8620 8621 8622 8623 8624 8625 8626 8627 8628 8629 8630 8631 8632 8633 8634 8635 8636 8637 8638 8639 8640 8641 8642 8643 8644 8645 8646 8647 8648 8649 8650 8651 8652 8653 8654 8655 8656 8657 8658 8659 8660 8661 8662 8663 8664 8665 8666 8667 8668 8669 8670 8671 8672 8673 8674 8675 8676 8677 8678 8679 8680 8681 8682 8683 8684 8685 8686 8687 8688 8689 8690 8691 8692 8693 8694 8695 8696 8697 8698 8699 8700 8701 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 8715 8716 8717 8718 8719 8720 8721 8722 8723 8724 8725 8726 8727 8728 8729 8730 8731 8732 8733 8734 8735 8736 8737 8738 8739 8740 8741 8742 8743 8744 8745 8746 8747 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 8778 8779 8780 8781 8782 8783 8784 8785 8786 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 8806 8807 8808 8809 8810 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 8825 8826 8827 8828 8829 8830 8831 8832 8833 8834 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 8860 8861 8862 8863 8864 8865 8866 8867 8868 8869 8870 8871 8872 8873 8874 8875 8876 8877 8878 8879 8880 8881 8882 8883 8884 8885 8886 8887 8888 8889 8890 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 8914 8915 8916 8917 8918 8919 8920 8921 8922 8923 8924 8925 8926 8927 8928 8929 8930 8931 8932 8933 8934 8935 8936 8937 8938 8939 8940 8941 8942 8943 8944 8945 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 8977 8978 8979 8980 8981 8982 8983 8984 8985 8986 8987 8988 8989 8990 8991 8992 8993 8994 8995 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 9010 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 9053 9054 9055 9056 9057 9058 9059 9060 9061 9062 9063 9064 9065 9066 9067 9068 9069 9070 9071 9072 9073 9074 9075 9076 9077 9078 9079 9080 9081 9082 9083 9084 9085 9086 9087 9088 9089 9090 9091 9092 9093 9094 9095 9096 9097 9098 9099 9100 9101 9102 9103 9104 9105 9106 9107 9108 9109 9110 9111 9112 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 9123 9124 9125 9126 9127 9128 9129 9130 9131 9132 9133 9134 9135 9136 9137 9138 9139 9140 9141 9142 9143 9144 9145 9146 9147 9148 9149 9150 9151 9152 9153 9154 9155 9156 9157 9158 9159 9160 9161 9162 9163 9164 9165 9166 9167 9168 9169 9170 9171 9172 9173 9174 9175 9176 9177 9178 9179 9180 9181 9182 9183 9184 9185 9186 9187 9188 9189 9190 9191 9192 9193 9194 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 9206 9207 9208 9209 9210 9211 9212 9213 9214 9215 9216 9217 9218 9219 9220 9221 9222 9223 9224 9225 9226 9227 9228 9229 9230 9231 9232 9233 9234 9235 9236 9237 9238 9239 9240 9241 9242 9243 9244 9245 9246 9247 9248 9249 9250 9251 9252 9253 9254 9255 9256 9257 9258 9259 9260 9261 9262 9263 9264 9265 9266 9267 9268 9269 9270 9271 9272 9273 9274 9275 9276 9277 9278 9279 9280 9281 9282 9283 9284 9285 9286 9287 9288 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 9300 9301 9302 9303 9304 9305 9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 9317 9318 9319 9320 9321 9322 9323 9324 9325 9326 9327 9328 9329 9330 9331 9332 9333 9334 9335 9336 9337 9338 9339 9340 9341 9342 9343 9344 9345 9346 9347 9348 9349 9350 9351 9352 9353 9354 9355 9356 9357 9358 9359 9360 9361 9362 9363 9364 9365 9366 9367 9368 9369 9370 9371 9372 9373 9374 9375 9376 9377 9378 9379 9380 9381 9382 9383 9384 9385 9386 9387 9388 9389 9390 9391 9392 9393 9394 9395 9396 9397 9398 9399 9400 9401 9402 9403 9404 9405 9406 9407 9408 9409 9410 9411 9412 9413 9414 9415 9416 9417 9418 9419 9420 9421 9422 9423 9424 9425 9426 9427 9428 9429 9430 9431 9432 9433 9434 9435 9436 9437 9438 9439 9440 9441 9442 9443 9444 9445 9446 9447 9448 9449 9450 9451 9452 9453 9454 9455 9456 9457 9458 9459 9460 9461 9462 9463 9464 9465 9466 9467 9468 9469 9470 9471 9472 9473 9474 9475 9476 9477 9478 9479 9480 9481 9482 9483 9484 9485 9486 9487 9488 9489 9490 9491 9492 9493 9494 9495 9496 9497 9498 9499 9500 9501 9502 9503 9504 9505 9506 9507 9508 9509 9510 9511 9512 9513 9514 9515 9516 9517 9518 9519 | /* Start: bn_error.c */ #include <tommath.h> #ifdef BN_ERROR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ static const struct { int code; char *msg; } msgs[] = { { MP_OKAY, "Successful" }, { MP_MEM, "Out of heap" }, { MP_VAL, "Value out of range" } }; /* return a char * string for a given code */ char *mp_error_to_string(int code) { int x; /* scan the lookup table for the given message */ for (x = 0; x < (int)(sizeof(msgs) / sizeof(msgs[0])); x++) { if (msgs[x].code == code) { return msgs[x].msg; } } /* generic reply for invalid code */ return "Invalid error code"; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_error.c */ /* Start: bn_fast_mp_invmod.c */ #include <tommath.h> #ifdef BN_FAST_MP_INVMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes the modular inverse via binary extended euclidean algorithm, * that is c = 1/a mod b * * Based on slow invmod except this is optimized for the case where b is * odd as per HAC Note 14.64 on pp. 610 */ int fast_mp_invmod (mp_int * a, mp_int * b, mp_int * c) { mp_int x, y, u, v, B, D; int res, neg; /* 2. [modified] b must be odd */ if (mp_iseven (b) == 1) { return MP_VAL; } /* init all our temps */ if ((res = mp_init_multi(&x, &y, &u, &v, &B, &D, NULL)) != MP_OKAY) { return res; } /* x == modulus, y == value to invert */ if ((res = mp_copy (b, &x)) != MP_OKAY) { goto LBL_ERR; } /* we need y = |a| */ if ((res = mp_mod (a, b, &y)) != MP_OKAY) { goto LBL_ERR; } /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ if ((res = mp_copy (&x, &u)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_copy (&y, &v)) != MP_OKAY) { goto LBL_ERR; } mp_set (&D, 1); top: /* 4. while u is even do */ while (mp_iseven (&u) == 1) { /* 4.1 u = u/2 */ if ((res = mp_div_2 (&u, &u)) != MP_OKAY) { goto LBL_ERR; } /* 4.2 if B is odd then */ if (mp_isodd (&B) == 1) { if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) { goto LBL_ERR; } } /* B = B/2 */ if ((res = mp_div_2 (&B, &B)) != MP_OKAY) { goto LBL_ERR; } } /* 5. while v is even do */ while (mp_iseven (&v) == 1) { /* 5.1 v = v/2 */ if ((res = mp_div_2 (&v, &v)) != MP_OKAY) { goto LBL_ERR; } /* 5.2 if D is odd then */ if (mp_isodd (&D) == 1) { /* D = (D-x)/2 */ if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) { goto LBL_ERR; } } /* D = D/2 */ if ((res = mp_div_2 (&D, &D)) != MP_OKAY) { goto LBL_ERR; } } /* 6. if u >= v then */ if (mp_cmp (&u, &v) != MP_LT) { /* u = u - v, B = B - D */ if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) { goto LBL_ERR; } } else { /* v - v - u, D = D - B */ if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) { goto LBL_ERR; } } /* if not zero goto step 4 */ if (mp_iszero (&u) == 0) { goto top; } /* now a = C, b = D, gcd == g*v */ /* if v != 1 then there is no inverse */ if (mp_cmp_d (&v, 1) != MP_EQ) { res = MP_VAL; goto LBL_ERR; } /* b is now the inverse */ neg = a->sign; while (D.sign == MP_NEG) { if ((res = mp_add (&D, b, &D)) != MP_OKAY) { goto LBL_ERR; } } mp_exch (&D, c); c->sign = neg; res = MP_OKAY; LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &B, &D, NULL); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_fast_mp_invmod.c */ /* Start: bn_fast_mp_montgomery_reduce.c */ #include <tommath.h> #ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes xR**-1 == x (mod N) via Montgomery Reduction * * This is an optimized implementation of montgomery_reduce * which uses the comba method to quickly calculate the columns of the * reduction. * * Based on Algorithm 14.32 on pp.601 of HAC. */ int fast_mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) { int ix, res, olduse; mp_word W[MP_WARRAY]; /* get old used count */ olduse = x->used; /* grow a as required */ if (x->alloc < n->used + 1) { if ((res = mp_grow (x, n->used + 1)) != MP_OKAY) { return res; } } /* first we have to get the digits of the input into * an array of double precision words W[...] */ { register mp_word *_W; register mp_digit *tmpx; /* alias for the W[] array */ _W = W; /* alias for the digits of x*/ tmpx = x->dp; /* copy the digits of a into W[0..a->used-1] */ for (ix = 0; ix < x->used; ix++) { *_W++ = *tmpx++; } /* zero the high words of W[a->used..m->used*2] */ for (; ix < n->used * 2 + 1; ix++) { *_W++ = 0; } } /* now we proceed to zero successive digits * from the least significant upwards */ for (ix = 0; ix < n->used; ix++) { /* mu = ai * m' mod b * * We avoid a double precision multiplication (which isn't required) * by casting the value down to a mp_digit. Note this requires * that W[ix-1] have the carry cleared (see after the inner loop) */ register mp_digit mu; mu = (mp_digit) (((W[ix] & MP_MASK) * rho) & MP_MASK); /* a = a + mu * m * b**i * * This is computed in place and on the fly. The multiplication * by b**i is handled by offseting which columns the results * are added to. * * Note the comba method normally doesn't handle carries in the * inner loop In this case we fix the carry from the previous * column since the Montgomery reduction requires digits of the * result (so far) [see above] to work. This is * handled by fixing up one carry after the inner loop. The * carry fixups are done in order so after these loops the * first m->used words of W[] have the carries fixed */ { register int iy; register mp_digit *tmpn; register mp_word *_W; /* alias for the digits of the modulus */ tmpn = n->dp; /* Alias for the columns set by an offset of ix */ _W = W + ix; /* inner loop */ for (iy = 0; iy < n->used; iy++) { *_W++ += ((mp_word)mu) * ((mp_word)*tmpn++); } } /* now fix carry for next digit, W[ix+1] */ W[ix + 1] += W[ix] >> ((mp_word) DIGIT_BIT); } /* now we have to propagate the carries and * shift the words downward [all those least * significant digits we zeroed]. */ { register mp_digit *tmpx; register mp_word *_W, *_W1; /* nox fix rest of carries */ /* alias for current word */ _W1 = W + ix; /* alias for next word, where the carry goes */ _W = W + ++ix; for (; ix <= n->used * 2 + 1; ix++) { *_W++ += *_W1++ >> ((mp_word) DIGIT_BIT); } /* copy out, A = A/b**n * * The result is A/b**n but instead of converting from an * array of mp_word to mp_digit than calling mp_rshd * we just copy them in the right order */ /* alias for destination word */ tmpx = x->dp; /* alias for shifted double precision result */ _W = W + n->used; for (ix = 0; ix < n->used + 1; ix++) { *tmpx++ = (mp_digit)(*_W++ & ((mp_word) MP_MASK)); } /* zero oldused digits, if the input a was larger than * m->used+1 we'll have to clear the digits */ for (; ix < olduse; ix++) { *tmpx++ = 0; } } /* set the max used and clamp */ x->used = n->used + 1; mp_clamp (x); /* if A >= m then A = A - m */ if (mp_cmp_mag (x, n) != MP_LT) { return s_mp_sub (x, n, x); } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_fast_mp_montgomery_reduce.c */ /* Start: bn_fast_s_mp_mul_digs.c */ #include <tommath.h> #ifdef BN_FAST_S_MP_MUL_DIGS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Fast (comba) multiplier * * This is the fast column-array [comba] multiplier. It is * designed to compute the columns of the product first * then handle the carries afterwards. This has the effect * of making the nested loops that compute the columns very * simple and schedulable on super-scalar processors. * * This has been modified to produce a variable number of * digits of output so if say only a half-product is required * you don't have to compute the upper half (a feature * required for fast Barrett reduction). * * Based on Algorithm 14.12 on pp.595 of HAC. * */ int fast_s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) { int olduse, res, pa, ix, iz; mp_digit W[MP_WARRAY]; register mp_word _W; /* grow the destination as required */ if (c->alloc < digs) { if ((res = mp_grow (c, digs)) != MP_OKAY) { return res; } } /* number of output digits to produce */ pa = MIN(digs, a->used + b->used); /* clear the carry */ _W = 0; for (ix = 0; ix < pa; ix++) { int tx, ty; int iy; mp_digit *tmpx, *tmpy; /* get offsets into the two bignums */ ty = MIN(b->used-1, ix); tx = ix - ty; /* setup temp aliases */ tmpx = a->dp + tx; tmpy = b->dp + ty; /* this is the number of times the loop will iterrate, essentially while (tx++ < a->used && ty-- >= 0) { ... } */ iy = MIN(a->used-tx, ty+1); /* execute loop */ for (iz = 0; iz < iy; ++iz) { _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); } /* store term */ W[ix] = ((mp_digit)_W) & MP_MASK; /* make next carry */ _W = _W >> ((mp_word)DIGIT_BIT); } /* store final carry */ W[ix] = (mp_digit)(_W & MP_MASK); /* setup dest */ olduse = c->used; c->used = pa; { register mp_digit *tmpc; tmpc = c->dp; for (ix = 0; ix < pa+1; ix++) { /* now extract the previous digit [below the carry] */ *tmpc++ = W[ix]; } /* clear unused digits [that existed in the old copy of c] */ for (; ix < olduse; ix++) { *tmpc++ = 0; } } mp_clamp (c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_fast_s_mp_mul_digs.c */ /* Start: bn_fast_s_mp_mul_high_digs.c */ #include <tommath.h> #ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* this is a modified version of fast_s_mul_digs that only produces * output digits *above* digs. See the comments for fast_s_mul_digs * to see how it works. * * This is used in the Barrett reduction since for one of the multiplications * only the higher digits were needed. This essentially halves the work. * * Based on Algorithm 14.12 on pp.595 of HAC. */ int fast_s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) { int olduse, res, pa, ix, iz; mp_digit W[MP_WARRAY]; mp_word _W; /* grow the destination as required */ pa = a->used + b->used; if (c->alloc < pa) { if ((res = mp_grow (c, pa)) != MP_OKAY) { return res; } } /* number of output digits to produce */ pa = a->used + b->used; _W = 0; for (ix = digs; ix < pa; ix++) { int tx, ty, iy; mp_digit *tmpx, *tmpy; /* get offsets into the two bignums */ ty = MIN(b->used-1, ix); tx = ix - ty; /* setup temp aliases */ tmpx = a->dp + tx; tmpy = b->dp + ty; /* this is the number of times the loop will iterrate, essentially its while (tx++ < a->used && ty-- >= 0) { ... } */ iy = MIN(a->used-tx, ty+1); /* execute loop */ for (iz = 0; iz < iy; iz++) { _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); } /* store term */ W[ix] = ((mp_digit)_W) & MP_MASK; /* make next carry */ _W = _W >> ((mp_word)DIGIT_BIT); } /* store final carry */ W[ix] = (mp_digit)(_W & MP_MASK); /* setup dest */ olduse = c->used; c->used = pa; { register mp_digit *tmpc; tmpc = c->dp + digs; for (ix = digs; ix <= pa; ix++) { /* now extract the previous digit [below the carry] */ *tmpc++ = W[ix]; } /* clear unused digits [that existed in the old copy of c] */ for (; ix < olduse; ix++) { *tmpc++ = 0; } } mp_clamp (c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_fast_s_mp_mul_high_digs.c */ /* Start: bn_fast_s_mp_sqr.c */ #include <tommath.h> #ifdef BN_FAST_S_MP_SQR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* the jist of squaring... * you do like mult except the offset of the tmpx [one that * starts closer to zero] can't equal the offset of tmpy. * So basically you set up iy like before then you min it with * (ty-tx) so that it never happens. You double all those * you add in the inner loop After that loop you do the squares and add them in. */ int fast_s_mp_sqr (mp_int * a, mp_int * b) { int olduse, res, pa, ix, iz; mp_digit W[MP_WARRAY], *tmpx; mp_word W1; /* grow the destination as required */ pa = a->used + a->used; if (b->alloc < pa) { if ((res = mp_grow (b, pa)) != MP_OKAY) { return res; } } /* number of output digits to produce */ W1 = 0; for (ix = 0; ix < pa; ix++) { int tx, ty, iy; mp_word _W; mp_digit *tmpy; /* clear counter */ _W = 0; /* get offsets into the two bignums */ ty = MIN(a->used-1, ix); tx = ix - ty; /* setup temp aliases */ tmpx = a->dp + tx; tmpy = a->dp + ty; /* this is the number of times the loop will iterrate, essentially while (tx++ < a->used && ty-- >= 0) { ... } */ iy = MIN(a->used-tx, ty+1); /* now for squaring tx can never equal ty * we halve the distance since they approach at a rate of 2x * and we have to round because odd cases need to be executed */ iy = MIN(iy, (ty-tx+1)>>1); /* execute loop */ for (iz = 0; iz < iy; iz++) { _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--); } /* double the inner product and add carry */ _W = _W + _W + W1; /* even columns have the square term in them */ if ((ix&1) == 0) { _W += ((mp_word)a->dp[ix>>1])*((mp_word)a->dp[ix>>1]); } /* store it */ W[ix] = (mp_digit)(_W & MP_MASK); /* make next carry */ W1 = _W >> ((mp_word)DIGIT_BIT); } /* setup dest */ olduse = b->used; b->used = a->used+a->used; { mp_digit *tmpb; tmpb = b->dp; for (ix = 0; ix < pa; ix++) { *tmpb++ = W[ix] & MP_MASK; } /* clear unused digits [that existed in the old copy of c] */ for (; ix < olduse; ix++) { *tmpb++ = 0; } } mp_clamp (b); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_fast_s_mp_sqr.c */ /* Start: bn_mp_2expt.c */ #include <tommath.h> #ifdef BN_MP_2EXPT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes a = 2**b * * Simple algorithm which zeroes the int, grows it then just sets one bit * as required. */ int mp_2expt (mp_int * a, int b) { int res; /* zero a as per default */ mp_zero (a); /* grow a to accomodate the single bit */ if ((res = mp_grow (a, b / DIGIT_BIT + 1)) != MP_OKAY) { return res; } /* set the used count of where the bit will go */ a->used = b / DIGIT_BIT + 1; /* put the single bit in its place */ a->dp[b / DIGIT_BIT] = ((mp_digit)1) << (b % DIGIT_BIT); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_2expt.c */ /* Start: bn_mp_abs.c */ #include <tommath.h> #ifdef BN_MP_ABS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* b = |a| * * Simple function copies the input and fixes the sign to positive */ int mp_abs (mp_int * a, mp_int * b) { int res; /* copy a to b */ if (a != b) { if ((res = mp_copy (a, b)) != MP_OKAY) { return res; } } /* force the sign of b to positive */ b->sign = MP_ZPOS; return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_abs.c */ /* Start: bn_mp_add.c */ #include <tommath.h> #ifdef BN_MP_ADD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* high level addition (handles signs) */ int mp_add (mp_int * a, mp_int * b, mp_int * c) { int sa, sb, res; /* get sign of both inputs */ sa = a->sign; sb = b->sign; /* handle two cases, not four */ if (sa == sb) { /* both positive or both negative */ /* add their magnitudes, copy the sign */ c->sign = sa; res = s_mp_add (a, b, c); } else { /* one positive, the other negative */ /* subtract the one with the greater magnitude from */ /* the one of the lesser magnitude. The result gets */ /* the sign of the one with the greater magnitude. */ if (mp_cmp_mag (a, b) == MP_LT) { c->sign = sb; res = s_mp_sub (b, a, c); } else { c->sign = sa; res = s_mp_sub (a, b, c); } } return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_add.c */ /* Start: bn_mp_add_d.c */ #include <tommath.h> #ifdef BN_MP_ADD_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* single digit addition */ int mp_add_d (mp_int * a, mp_digit b, mp_int * c) { int res, ix, oldused; mp_digit *tmpa, *tmpc, mu; /* grow c as required */ if (c->alloc < a->used + 1) { if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) { return res; } } /* if a is negative and |a| >= b, call c = |a| - b */ if (a->sign == MP_NEG && (a->used > 1 || a->dp[0] >= b)) { /* temporarily fix sign of a */ a->sign = MP_ZPOS; /* c = |a| - b */ res = mp_sub_d(a, b, c); /* fix sign */ a->sign = c->sign = MP_NEG; return res; } /* old number of used digits in c */ oldused = c->used; /* sign always positive */ c->sign = MP_ZPOS; /* source alias */ tmpa = a->dp; /* destination alias */ tmpc = c->dp; /* if a is positive */ if (a->sign == MP_ZPOS) { /* add digit, after this we're propagating * the carry. */ *tmpc = *tmpa++ + b; mu = *tmpc >> DIGIT_BIT; *tmpc++ &= MP_MASK; /* now handle rest of the digits */ for (ix = 1; ix < a->used; ix++) { *tmpc = *tmpa++ + mu; mu = *tmpc >> DIGIT_BIT; *tmpc++ &= MP_MASK; } /* set final carry */ ix++; *tmpc++ = mu; /* setup size */ c->used = a->used + 1; } else { /* a was negative and |a| < b */ c->used = 1; /* the result is a single digit */ if (a->used == 1) { *tmpc++ = b - a->dp[0]; } else { *tmpc++ = b; } /* setup count so the clearing of oldused * can fall through correctly */ ix = 1; } /* now zero to oldused */ while (ix++ < oldused) { *tmpc++ = 0; } mp_clamp(c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_add_d.c */ /* Start: bn_mp_addmod.c */ #include <tommath.h> #ifdef BN_MP_ADDMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* d = a + b (mod c) */ int mp_addmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) { int res; mp_int t; if ((res = mp_init (&t)) != MP_OKAY) { return res; } if ((res = mp_add (a, b, &t)) != MP_OKAY) { mp_clear (&t); return res; } res = mp_mod (&t, c, d); mp_clear (&t); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_addmod.c */ /* Start: bn_mp_and.c */ #include <tommath.h> #ifdef BN_MP_AND_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* AND two ints together */ int mp_and (mp_int * a, mp_int * b, mp_int * c) { int res, ix, px; mp_int t, *x; if (a->used > b->used) { if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } px = b->used; x = b; } else { if ((res = mp_init_copy (&t, b)) != MP_OKAY) { return res; } px = a->used; x = a; } for (ix = 0; ix < px; ix++) { t.dp[ix] &= x->dp[ix]; } /* zero digits above the last from the smallest mp_int */ for (; ix < t.used; ix++) { t.dp[ix] = 0; } mp_clamp (&t); mp_exch (c, &t); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_and.c */ /* Start: bn_mp_clamp.c */ #include <tommath.h> #ifdef BN_MP_CLAMP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* trim unused digits * * This is used to ensure that leading zero digits are * trimed and the leading "used" digit will be non-zero * Typically very fast. Also fixes the sign if there * are no more leading digits */ void mp_clamp (mp_int * a) { /* decrease used while the most significant digit is * zero. */ while (a->used > 0 && a->dp[a->used - 1] == 0) { --(a->used); } /* reset the sign flag if used == 0 */ if (a->used == 0) { a->sign = MP_ZPOS; } } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_clamp.c */ /* Start: bn_mp_clear.c */ #include <tommath.h> #ifdef BN_MP_CLEAR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* clear one (frees) */ void mp_clear (mp_int * a) { int i; /* only do anything if a hasn't been freed previously */ if (a->dp != NULL) { /* first zero the digits */ for (i = 0; i < a->used; i++) { a->dp[i] = 0; } /* free ram */ XFREE(a->dp); /* reset members to make debugging easier */ a->dp = NULL; a->alloc = a->used = 0; a->sign = MP_ZPOS; } } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_clear.c */ /* Start: bn_mp_clear_multi.c */ #include <tommath.h> #ifdef BN_MP_CLEAR_MULTI_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ #include <stdarg.h> void mp_clear_multi(mp_int *mp, ...) { mp_int* next_mp = mp; va_list args; va_start(args, mp); while (next_mp != NULL) { mp_clear(next_mp); next_mp = va_arg(args, mp_int*); } va_end(args); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_clear_multi.c */ /* Start: bn_mp_cmp.c */ #include <tommath.h> #ifdef BN_MP_CMP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* compare two ints (signed)*/ int mp_cmp (mp_int * a, mp_int * b) { /* compare based on sign */ if (a->sign != b->sign) { if (a->sign == MP_NEG) { return MP_LT; } else { return MP_GT; } } /* compare digits */ if (a->sign == MP_NEG) { /* if negative compare opposite direction */ return mp_cmp_mag(b, a); } else { return mp_cmp_mag(a, b); } } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_cmp.c */ /* Start: bn_mp_cmp_d.c */ #include <tommath.h> #ifdef BN_MP_CMP_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* compare a digit */ int mp_cmp_d(mp_int * a, mp_digit b) { /* compare based on sign */ if (a->sign == MP_NEG) { return MP_LT; } /* compare based on magnitude */ if (a->used > 1) { return MP_GT; } /* compare the only digit of a to b */ if (a->dp[0] > b) { return MP_GT; } else if (a->dp[0] < b) { return MP_LT; } else { return MP_EQ; } } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_cmp_d.c */ /* Start: bn_mp_cmp_mag.c */ #include <tommath.h> #ifdef BN_MP_CMP_MAG_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* compare maginitude of two ints (unsigned) */ int mp_cmp_mag (mp_int * a, mp_int * b) { int n; mp_digit *tmpa, *tmpb; /* compare based on # of non-zero digits */ if (a->used > b->used) { return MP_GT; } if (a->used < b->used) { return MP_LT; } /* alias for a */ tmpa = a->dp + (a->used - 1); /* alias for b */ tmpb = b->dp + (a->used - 1); /* compare based on digits */ for (n = 0; n < a->used; ++n, --tmpa, --tmpb) { if (*tmpa > *tmpb) { return MP_GT; } if (*tmpa < *tmpb) { return MP_LT; } } return MP_EQ; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_cmp_mag.c */ /* Start: bn_mp_cnt_lsb.c */ #include <tommath.h> #ifdef BN_MP_CNT_LSB_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ static const int lnz[16] = { 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0 }; /* Counts the number of lsbs which are zero before the first zero bit */ int mp_cnt_lsb(mp_int *a) { int x; mp_digit q, qq; /* easy out */ if (mp_iszero(a) == 1) { return 0; } /* scan lower digits until non-zero */ for (x = 0; x < a->used && a->dp[x] == 0; x++); q = a->dp[x]; x *= DIGIT_BIT; /* now scan this digit until a 1 is found */ if ((q & 1) == 0) { do { qq = q & 15; x += lnz[qq]; q >>= 4; } while (qq == 0); } return x; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_cnt_lsb.c */ /* Start: bn_mp_copy.c */ #include <tommath.h> #ifdef BN_MP_COPY_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* copy, b = a */ int mp_copy (mp_int * a, mp_int * b) { int res, n; /* if dst == src do nothing */ if (a == b) { return MP_OKAY; } /* grow dest */ if (b->alloc < a->used) { if ((res = mp_grow (b, a->used)) != MP_OKAY) { return res; } } /* zero b and copy the parameters over */ { register mp_digit *tmpa, *tmpb; /* pointer aliases */ /* source */ tmpa = a->dp; /* destination */ tmpb = b->dp; /* copy all the digits */ for (n = 0; n < a->used; n++) { *tmpb++ = *tmpa++; } /* clear high digits */ for (; n < b->used; n++) { *tmpb++ = 0; } } /* copy used count and sign */ b->used = a->used; b->sign = a->sign; return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_copy.c */ /* Start: bn_mp_count_bits.c */ #include <tommath.h> #ifdef BN_MP_COUNT_BITS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* returns the number of bits in an int */ int mp_count_bits (mp_int * a) { int r; mp_digit q; /* shortcut */ if (a->used == 0) { return 0; } /* get number of digits and add that */ r = (a->used - 1) * DIGIT_BIT; /* take the last digit and count the bits in it */ q = a->dp[a->used - 1]; while (q > ((mp_digit) 0)) { ++r; q >>= ((mp_digit) 1); } return r; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_count_bits.c */ /* Start: bn_mp_div.c */ #include <tommath.h> #ifdef BN_MP_DIV_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ #ifdef BN_MP_DIV_SMALL /* slower bit-bang division... also smaller */ int mp_div(mp_int * a, mp_int * b, mp_int * c, mp_int * d) { mp_int ta, tb, tq, q; int res, n, n2; /* is divisor zero ? */ if (mp_iszero (b) == 1) { return MP_VAL; } /* if a < b then q=0, r = a */ if (mp_cmp_mag (a, b) == MP_LT) { if (d != NULL) { res = mp_copy (a, d); } else { res = MP_OKAY; } if (c != NULL) { mp_zero (c); } return res; } /* init our temps */ if ((res = mp_init_multi(&ta, &tb, &tq, &q, NULL) != MP_OKAY)) { return res; } mp_set(&tq, 1); n = mp_count_bits(a) - mp_count_bits(b); if (((res = mp_abs(a, &ta)) != MP_OKAY) || ((res = mp_abs(b, &tb)) != MP_OKAY) || ((res = mp_mul_2d(&tb, n, &tb)) != MP_OKAY) || ((res = mp_mul_2d(&tq, n, &tq)) != MP_OKAY)) { goto LBL_ERR; } while (n-- >= 0) { if (mp_cmp(&tb, &ta) != MP_GT) { if (((res = mp_sub(&ta, &tb, &ta)) != MP_OKAY) || ((res = mp_add(&q, &tq, &q)) != MP_OKAY)) { goto LBL_ERR; } } if (((res = mp_div_2d(&tb, 1, &tb, NULL)) != MP_OKAY) || ((res = mp_div_2d(&tq, 1, &tq, NULL)) != MP_OKAY)) { goto LBL_ERR; } } /* now q == quotient and ta == remainder */ n = a->sign; n2 = (a->sign == b->sign ? MP_ZPOS : MP_NEG); if (c != NULL) { mp_exch(c, &q); c->sign = (mp_iszero(c) == MP_YES) ? MP_ZPOS : n2; } if (d != NULL) { mp_exch(d, &ta); d->sign = (mp_iszero(d) == MP_YES) ? MP_ZPOS : n; } LBL_ERR: mp_clear_multi(&ta, &tb, &tq, &q, NULL); return res; } #else /* integer signed division. * c*b + d == a [e.g. a/b, c=quotient, d=remainder] * HAC pp.598 Algorithm 14.20 * * Note that the description in HAC is horribly * incomplete. For example, it doesn't consider * the case where digits are removed from 'x' in * the inner loop. It also doesn't consider the * case that y has fewer than three digits, etc.. * * The overall algorithm is as described as * 14.20 from HAC but fixed to treat these cases. */ int mp_div (mp_int * a, mp_int * b, mp_int * c, mp_int * d) { mp_int q, x, y, t1, t2; int res, n, t, i, norm, neg; /* is divisor zero ? */ if (mp_iszero (b) == 1) { return MP_VAL; } /* if a < b then q=0, r = a */ if (mp_cmp_mag (a, b) == MP_LT) { if (d != NULL) { res = mp_copy (a, d); } else { res = MP_OKAY; } if (c != NULL) { mp_zero (c); } return res; } if ((res = mp_init_size (&q, a->used + 2)) != MP_OKAY) { return res; } q.used = a->used + 2; if ((res = mp_init (&t1)) != MP_OKAY) { goto LBL_Q; } if ((res = mp_init (&t2)) != MP_OKAY) { goto LBL_T1; } if ((res = mp_init_copy (&x, a)) != MP_OKAY) { goto LBL_T2; } if ((res = mp_init_copy (&y, b)) != MP_OKAY) { goto LBL_X; } /* fix the sign */ neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; x.sign = y.sign = MP_ZPOS; /* normalize both x and y, ensure that y >= b/2, [b == 2**DIGIT_BIT] */ norm = mp_count_bits(&y) % DIGIT_BIT; if (norm < (int)(DIGIT_BIT-1)) { norm = (DIGIT_BIT-1) - norm; if ((res = mp_mul_2d (&x, norm, &x)) != MP_OKAY) { goto LBL_Y; } if ((res = mp_mul_2d (&y, norm, &y)) != MP_OKAY) { goto LBL_Y; } } else { norm = 0; } /* note hac does 0 based, so if used==5 then its 0,1,2,3,4, e.g. use 4 */ n = x.used - 1; t = y.used - 1; /* while (x >= y*b**n-t) do { q[n-t] += 1; x -= y*b**{n-t} } */ if ((res = mp_lshd (&y, n - t)) != MP_OKAY) { /* y = y*b**{n-t} */ goto LBL_Y; } while (mp_cmp (&x, &y) != MP_LT) { ++(q.dp[n - t]); if ((res = mp_sub (&x, &y, &x)) != MP_OKAY) { goto LBL_Y; } } /* reset y by shifting it back down */ mp_rshd (&y, n - t); /* step 3. for i from n down to (t + 1) */ for (i = n; i >= (t + 1); i--) { if (i > x.used) { continue; } /* step 3.1 if xi == yt then set q{i-t-1} to b-1, * otherwise set q{i-t-1} to (xi*b + x{i-1})/yt */ if (x.dp[i] == y.dp[t]) { q.dp[i - t - 1] = ((((mp_digit)1) << DIGIT_BIT) - 1); } else { mp_word tmp; tmp = ((mp_word) x.dp[i]) << ((mp_word) DIGIT_BIT); tmp |= ((mp_word) x.dp[i - 1]); tmp /= ((mp_word) y.dp[t]); if (tmp > (mp_word) MP_MASK) tmp = MP_MASK; q.dp[i - t - 1] = (mp_digit) (tmp & (mp_word) (MP_MASK)); } /* while (q{i-t-1} * (yt * b + y{t-1})) > xi * b**2 + xi-1 * b + xi-2 do q{i-t-1} -= 1; */ q.dp[i - t - 1] = (q.dp[i - t - 1] + 1) & MP_MASK; do { q.dp[i - t - 1] = (q.dp[i - t - 1] - 1) & MP_MASK; /* find left hand */ mp_zero (&t1); t1.dp[0] = (t - 1 < 0) ? 0 : y.dp[t - 1]; t1.dp[1] = y.dp[t]; t1.used = 2; if ((res = mp_mul_d (&t1, q.dp[i - t - 1], &t1)) != MP_OKAY) { goto LBL_Y; } /* find right hand */ t2.dp[0] = (i - 2 < 0) ? 0 : x.dp[i - 2]; t2.dp[1] = (i - 1 < 0) ? 0 : x.dp[i - 1]; t2.dp[2] = x.dp[i]; t2.used = 3; } while (mp_cmp_mag(&t1, &t2) == MP_GT); /* step 3.3 x = x - q{i-t-1} * y * b**{i-t-1} */ if ((res = mp_mul_d (&y, q.dp[i - t - 1], &t1)) != MP_OKAY) { goto LBL_Y; } if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) { goto LBL_Y; } if ((res = mp_sub (&x, &t1, &x)) != MP_OKAY) { goto LBL_Y; } /* if x < 0 then { x = x + y*b**{i-t-1}; q{i-t-1} -= 1; } */ if (x.sign == MP_NEG) { if ((res = mp_copy (&y, &t1)) != MP_OKAY) { goto LBL_Y; } if ((res = mp_lshd (&t1, i - t - 1)) != MP_OKAY) { goto LBL_Y; } if ((res = mp_add (&x, &t1, &x)) != MP_OKAY) { goto LBL_Y; } q.dp[i - t - 1] = (q.dp[i - t - 1] - 1UL) & MP_MASK; } } /* now q is the quotient and x is the remainder * [which we have to normalize] */ /* get sign before writing to c */ x.sign = x.used == 0 ? MP_ZPOS : a->sign; if (c != NULL) { mp_clamp (&q); mp_exch (&q, c); c->sign = neg; } if (d != NULL) { mp_div_2d (&x, norm, &x, NULL); mp_exch (&x, d); } res = MP_OKAY; LBL_Y:mp_clear (&y); LBL_X:mp_clear (&x); LBL_T2:mp_clear (&t2); LBL_T1:mp_clear (&t1); LBL_Q:mp_clear (&q); return res; } #endif #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_div.c */ /* Start: bn_mp_div_2.c */ #include <tommath.h> #ifdef BN_MP_DIV_2_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* b = a/2 */ int mp_div_2(mp_int * a, mp_int * b) { int x, res, oldused; /* copy */ if (b->alloc < a->used) { if ((res = mp_grow (b, a->used)) != MP_OKAY) { return res; } } oldused = b->used; b->used = a->used; { register mp_digit r, rr, *tmpa, *tmpb; /* source alias */ tmpa = a->dp + b->used - 1; /* dest alias */ tmpb = b->dp + b->used - 1; /* carry */ r = 0; for (x = b->used - 1; x >= 0; x--) { /* get the carry for the next iteration */ rr = *tmpa & 1; /* shift the current digit, add in carry and store */ *tmpb-- = (*tmpa-- >> 1) | (r << (DIGIT_BIT - 1)); /* forward carry to next iteration */ r = rr; } /* zero excess digits */ tmpb = b->dp + b->used; for (x = b->used; x < oldused; x++) { *tmpb++ = 0; } } b->sign = a->sign; mp_clamp (b); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_div_2.c */ /* Start: bn_mp_div_2d.c */ #include <tommath.h> #ifdef BN_MP_DIV_2D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* shift right by a certain bit count (store quotient in c, optional remainder in d) */ int mp_div_2d (mp_int * a, int b, mp_int * c, mp_int * d) { mp_digit D, r, rr; int x, res; mp_int t; /* if the shift count is <= 0 then we do no work */ if (b <= 0) { res = mp_copy (a, c); if (d != NULL) { mp_zero (d); } return res; } if ((res = mp_init (&t)) != MP_OKAY) { return res; } /* get the remainder */ if (d != NULL) { if ((res = mp_mod_2d (a, b, &t)) != MP_OKAY) { mp_clear (&t); return res; } } /* copy */ if ((res = mp_copy (a, c)) != MP_OKAY) { mp_clear (&t); return res; } /* shift by as many digits in the bit count */ if (b >= (int)DIGIT_BIT) { mp_rshd (c, b / DIGIT_BIT); } /* shift any bit count < DIGIT_BIT */ D = (mp_digit) (b % DIGIT_BIT); if (D != 0) { register mp_digit *tmpc, mask, shift; /* mask */ mask = (((mp_digit)1) << D) - 1; /* shift for lsb */ shift = DIGIT_BIT - D; /* alias */ tmpc = c->dp + (c->used - 1); /* carry */ r = 0; for (x = c->used - 1; x >= 0; x--) { /* get the lower bits of this word in a temp */ rr = *tmpc & mask; /* shift the current word and mix in the carry bits from the previous word */ *tmpc = (*tmpc >> D) | (r << shift); --tmpc; /* set the carry to the carry bits of the current word found above */ r = rr; } } mp_clamp (c); if (d != NULL) { mp_exch (&t, d); } mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_div_2d.c */ /* Start: bn_mp_div_3.c */ #include <tommath.h> #ifdef BN_MP_DIV_3_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* divide by three (based on routine from MPI and the GMP manual) */ int mp_div_3 (mp_int * a, mp_int *c, mp_digit * d) { mp_int q; mp_word w, t; mp_digit b; int res, ix; /* b = 2**DIGIT_BIT / 3 */ b = (((mp_word)1) << ((mp_word)DIGIT_BIT)) / ((mp_word)3); if ((res = mp_init_size(&q, a->used)) != MP_OKAY) { return res; } q.used = a->used; q.sign = a->sign; w = 0; for (ix = a->used - 1; ix >= 0; ix--) { w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]); if (w >= 3) { /* multiply w by [1/3] */ t = (w * ((mp_word)b)) >> ((mp_word)DIGIT_BIT); /* now subtract 3 * [w/3] from w, to get the remainder */ w -= t+t+t; /* fixup the remainder as required since * the optimization is not exact. */ while (w >= 3) { t += 1; w -= 3; } } else { t = 0; } q.dp[ix] = (mp_digit)t; } /* [optional] store the remainder */ if (d != NULL) { *d = (mp_digit)w; } /* [optional] store the quotient */ if (c != NULL) { mp_clamp(&q); mp_exch(&q, c); } mp_clear(&q); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_div_3.c */ /* Start: bn_mp_div_d.c */ #include <tommath.h> #ifdef BN_MP_DIV_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ static int s_is_power_of_two(mp_digit b, int *p) { int x; for (x = 1; x < DIGIT_BIT; x++) { if (b == (((mp_digit)1)<<x)) { *p = x; return 1; } } return 0; } /* single digit division (based on routine from MPI) */ int mp_div_d (mp_int * a, mp_digit b, mp_int * c, mp_digit * d) { mp_int q; mp_word w; mp_digit t; int res, ix; /* cannot divide by zero */ if (b == 0) { return MP_VAL; } /* quick outs */ if (b == 1 || mp_iszero(a) == 1) { if (d != NULL) { *d = 0; } if (c != NULL) { return mp_copy(a, c); } return MP_OKAY; } /* power of two ? */ if (s_is_power_of_two(b, &ix) == 1) { if (d != NULL) { *d = a->dp[0] & ((((mp_digit)1)<<ix) - 1); } if (c != NULL) { return mp_div_2d(a, ix, c, NULL); } return MP_OKAY; } #ifdef BN_MP_DIV_3_C /* three? */ if (b == 3) { return mp_div_3(a, c, d); } #endif /* no easy answer [c'est la vie]. Just division */ if ((res = mp_init_size(&q, a->used)) != MP_OKAY) { return res; } q.used = a->used; q.sign = a->sign; w = 0; for (ix = a->used - 1; ix >= 0; ix--) { w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]); if (w >= b) { t = (mp_digit)(w / b); w -= ((mp_word)t) * ((mp_word)b); } else { t = 0; } q.dp[ix] = (mp_digit)t; } if (d != NULL) { *d = (mp_digit)w; } if (c != NULL) { mp_clamp(&q); mp_exch(&q, c); } mp_clear(&q); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_div_d.c */ /* Start: bn_mp_dr_is_modulus.c */ #include <tommath.h> #ifdef BN_MP_DR_IS_MODULUS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines if a number is a valid DR modulus */ int mp_dr_is_modulus(mp_int *a) { int ix; /* must be at least two digits */ if (a->used < 2) { return 0; } /* must be of the form b**k - a [a <= b] so all * but the first digit must be equal to -1 (mod b). */ for (ix = 1; ix < a->used; ix++) { if (a->dp[ix] != MP_MASK) { return 0; } } return 1; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_dr_is_modulus.c */ /* Start: bn_mp_dr_reduce.c */ #include <tommath.h> #ifdef BN_MP_DR_REDUCE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* reduce "x" in place modulo "n" using the Diminished Radix algorithm. * * Based on algorithm from the paper * * "Generating Efficient Primes for Discrete Log Cryptosystems" * Chae Hoon Lim, Pil Joong Lee, * POSTECH Information Research Laboratories * * The modulus must be of a special format [see manual] * * Has been modified to use algorithm 7.10 from the LTM book instead * * Input x must be in the range 0 <= x <= (n-1)**2 */ int mp_dr_reduce (mp_int * x, mp_int * n, mp_digit k) { int err, i, m; mp_word r; mp_digit mu, *tmpx1, *tmpx2; /* m = digits in modulus */ m = n->used; /* ensure that "x" has at least 2m digits */ if (x->alloc < m + m) { if ((err = mp_grow (x, m + m)) != MP_OKAY) { return err; } } /* top of loop, this is where the code resumes if * another reduction pass is required. */ top: /* aliases for digits */ /* alias for lower half of x */ tmpx1 = x->dp; /* alias for upper half of x, or x/B**m */ tmpx2 = x->dp + m; /* set carry to zero */ mu = 0; /* compute (x mod B**m) + k * [x/B**m] inline and inplace */ for (i = 0; i < m; i++) { r = ((mp_word)*tmpx2++) * ((mp_word)k) + *tmpx1 + mu; *tmpx1++ = (mp_digit)(r & MP_MASK); mu = (mp_digit)(r >> ((mp_word)DIGIT_BIT)); } /* set final carry */ *tmpx1++ = mu; /* zero words above m */ for (i = m + 1; i < x->used; i++) { *tmpx1++ = 0; } /* clamp, sub and return */ mp_clamp (x); /* if x >= n then subtract and reduce again * Each successive "recursion" makes the input smaller and smaller. */ if (mp_cmp_mag (x, n) != MP_LT) { s_mp_sub(x, n, x); goto top; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_dr_reduce.c */ /* Start: bn_mp_dr_setup.c */ #include <tommath.h> #ifdef BN_MP_DR_SETUP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines the setup value */ void mp_dr_setup(mp_int *a, mp_digit *d) { /* the casts are required if DIGIT_BIT is one less than * the number of bits in a mp_digit [e.g. DIGIT_BIT==31] */ *d = (mp_digit)((((mp_word)1) << ((mp_word)DIGIT_BIT)) - ((mp_word)a->dp[0])); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_dr_setup.c */ /* Start: bn_mp_exch.c */ #include <tommath.h> #ifdef BN_MP_EXCH_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* swap the elements of two integers, for cases where you can't simply swap the * mp_int pointers around */ void mp_exch (mp_int * a, mp_int * b) { mp_int t; t = *a; *a = *b; *b = t; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_exch.c */ /* Start: bn_mp_expt_d.c */ #include <tommath.h> #ifdef BN_MP_EXPT_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* calculate c = a**b using a square-multiply algorithm */ int mp_expt_d (mp_int * a, mp_digit b, mp_int * c) { int res, x; mp_int g; if ((res = mp_init_copy (&g, a)) != MP_OKAY) { return res; } /* set initial result */ mp_set (c, 1); for (x = 0; x < (int) DIGIT_BIT; x++) { /* square */ if ((res = mp_sqr (c, c)) != MP_OKAY) { mp_clear (&g); return res; } /* if the bit is set multiply */ if ((b & (mp_digit) (((mp_digit)1) << (DIGIT_BIT - 1))) != 0) { if ((res = mp_mul (c, &g, c)) != MP_OKAY) { mp_clear (&g); return res; } } /* shift to next bit */ b <<= 1; } mp_clear (&g); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_expt_d.c */ /* Start: bn_mp_exptmod.c */ #include <tommath.h> #ifdef BN_MP_EXPTMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* this is a shell function that calls either the normal or Montgomery * exptmod functions. Originally the call to the montgomery code was * embedded in the normal function but that wasted alot of stack space * for nothing (since 99% of the time the Montgomery code would be called) */ int mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y) { int dr; /* modulus P must be positive */ if (P->sign == MP_NEG) { return MP_VAL; } /* if exponent X is negative we have to recurse */ if (X->sign == MP_NEG) { #ifdef BN_MP_INVMOD_C mp_int tmpG, tmpX; int err; /* first compute 1/G mod P */ if ((err = mp_init(&tmpG)) != MP_OKAY) { return err; } if ((err = mp_invmod(G, P, &tmpG)) != MP_OKAY) { mp_clear(&tmpG); return err; } /* now get |X| */ if ((err = mp_init(&tmpX)) != MP_OKAY) { mp_clear(&tmpG); return err; } if ((err = mp_abs(X, &tmpX)) != MP_OKAY) { mp_clear_multi(&tmpG, &tmpX, NULL); return err; } /* and now compute (1/G)**|X| instead of G**X [X < 0] */ err = mp_exptmod(&tmpG, &tmpX, P, Y); mp_clear_multi(&tmpG, &tmpX, NULL); return err; #else /* no invmod */ return MP_VAL; #endif } /* modified diminished radix reduction */ #if defined(BN_MP_REDUCE_IS_2K_L_C) && defined(BN_MP_REDUCE_2K_L_C) && defined(BN_S_MP_EXPTMOD_C) if (mp_reduce_is_2k_l(P) == MP_YES) { return s_mp_exptmod(G, X, P, Y, 1); } #endif #ifdef BN_MP_DR_IS_MODULUS_C /* is it a DR modulus? */ dr = mp_dr_is_modulus(P); #else /* default to no */ dr = 0; #endif #ifdef BN_MP_REDUCE_IS_2K_C /* if not, is it a unrestricted DR modulus? */ if (dr == 0) { dr = mp_reduce_is_2k(P) << 1; } #endif /* if the modulus is odd or dr != 0 use the montgomery method */ #ifdef BN_MP_EXPTMOD_FAST_C if (mp_isodd (P) == 1 || dr != 0) { return mp_exptmod_fast (G, X, P, Y, dr); } else { #endif #ifdef BN_S_MP_EXPTMOD_C /* otherwise use the generic Barrett reduction technique */ return s_mp_exptmod (G, X, P, Y, 0); #else /* no exptmod for evens */ return MP_VAL; #endif #ifdef BN_MP_EXPTMOD_FAST_C } #endif } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_exptmod.c */ /* Start: bn_mp_exptmod_fast.c */ #include <tommath.h> #ifdef BN_MP_EXPTMOD_FAST_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes Y == G**X mod P, HAC pp.616, Algorithm 14.85 * * Uses a left-to-right k-ary sliding window to compute the modular exponentiation. * The value of k changes based on the size of the exponent. * * Uses Montgomery or Diminished Radix reduction [whichever appropriate] */ #ifdef MP_LOW_MEM #define TAB_SIZE 32 #else #define TAB_SIZE 256 #endif int mp_exptmod_fast (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode) { mp_int M[TAB_SIZE], res; mp_digit buf, mp; int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; /* use a pointer to the reduction algorithm. This allows us to use * one of many reduction algorithms without modding the guts of * the code with if statements everywhere. */ int (*redux)(mp_int*,mp_int*,mp_digit); /* find window size */ x = mp_count_bits (X); if (x <= 7) { winsize = 2; } else if (x <= 36) { winsize = 3; } else if (x <= 140) { winsize = 4; } else if (x <= 450) { winsize = 5; } else if (x <= 1303) { winsize = 6; } else if (x <= 3529) { winsize = 7; } else { winsize = 8; } #ifdef MP_LOW_MEM if (winsize > 5) { winsize = 5; } #endif /* init M array */ /* init first cell */ if ((err = mp_init(&M[1])) != MP_OKAY) { return err; } /* now init the second half of the array */ for (x = 1<<(winsize-1); x < (1 << winsize); x++) { if ((err = mp_init(&M[x])) != MP_OKAY) { for (y = 1<<(winsize-1); y < x; y++) { mp_clear (&M[y]); } mp_clear(&M[1]); return err; } } /* determine and setup reduction code */ if (redmode == 0) { #ifdef BN_MP_MONTGOMERY_SETUP_C /* now setup montgomery */ if ((err = mp_montgomery_setup (P, &mp)) != MP_OKAY) { goto LBL_M; } #else err = MP_VAL; goto LBL_M; #endif /* automatically pick the comba one if available (saves quite a few calls/ifs) */ #ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C if (((P->used * 2 + 1) < MP_WARRAY) && P->used < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { redux = fast_mp_montgomery_reduce; } else #endif { #ifdef BN_MP_MONTGOMERY_REDUCE_C /* use slower baseline Montgomery method */ redux = mp_montgomery_reduce; #else err = MP_VAL; goto LBL_M; #endif } } else if (redmode == 1) { #if defined(BN_MP_DR_SETUP_C) && defined(BN_MP_DR_REDUCE_C) /* setup DR reduction for moduli of the form B**k - b */ mp_dr_setup(P, &mp); redux = mp_dr_reduce; #else err = MP_VAL; goto LBL_M; #endif } else { #if defined(BN_MP_REDUCE_2K_SETUP_C) && defined(BN_MP_REDUCE_2K_C) /* setup DR reduction for moduli of the form 2**k - b */ if ((err = mp_reduce_2k_setup(P, &mp)) != MP_OKAY) { goto LBL_M; } redux = mp_reduce_2k; #else err = MP_VAL; goto LBL_M; #endif } /* setup result */ if ((err = mp_init (&res)) != MP_OKAY) { goto LBL_M; } /* create M table * * * The first half of the table is not computed though accept for M[0] and M[1] */ if (redmode == 0) { #ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C /* now we need R mod m */ if ((err = mp_montgomery_calc_normalization (&res, P)) != MP_OKAY) { goto LBL_RES; } #else err = MP_VAL; goto LBL_RES; #endif /* now set M[1] to G * R mod m */ if ((err = mp_mulmod (G, &res, P, &M[1])) != MP_OKAY) { goto LBL_RES; } } else { mp_set(&res, 1); if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) { goto LBL_RES; } } /* compute the value at M[1<<(winsize-1)] by squaring M[1] (winsize-1) times */ if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) { goto LBL_RES; } for (x = 0; x < (winsize - 1); x++) { if ((err = mp_sqr (&M[1 << (winsize - 1)], &M[1 << (winsize - 1)])) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&M[1 << (winsize - 1)], P, mp)) != MP_OKAY) { goto LBL_RES; } } /* create upper table */ for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) { if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&M[x], P, mp)) != MP_OKAY) { goto LBL_RES; } } /* set initial mode and bit cnt */ mode = 0; bitcnt = 1; buf = 0; digidx = X->used - 1; bitcpy = 0; bitbuf = 0; for (;;) { /* grab next digit as required */ if (--bitcnt == 0) { /* if digidx == -1 we are out of digits so break */ if (digidx == -1) { break; } /* read next digit and reset bitcnt */ buf = X->dp[digidx--]; bitcnt = (int)DIGIT_BIT; } /* grab the next msb from the exponent */ y = (mp_digit)(buf >> (DIGIT_BIT - 1)) & 1; buf <<= (mp_digit)1; /* if the bit is zero and mode == 0 then we ignore it * These represent the leading zero bits before the first 1 bit * in the exponent. Technically this opt is not required but it * does lower the # of trivial squaring/reductions used */ if (mode == 0 && y == 0) { continue; } /* if the bit is zero and mode == 1 then we square */ if (mode == 1 && y == 0) { if ((err = mp_sqr (&res, &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, mp)) != MP_OKAY) { goto LBL_RES; } continue; } /* else we add it to the window */ bitbuf |= (y << (winsize - ++bitcpy)); mode = 2; if (bitcpy == winsize) { /* ok window is filled so square as required and multiply */ /* square first */ for (x = 0; x < winsize; x++) { if ((err = mp_sqr (&res, &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, mp)) != MP_OKAY) { goto LBL_RES; } } /* then multiply */ if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, mp)) != MP_OKAY) { goto LBL_RES; } /* empty window and reset */ bitcpy = 0; bitbuf = 0; mode = 1; } } /* if bits remain then square/multiply */ if (mode == 2 && bitcpy > 0) { /* square then multiply if the bit is set */ for (x = 0; x < bitcpy; x++) { if ((err = mp_sqr (&res, &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, mp)) != MP_OKAY) { goto LBL_RES; } /* get next bit of the window */ bitbuf <<= 1; if ((bitbuf & (1 << winsize)) != 0) { /* then multiply */ if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, mp)) != MP_OKAY) { goto LBL_RES; } } } } if (redmode == 0) { /* fixup result if Montgomery reduction is used * recall that any value in a Montgomery system is * actually multiplied by R mod n. So we have * to reduce one more time to cancel out the factor * of R. */ if ((err = redux(&res, P, mp)) != MP_OKAY) { goto LBL_RES; } } /* swap res with Y */ mp_exch (&res, Y); err = MP_OKAY; LBL_RES:mp_clear (&res); LBL_M: mp_clear(&M[1]); for (x = 1<<(winsize-1); x < (1 << winsize); x++) { mp_clear (&M[x]); } return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_exptmod_fast.c */ /* Start: bn_mp_exteuclid.c */ #include <tommath.h> #ifdef BN_MP_EXTEUCLID_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Extended euclidean algorithm of (a, b) produces a*u1 + b*u2 = u3 */ int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) { mp_int u1,u2,u3,v1,v2,v3,t1,t2,t3,q,tmp; int err; if ((err = mp_init_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL)) != MP_OKAY) { return err; } /* initialize, (u1,u2,u3) = (1,0,a) */ mp_set(&u1, 1); if ((err = mp_copy(a, &u3)) != MP_OKAY) { goto _ERR; } /* initialize, (v1,v2,v3) = (0,1,b) */ mp_set(&v2, 1); if ((err = mp_copy(b, &v3)) != MP_OKAY) { goto _ERR; } /* loop while v3 != 0 */ while (mp_iszero(&v3) == MP_NO) { /* q = u3/v3 */ if ((err = mp_div(&u3, &v3, &q, NULL)) != MP_OKAY) { goto _ERR; } /* (t1,t2,t3) = (u1,u2,u3) - (v1,v2,v3)q */ if ((err = mp_mul(&v1, &q, &tmp)) != MP_OKAY) { goto _ERR; } if ((err = mp_sub(&u1, &tmp, &t1)) != MP_OKAY) { goto _ERR; } if ((err = mp_mul(&v2, &q, &tmp)) != MP_OKAY) { goto _ERR; } if ((err = mp_sub(&u2, &tmp, &t2)) != MP_OKAY) { goto _ERR; } if ((err = mp_mul(&v3, &q, &tmp)) != MP_OKAY) { goto _ERR; } if ((err = mp_sub(&u3, &tmp, &t3)) != MP_OKAY) { goto _ERR; } /* (u1,u2,u3) = (v1,v2,v3) */ if ((err = mp_copy(&v1, &u1)) != MP_OKAY) { goto _ERR; } if ((err = mp_copy(&v2, &u2)) != MP_OKAY) { goto _ERR; } if ((err = mp_copy(&v3, &u3)) != MP_OKAY) { goto _ERR; } /* (v1,v2,v3) = (t1,t2,t3) */ if ((err = mp_copy(&t1, &v1)) != MP_OKAY) { goto _ERR; } if ((err = mp_copy(&t2, &v2)) != MP_OKAY) { goto _ERR; } if ((err = mp_copy(&t3, &v3)) != MP_OKAY) { goto _ERR; } } /* make sure U3 >= 0 */ if (u3.sign == MP_NEG) { mp_neg(&u1, &u1); mp_neg(&u2, &u2); mp_neg(&u3, &u3); } /* copy result out */ if (U1 != NULL) { mp_exch(U1, &u1); } if (U2 != NULL) { mp_exch(U2, &u2); } if (U3 != NULL) { mp_exch(U3, &u3); } err = MP_OKAY; _ERR: mp_clear_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_exteuclid.c */ /* Start: bn_mp_fread.c */ #include <tommath.h> #ifdef BN_MP_FREAD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* read a bigint from a file stream in ASCII */ int mp_fread(mp_int *a, int radix, FILE *stream) { int err, ch, neg, y; /* clear a */ mp_zero(a); /* if first digit is - then set negative */ ch = fgetc(stream); if (ch == '-') { neg = MP_NEG; ch = fgetc(stream); } else { neg = MP_ZPOS; } for (;;) { /* find y in the radix map */ for (y = 0; y < radix; y++) { if (mp_s_rmap[y] == ch) { break; } } if (y == radix) { break; } /* shift up and add */ if ((err = mp_mul_d(a, radix, a)) != MP_OKAY) { return err; } if ((err = mp_add_d(a, y, a)) != MP_OKAY) { return err; } ch = fgetc(stream); } if (mp_cmp_d(a, 0) != MP_EQ) { a->sign = neg; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_fread.c */ /* Start: bn_mp_fwrite.c */ #include <tommath.h> #ifdef BN_MP_FWRITE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ int mp_fwrite(mp_int *a, int radix, FILE *stream) { char *buf; int err, len, x; if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) { return err; } buf = OPT_CAST(char) XMALLOC (len); if (buf == NULL) { return MP_MEM; } if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) { XFREE (buf); return err; } for (x = 0; x < len; x++) { if (fputc(buf[x], stream) == EOF) { XFREE (buf); return MP_VAL; } } XFREE (buf); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_fwrite.c */ /* Start: bn_mp_gcd.c */ #include <tommath.h> #ifdef BN_MP_GCD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Greatest Common Divisor using the binary method */ int mp_gcd (mp_int * a, mp_int * b, mp_int * c) { mp_int u, v; int k, u_lsb, v_lsb, res; /* either zero than gcd is the largest */ if (mp_iszero (a) == 1 && mp_iszero (b) == 0) { return mp_abs (b, c); } if (mp_iszero (a) == 0 && mp_iszero (b) == 1) { return mp_abs (a, c); } /* optimized. At this point if a == 0 then * b must equal zero too */ if (mp_iszero (a) == 1) { mp_zero(c); return MP_OKAY; } /* get copies of a and b we can modify */ if ((res = mp_init_copy (&u, a)) != MP_OKAY) { return res; } if ((res = mp_init_copy (&v, b)) != MP_OKAY) { goto LBL_U; } /* must be positive for the remainder of the algorithm */ u.sign = v.sign = MP_ZPOS; /* B1. Find the common power of two for u and v */ u_lsb = mp_cnt_lsb(&u); v_lsb = mp_cnt_lsb(&v); k = MIN(u_lsb, v_lsb); if (k > 0) { /* divide the power of two out */ if ((res = mp_div_2d(&u, k, &u, NULL)) != MP_OKAY) { goto LBL_V; } if ((res = mp_div_2d(&v, k, &v, NULL)) != MP_OKAY) { goto LBL_V; } } /* divide any remaining factors of two out */ if (u_lsb != k) { if ((res = mp_div_2d(&u, u_lsb - k, &u, NULL)) != MP_OKAY) { goto LBL_V; } } if (v_lsb != k) { if ((res = mp_div_2d(&v, v_lsb - k, &v, NULL)) != MP_OKAY) { goto LBL_V; } } while (mp_iszero(&v) == 0) { /* make sure v is the largest */ if (mp_cmp_mag(&u, &v) == MP_GT) { /* swap u and v to make sure v is >= u */ mp_exch(&u, &v); } /* subtract smallest from largest */ if ((res = s_mp_sub(&v, &u, &v)) != MP_OKAY) { goto LBL_V; } /* Divide out all factors of two */ if ((res = mp_div_2d(&v, mp_cnt_lsb(&v), &v, NULL)) != MP_OKAY) { goto LBL_V; } } /* multiply by 2**k which we divided out at the beginning */ if ((res = mp_mul_2d (&u, k, c)) != MP_OKAY) { goto LBL_V; } c->sign = MP_ZPOS; res = MP_OKAY; LBL_V:mp_clear (&u); LBL_U:mp_clear (&v); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_gcd.c */ /* Start: bn_mp_get_int.c */ #include <tommath.h> #ifdef BN_MP_GET_INT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* get the lower 32-bits of an mp_int */ unsigned long mp_get_int(mp_int * a) { int i; unsigned long res; if (a->used == 0) { return 0; } /* get number of digits of the lsb we have to read */ i = MIN(a->used,(int)((sizeof(unsigned long)*CHAR_BIT+DIGIT_BIT-1)/DIGIT_BIT))-1; /* get most significant digit of result */ res = DIGIT(a,i); while (--i >= 0) { res = (res << DIGIT_BIT) | DIGIT(a,i); } /* force result to 32-bits always so it is consistent on non 32-bit platforms */ return res & 0xFFFFFFFFUL; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_get_int.c */ /* Start: bn_mp_grow.c */ #include <tommath.h> #ifdef BN_MP_GROW_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* grow as required */ int mp_grow (mp_int * a, int size) { int i; mp_digit *tmp; /* if the alloc size is smaller alloc more ram */ if (a->alloc < size) { /* ensure there are always at least MP_PREC digits extra on top */ size += (MP_PREC * 2) - (size % MP_PREC); /* reallocate the array a->dp * * We store the return in a temporary variable * in case the operation failed we don't want * to overwrite the dp member of a. */ tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * size); if (tmp == NULL) { /* reallocation failed but "a" is still valid [can be freed] */ return MP_MEM; } /* reallocation succeeded so set a->dp */ a->dp = tmp; /* zero excess digits */ i = a->alloc; a->alloc = size; for (; i < a->alloc; i++) { a->dp[i] = 0; } } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_grow.c */ /* Start: bn_mp_init.c */ #include <tommath.h> #ifdef BN_MP_INIT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* init a new mp_int */ int mp_init (mp_int * a) { int i; /* allocate memory required and clear it */ a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * MP_PREC); if (a->dp == NULL) { return MP_MEM; } /* set the digits to zero */ for (i = 0; i < MP_PREC; i++) { a->dp[i] = 0; } /* set the used to zero, allocated digits to the default precision * and sign to positive */ a->used = 0; a->alloc = MP_PREC; a->sign = MP_ZPOS; return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_init.c */ /* Start: bn_mp_init_copy.c */ #include <tommath.h> #ifdef BN_MP_INIT_COPY_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* creates "a" then copies b into it */ int mp_init_copy (mp_int * a, mp_int * b) { int res; if ((res = mp_init (a)) != MP_OKAY) { return res; } return mp_copy (b, a); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_init_copy.c */ /* Start: bn_mp_init_multi.c */ #include <tommath.h> #ifdef BN_MP_INIT_MULTI_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ #include <stdarg.h> int mp_init_multi(mp_int *mp, ...) { mp_err res = MP_OKAY; /* Assume ok until proven otherwise */ int n = 0; /* Number of ok inits */ mp_int* cur_arg = mp; va_list args; va_start(args, mp); /* init args to next argument from caller */ while (cur_arg != NULL) { if (mp_init(cur_arg) != MP_OKAY) { /* Oops - error! Back-track and mp_clear what we already succeeded in init-ing, then return error. */ va_list clean_args; /* end the current list */ va_end(args); /* now start cleaning up */ cur_arg = mp; va_start(clean_args, mp); while (n--) { mp_clear(cur_arg); cur_arg = va_arg(clean_args, mp_int*); } va_end(clean_args); res = MP_MEM; break; } n++; cur_arg = va_arg(args, mp_int*); } va_end(args); return res; /* Assumed ok, if error flagged above. */ } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_init_multi.c */ /* Start: bn_mp_init_set.c */ #include <tommath.h> #ifdef BN_MP_INIT_SET_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* initialize and set a digit */ int mp_init_set (mp_int * a, mp_digit b) { int err; if ((err = mp_init(a)) != MP_OKAY) { return err; } mp_set(a, b); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_init_set.c */ /* Start: bn_mp_init_set_int.c */ #include <tommath.h> #ifdef BN_MP_INIT_SET_INT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* initialize and set a digit */ int mp_init_set_int (mp_int * a, unsigned long b) { int err; if ((err = mp_init(a)) != MP_OKAY) { return err; } return mp_set_int(a, b); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_init_set_int.c */ /* Start: bn_mp_init_size.c */ #include <tommath.h> #ifdef BN_MP_INIT_SIZE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* init an mp_init for a given size */ int mp_init_size (mp_int * a, int size) { int x; /* pad size so there are always extra digits */ size += (MP_PREC * 2) - (size % MP_PREC); /* alloc mem */ a->dp = OPT_CAST(mp_digit) XMALLOC (sizeof (mp_digit) * size); if (a->dp == NULL) { return MP_MEM; } /* set the members */ a->used = 0; a->alloc = size; a->sign = MP_ZPOS; /* zero the digits */ for (x = 0; x < size; x++) { a->dp[x] = 0; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_init_size.c */ /* Start: bn_mp_invmod.c */ #include <tommath.h> #ifdef BN_MP_INVMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* hac 14.61, pp608 */ int mp_invmod (mp_int * a, mp_int * b, mp_int * c) { /* b cannot be negative */ if (b->sign == MP_NEG || mp_iszero(b) == 1) { return MP_VAL; } #ifdef BN_FAST_MP_INVMOD_C /* if the modulus is odd we can use a faster routine instead */ if (mp_isodd (b) == 1) { return fast_mp_invmod (a, b, c); } #endif #ifdef BN_MP_INVMOD_SLOW_C return mp_invmod_slow(a, b, c); #endif return MP_VAL; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_invmod.c */ /* Start: bn_mp_invmod_slow.c */ #include <tommath.h> #ifdef BN_MP_INVMOD_SLOW_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* hac 14.61, pp608 */ int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c) { mp_int x, y, u, v, A, B, C, D; int res; /* b cannot be negative */ if (b->sign == MP_NEG || mp_iszero(b) == 1) { return MP_VAL; } /* init temps */ if ((res = mp_init_multi(&x, &y, &u, &v, &A, &B, &C, &D, NULL)) != MP_OKAY) { return res; } /* x = a, y = b */ if ((res = mp_mod(a, b, &x)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_copy (b, &y)) != MP_OKAY) { goto LBL_ERR; } /* 2. [modified] if x,y are both even then return an error! */ if (mp_iseven (&x) == 1 && mp_iseven (&y) == 1) { res = MP_VAL; goto LBL_ERR; } /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ if ((res = mp_copy (&x, &u)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_copy (&y, &v)) != MP_OKAY) { goto LBL_ERR; } mp_set (&A, 1); mp_set (&D, 1); top: /* 4. while u is even do */ while (mp_iseven (&u) == 1) { /* 4.1 u = u/2 */ if ((res = mp_div_2 (&u, &u)) != MP_OKAY) { goto LBL_ERR; } /* 4.2 if A or B is odd then */ if (mp_isodd (&A) == 1 || mp_isodd (&B) == 1) { /* A = (A+y)/2, B = (B-x)/2 */ if ((res = mp_add (&A, &y, &A)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&B, &x, &B)) != MP_OKAY) { goto LBL_ERR; } } /* A = A/2, B = B/2 */ if ((res = mp_div_2 (&A, &A)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_div_2 (&B, &B)) != MP_OKAY) { goto LBL_ERR; } } /* 5. while v is even do */ while (mp_iseven (&v) == 1) { /* 5.1 v = v/2 */ if ((res = mp_div_2 (&v, &v)) != MP_OKAY) { goto LBL_ERR; } /* 5.2 if C or D is odd then */ if (mp_isodd (&C) == 1 || mp_isodd (&D) == 1) { /* C = (C+y)/2, D = (D-x)/2 */ if ((res = mp_add (&C, &y, &C)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&D, &x, &D)) != MP_OKAY) { goto LBL_ERR; } } /* C = C/2, D = D/2 */ if ((res = mp_div_2 (&C, &C)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_div_2 (&D, &D)) != MP_OKAY) { goto LBL_ERR; } } /* 6. if u >= v then */ if (mp_cmp (&u, &v) != MP_LT) { /* u = u - v, A = A - C, B = B - D */ if ((res = mp_sub (&u, &v, &u)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&A, &C, &A)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&B, &D, &B)) != MP_OKAY) { goto LBL_ERR; } } else { /* v - v - u, C = C - A, D = D - B */ if ((res = mp_sub (&v, &u, &v)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&C, &A, &C)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_sub (&D, &B, &D)) != MP_OKAY) { goto LBL_ERR; } } /* if not zero goto step 4 */ if (mp_iszero (&u) == 0) goto top; /* now a = C, b = D, gcd == g*v */ /* if v != 1 then there is no inverse */ if (mp_cmp_d (&v, 1) != MP_EQ) { res = MP_VAL; goto LBL_ERR; } /* if its too low */ while (mp_cmp_d(&C, 0) == MP_LT) { if ((res = mp_add(&C, b, &C)) != MP_OKAY) { goto LBL_ERR; } } /* too big */ while (mp_cmp_mag(&C, b) != MP_LT) { if ((res = mp_sub(&C, b, &C)) != MP_OKAY) { goto LBL_ERR; } } /* C is now the inverse */ mp_exch (&C, c); res = MP_OKAY; LBL_ERR:mp_clear_multi (&x, &y, &u, &v, &A, &B, &C, &D, NULL); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_invmod_slow.c */ /* Start: bn_mp_is_square.c */ #include <tommath.h> #ifdef BN_MP_IS_SQUARE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Check if remainders are possible squares - fast exclude non-squares */ static const char rem_128[128] = { 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1 }; static const char rem_105[105] = { 0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1 }; /* Store non-zero to ret if arg is square, and zero if not */ int mp_is_square(mp_int *arg,int *ret) { int res; mp_digit c; mp_int t; unsigned long r; /* Default to Non-square :) */ *ret = MP_NO; if (arg->sign == MP_NEG) { return MP_VAL; } /* digits used? (TSD) */ if (arg->used == 0) { return MP_OKAY; } /* First check mod 128 (suppose that DIGIT_BIT is at least 7) */ if (rem_128[127 & DIGIT(arg,0)] == 1) { return MP_OKAY; } /* Next check mod 105 (3*5*7) */ if ((res = mp_mod_d(arg,105,&c)) != MP_OKAY) { return res; } if (rem_105[c] == 1) { return MP_OKAY; } if ((res = mp_init_set_int(&t,11L*13L*17L*19L*23L*29L*31L)) != MP_OKAY) { return res; } if ((res = mp_mod(arg,&t,&t)) != MP_OKAY) { goto ERR; } r = mp_get_int(&t); /* Check for other prime modules, note it's not an ERROR but we must * free "t" so the easiest way is to goto ERR. We know that res * is already equal to MP_OKAY from the mp_mod call */ if ( (1L<<(r%11)) & 0x5C4L ) goto ERR; if ( (1L<<(r%13)) & 0x9E4L ) goto ERR; if ( (1L<<(r%17)) & 0x5CE8L ) goto ERR; if ( (1L<<(r%19)) & 0x4F50CL ) goto ERR; if ( (1L<<(r%23)) & 0x7ACCA0L ) goto ERR; if ( (1L<<(r%29)) & 0xC2EDD0CL ) goto ERR; if ( (1L<<(r%31)) & 0x6DE2B848L ) goto ERR; /* Final check - is sqr(sqrt(arg)) == arg ? */ if ((res = mp_sqrt(arg,&t)) != MP_OKAY) { goto ERR; } if ((res = mp_sqr(&t,&t)) != MP_OKAY) { goto ERR; } *ret = (mp_cmp_mag(&t,arg) == MP_EQ) ? MP_YES : MP_NO; ERR:mp_clear(&t); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_is_square.c */ /* Start: bn_mp_jacobi.c */ #include <tommath.h> #ifdef BN_MP_JACOBI_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes the jacobi c = (a | n) (or Legendre if n is prime) * HAC pp. 73 Algorithm 2.149 */ int mp_jacobi (mp_int * a, mp_int * p, int *c) { mp_int a1, p1; int k, s, r, res; mp_digit residue; /* if p <= 0 return MP_VAL */ if (mp_cmp_d(p, 0) != MP_GT) { return MP_VAL; } /* step 1. if a == 0, return 0 */ if (mp_iszero (a) == 1) { *c = 0; return MP_OKAY; } /* step 2. if a == 1, return 1 */ if (mp_cmp_d (a, 1) == MP_EQ) { *c = 1; return MP_OKAY; } /* default */ s = 0; /* step 3. write a = a1 * 2**k */ if ((res = mp_init_copy (&a1, a)) != MP_OKAY) { return res; } if ((res = mp_init (&p1)) != MP_OKAY) { goto LBL_A1; } /* divide out larger power of two */ k = mp_cnt_lsb(&a1); if ((res = mp_div_2d(&a1, k, &a1, NULL)) != MP_OKAY) { goto LBL_P1; } /* step 4. if e is even set s=1 */ if ((k & 1) == 0) { s = 1; } else { /* else set s=1 if p = 1/7 (mod 8) or s=-1 if p = 3/5 (mod 8) */ residue = p->dp[0] & 7; if (residue == 1 || residue == 7) { s = 1; } else if (residue == 3 || residue == 5) { s = -1; } } /* step 5. if p == 3 (mod 4) *and* a1 == 3 (mod 4) then s = -s */ if ( ((p->dp[0] & 3) == 3) && ((a1.dp[0] & 3) == 3)) { s = -s; } /* if a1 == 1 we're done */ if (mp_cmp_d (&a1, 1) == MP_EQ) { *c = s; } else { /* n1 = n mod a1 */ if ((res = mp_mod (p, &a1, &p1)) != MP_OKAY) { goto LBL_P1; } if ((res = mp_jacobi (&p1, &a1, &r)) != MP_OKAY) { goto LBL_P1; } *c = s * r; } /* done */ res = MP_OKAY; LBL_P1:mp_clear (&p1); LBL_A1:mp_clear (&a1); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_jacobi.c */ /* Start: bn_mp_karatsuba_mul.c */ #include <tommath.h> #ifdef BN_MP_KARATSUBA_MUL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* c = |a| * |b| using Karatsuba Multiplication using * three half size multiplications * * Let B represent the radix [e.g. 2**DIGIT_BIT] and * let n represent half of the number of digits in * the min(a,b) * * a = a1 * B**n + a0 * b = b1 * B**n + b0 * * Then, a * b => a1b1 * B**2n + ((a1 + a0)(b1 + b0) - (a0b0 + a1b1)) * B + a0b0 * * Note that a1b1 and a0b0 are used twice and only need to be * computed once. So in total three half size (half # of * digit) multiplications are performed, a0b0, a1b1 and * (a1+b1)(a0+b0) * * Note that a multiplication of half the digits requires * 1/4th the number of single precision multiplications so in * total after one call 25% of the single precision multiplications * are saved. Note also that the call to mp_mul can end up back * in this function if the a0, a1, b0, or b1 are above the threshold. * This is known as divide-and-conquer and leads to the famous * O(N**lg(3)) or O(N**1.584) work which is asymptopically lower than * the standard O(N**2) that the baseline/comba methods use. * Generally though the overhead of this method doesn't pay off * until a certain size (N ~ 80) is reached. */ int mp_karatsuba_mul (mp_int * a, mp_int * b, mp_int * c) { mp_int x0, x1, y0, y1, t1, x0y0, x1y1; int B, err; /* default the return code to an error */ err = MP_MEM; /* min # of digits */ B = MIN (a->used, b->used); /* now divide in two */ B = B >> 1; /* init copy all the temps */ if (mp_init_size (&x0, B) != MP_OKAY) goto ERR; if (mp_init_size (&x1, a->used - B) != MP_OKAY) goto X0; if (mp_init_size (&y0, B) != MP_OKAY) goto X1; if (mp_init_size (&y1, b->used - B) != MP_OKAY) goto Y0; /* init temps */ if (mp_init_size (&t1, B * 2) != MP_OKAY) goto Y1; if (mp_init_size (&x0y0, B * 2) != MP_OKAY) goto T1; if (mp_init_size (&x1y1, B * 2) != MP_OKAY) goto X0Y0; /* now shift the digits */ x0.used = y0.used = B; x1.used = a->used - B; y1.used = b->used - B; { register int x; register mp_digit *tmpa, *tmpb, *tmpx, *tmpy; /* we copy the digits directly instead of using higher level functions * since we also need to shift the digits */ tmpa = a->dp; tmpb = b->dp; tmpx = x0.dp; tmpy = y0.dp; for (x = 0; x < B; x++) { *tmpx++ = *tmpa++; *tmpy++ = *tmpb++; } tmpx = x1.dp; for (x = B; x < a->used; x++) { *tmpx++ = *tmpa++; } tmpy = y1.dp; for (x = B; x < b->used; x++) { *tmpy++ = *tmpb++; } } /* only need to clamp the lower words since by definition the * upper words x1/y1 must have a known number of digits */ mp_clamp (&x0); mp_clamp (&y0); /* now calc the products x0y0 and x1y1 */ /* after this x0 is no longer required, free temp [x0==t2]! */ if (mp_mul (&x0, &y0, &x0y0) != MP_OKAY) goto X1Y1; /* x0y0 = x0*y0 */ if (mp_mul (&x1, &y1, &x1y1) != MP_OKAY) goto X1Y1; /* x1y1 = x1*y1 */ /* now calc x1+x0 and y1+y0 */ if (s_mp_add (&x1, &x0, &t1) != MP_OKAY) goto X1Y1; /* t1 = x1 - x0 */ if (s_mp_add (&y1, &y0, &x0) != MP_OKAY) goto X1Y1; /* t2 = y1 - y0 */ if (mp_mul (&t1, &x0, &t1) != MP_OKAY) goto X1Y1; /* t1 = (x1 + x0) * (y1 + y0) */ /* add x0y0 */ if (mp_add (&x0y0, &x1y1, &x0) != MP_OKAY) goto X1Y1; /* t2 = x0y0 + x1y1 */ if (s_mp_sub (&t1, &x0, &t1) != MP_OKAY) goto X1Y1; /* t1 = (x1+x0)*(y1+y0) - (x1y1 + x0y0) */ /* shift by B */ if (mp_lshd (&t1, B) != MP_OKAY) goto X1Y1; /* t1 = (x0y0 + x1y1 - (x1-x0)*(y1-y0))<<B */ if (mp_lshd (&x1y1, B * 2) != MP_OKAY) goto X1Y1; /* x1y1 = x1y1 << 2*B */ if (mp_add (&x0y0, &t1, &t1) != MP_OKAY) goto X1Y1; /* t1 = x0y0 + t1 */ if (mp_add (&t1, &x1y1, c) != MP_OKAY) goto X1Y1; /* t1 = x0y0 + t1 + x1y1 */ /* Algorithm succeeded set the return code to MP_OKAY */ err = MP_OKAY; X1Y1:mp_clear (&x1y1); X0Y0:mp_clear (&x0y0); T1:mp_clear (&t1); Y1:mp_clear (&y1); Y0:mp_clear (&y0); X1:mp_clear (&x1); X0:mp_clear (&x0); ERR: return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_karatsuba_mul.c */ /* Start: bn_mp_karatsuba_sqr.c */ #include <tommath.h> #ifdef BN_MP_KARATSUBA_SQR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Karatsuba squaring, computes b = a*a using three * half size squarings * * See comments of karatsuba_mul for details. It * is essentially the same algorithm but merely * tuned to perform recursive squarings. */ int mp_karatsuba_sqr (mp_int * a, mp_int * b) { mp_int x0, x1, t1, t2, x0x0, x1x1; int B, err; err = MP_MEM; /* min # of digits */ B = a->used; /* now divide in two */ B = B >> 1; /* init copy all the temps */ if (mp_init_size (&x0, B) != MP_OKAY) goto ERR; if (mp_init_size (&x1, a->used - B) != MP_OKAY) goto X0; /* init temps */ if (mp_init_size (&t1, a->used * 2) != MP_OKAY) goto X1; if (mp_init_size (&t2, a->used * 2) != MP_OKAY) goto T1; if (mp_init_size (&x0x0, B * 2) != MP_OKAY) goto T2; if (mp_init_size (&x1x1, (a->used - B) * 2) != MP_OKAY) goto X0X0; { register int x; register mp_digit *dst, *src; src = a->dp; /* now shift the digits */ dst = x0.dp; for (x = 0; x < B; x++) { *dst++ = *src++; } dst = x1.dp; for (x = B; x < a->used; x++) { *dst++ = *src++; } } x0.used = B; x1.used = a->used - B; mp_clamp (&x0); /* now calc the products x0*x0 and x1*x1 */ if (mp_sqr (&x0, &x0x0) != MP_OKAY) goto X1X1; /* x0x0 = x0*x0 */ if (mp_sqr (&x1, &x1x1) != MP_OKAY) goto X1X1; /* x1x1 = x1*x1 */ /* now calc (x1+x0)**2 */ if (s_mp_add (&x1, &x0, &t1) != MP_OKAY) goto X1X1; /* t1 = x1 - x0 */ if (mp_sqr (&t1, &t1) != MP_OKAY) goto X1X1; /* t1 = (x1 - x0) * (x1 - x0) */ /* add x0y0 */ if (s_mp_add (&x0x0, &x1x1, &t2) != MP_OKAY) goto X1X1; /* t2 = x0x0 + x1x1 */ if (s_mp_sub (&t1, &t2, &t1) != MP_OKAY) goto X1X1; /* t1 = (x1+x0)**2 - (x0x0 + x1x1) */ /* shift by B */ if (mp_lshd (&t1, B) != MP_OKAY) goto X1X1; /* t1 = (x0x0 + x1x1 - (x1-x0)*(x1-x0))<<B */ if (mp_lshd (&x1x1, B * 2) != MP_OKAY) goto X1X1; /* x1x1 = x1x1 << 2*B */ if (mp_add (&x0x0, &t1, &t1) != MP_OKAY) goto X1X1; /* t1 = x0x0 + t1 */ if (mp_add (&t1, &x1x1, b) != MP_OKAY) goto X1X1; /* t1 = x0x0 + t1 + x1x1 */ err = MP_OKAY; X1X1:mp_clear (&x1x1); X0X0:mp_clear (&x0x0); T2:mp_clear (&t2); T1:mp_clear (&t1); X1:mp_clear (&x1); X0:mp_clear (&x0); ERR: return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_karatsuba_sqr.c */ /* Start: bn_mp_lcm.c */ #include <tommath.h> #ifdef BN_MP_LCM_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes least common multiple as |a*b|/(a, b) */ int mp_lcm (mp_int * a, mp_int * b, mp_int * c) { int res; mp_int t1, t2; if ((res = mp_init_multi (&t1, &t2, NULL)) != MP_OKAY) { return res; } /* t1 = get the GCD of the two inputs */ if ((res = mp_gcd (a, b, &t1)) != MP_OKAY) { goto LBL_T; } /* divide the smallest by the GCD */ if (mp_cmp_mag(a, b) == MP_LT) { /* store quotient in t2 such that t2 * b is the LCM */ if ((res = mp_div(a, &t1, &t2, NULL)) != MP_OKAY) { goto LBL_T; } res = mp_mul(b, &t2, c); } else { /* store quotient in t2 such that t2 * a is the LCM */ if ((res = mp_div(b, &t1, &t2, NULL)) != MP_OKAY) { goto LBL_T; } res = mp_mul(a, &t2, c); } /* fix the sign to positive */ c->sign = MP_ZPOS; LBL_T: mp_clear_multi (&t1, &t2, NULL); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_lcm.c */ /* Start: bn_mp_lshd.c */ #include <tommath.h> #ifdef BN_MP_LSHD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* shift left a certain amount of digits */ int mp_lshd (mp_int * a, int b) { int x, res; /* if its less than zero return */ if (b <= 0) { return MP_OKAY; } /* grow to fit the new digits */ if (a->alloc < a->used + b) { if ((res = mp_grow (a, a->used + b)) != MP_OKAY) { return res; } } { register mp_digit *top, *bottom; /* increment the used by the shift amount then copy upwards */ a->used += b; /* top */ top = a->dp + a->used - 1; /* base */ bottom = a->dp + a->used - 1 - b; /* much like mp_rshd this is implemented using a sliding window * except the window goes the otherway around. Copying from * the bottom to the top. see bn_mp_rshd.c for more info. */ for (x = a->used - 1; x >= b; x--) { *top-- = *bottom--; } /* zero the lower digits */ top = a->dp; for (x = 0; x < b; x++) { *top++ = 0; } } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_lshd.c */ /* Start: bn_mp_mod.c */ #include <tommath.h> #ifdef BN_MP_MOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* c = a mod b, 0 <= c < b */ int mp_mod (mp_int * a, mp_int * b, mp_int * c) { mp_int t; int res; if ((res = mp_init (&t)) != MP_OKAY) { return res; } if ((res = mp_div (a, b, NULL, &t)) != MP_OKAY) { mp_clear (&t); return res; } if (t.sign != b->sign) { res = mp_add (b, &t, c); } else { res = MP_OKAY; mp_exch (&t, c); } mp_clear (&t); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_mod.c */ /* Start: bn_mp_mod_2d.c */ #include <tommath.h> #ifdef BN_MP_MOD_2D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* calc a value mod 2**b */ int mp_mod_2d (mp_int * a, int b, mp_int * c) { int x, res; /* if b is <= 0 then zero the int */ if (b <= 0) { mp_zero (c); return MP_OKAY; } /* if the modulus is larger than the value than return */ if (b >= (int) (a->used * DIGIT_BIT)) { res = mp_copy (a, c); return res; } /* copy */ if ((res = mp_copy (a, c)) != MP_OKAY) { return res; } /* zero digits above the last digit of the modulus */ for (x = (b / DIGIT_BIT) + ((b % DIGIT_BIT) == 0 ? 0 : 1); x < c->used; x++) { c->dp[x] = 0; } /* clear the digit that is not completely outside/inside the modulus */ c->dp[b / DIGIT_BIT] &= (mp_digit) ((((mp_digit) 1) << (((mp_digit) b) % DIGIT_BIT)) - ((mp_digit) 1)); mp_clamp (c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_mod_2d.c */ /* Start: bn_mp_mod_d.c */ #include <tommath.h> #ifdef BN_MP_MOD_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ int mp_mod_d (mp_int * a, mp_digit b, mp_digit * c) { return mp_div_d(a, b, NULL, c); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_mod_d.c */ /* Start: bn_mp_montgomery_calc_normalization.c */ #include <tommath.h> #ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* * shifts with subtractions when the result is greater than b. * * The method is slightly modified to shift B unconditionally upto just under * the leading bit of b. This saves alot of multiple precision shifting. */ int mp_montgomery_calc_normalization (mp_int * a, mp_int * b) { int x, bits, res; /* how many bits of last digit does b use */ bits = mp_count_bits (b) % DIGIT_BIT; if (b->used > 1) { if ((res = mp_2expt (a, (b->used - 1) * DIGIT_BIT + bits - 1)) != MP_OKAY) { return res; } } else { mp_set(a, 1); bits = 1; } /* now compute C = A * B mod b */ for (x = bits - 1; x < (int)DIGIT_BIT; x++) { if ((res = mp_mul_2 (a, a)) != MP_OKAY) { return res; } if (mp_cmp_mag (a, b) != MP_LT) { if ((res = s_mp_sub (a, b, a)) != MP_OKAY) { return res; } } } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_montgomery_calc_normalization.c */ /* Start: bn_mp_montgomery_reduce.c */ #include <tommath.h> #ifdef BN_MP_MONTGOMERY_REDUCE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes xR**-1 == x (mod N) via Montgomery Reduction */ int mp_montgomery_reduce (mp_int * x, mp_int * n, mp_digit rho) { int ix, res, digs; mp_digit mu; /* can the fast reduction [comba] method be used? * * Note that unlike in mul you're safely allowed *less* * than the available columns [255 per default] since carries * are fixed up in the inner loop. */ digs = n->used * 2 + 1; if ((digs < MP_WARRAY) && n->used < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { return fast_mp_montgomery_reduce (x, n, rho); } /* grow the input as required */ if (x->alloc < digs) { if ((res = mp_grow (x, digs)) != MP_OKAY) { return res; } } x->used = digs; for (ix = 0; ix < n->used; ix++) { /* mu = ai * rho mod b * * The value of rho must be precalculated via * montgomery_setup() such that * it equals -1/n0 mod b this allows the * following inner loop to reduce the * input one digit at a time */ mu = (mp_digit) (((mp_word)x->dp[ix]) * ((mp_word)rho) & MP_MASK); /* a = a + mu * m * b**i */ { register int iy; register mp_digit *tmpn, *tmpx, u; register mp_word r; /* alias for digits of the modulus */ tmpn = n->dp; /* alias for the digits of x [the input] */ tmpx = x->dp + ix; /* set the carry to zero */ u = 0; /* Multiply and add in place */ for (iy = 0; iy < n->used; iy++) { /* compute product and sum */ r = ((mp_word)mu) * ((mp_word)*tmpn++) + ((mp_word) u) + ((mp_word) * tmpx); /* get carry */ u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); /* fix digit */ *tmpx++ = (mp_digit)(r & ((mp_word) MP_MASK)); } /* At this point the ix'th digit of x should be zero */ /* propagate carries upwards as required*/ while (u) { *tmpx += u; u = *tmpx >> DIGIT_BIT; *tmpx++ &= MP_MASK; } } } /* at this point the n.used'th least * significant digits of x are all zero * which means we can shift x to the * right by n.used digits and the * residue is unchanged. */ /* x = x/b**n.used */ mp_clamp(x); mp_rshd (x, n->used); /* if x >= n then x = x - n */ if (mp_cmp_mag (x, n) != MP_LT) { return s_mp_sub (x, n, x); } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_montgomery_reduce.c */ /* Start: bn_mp_montgomery_setup.c */ #include <tommath.h> #ifdef BN_MP_MONTGOMERY_SETUP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* setups the montgomery reduction stuff */ int mp_montgomery_setup (mp_int * n, mp_digit * rho) { mp_digit x, b; /* fast inversion mod 2**k * * Based on the fact that * * XA = 1 (mod 2**n) => (X(2-XA)) A = 1 (mod 2**2n) * => 2*X*A - X*X*A*A = 1 * => 2*(1) - (1) = 1 */ b = n->dp[0]; if ((b & 1) == 0) { return MP_VAL; } x = (((b + 2) & 4) << 1) + b; /* here x*a==1 mod 2**4 */ x *= 2 - b * x; /* here x*a==1 mod 2**8 */ #if !defined(MP_8BIT) x *= 2 - b * x; /* here x*a==1 mod 2**16 */ #endif #if defined(MP_64BIT) || !(defined(MP_8BIT) || defined(MP_16BIT)) x *= 2 - b * x; /* here x*a==1 mod 2**32 */ #endif #ifdef MP_64BIT x *= 2 - b * x; /* here x*a==1 mod 2**64 */ #endif /* rho = -1/m mod b */ *rho = (((mp_word)1 << ((mp_word) DIGIT_BIT)) - x) & MP_MASK; return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_montgomery_setup.c */ /* Start: bn_mp_mul.c */ #include <tommath.h> #ifdef BN_MP_MUL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* high level multiplication (handles sign) */ int mp_mul (mp_int * a, mp_int * b, mp_int * c) { int res, neg; neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; /* use Toom-Cook? */ #ifdef BN_MP_TOOM_MUL_C if (MIN (a->used, b->used) >= TOOM_MUL_CUTOFF) { res = mp_toom_mul(a, b, c); } else #endif #ifdef BN_MP_KARATSUBA_MUL_C /* use Karatsuba? */ if (MIN (a->used, b->used) >= KARATSUBA_MUL_CUTOFF) { res = mp_karatsuba_mul (a, b, c); } else #endif { /* can we use the fast multiplier? * * The fast multiplier can be used if the output will * have less than MP_WARRAY digits and the number of * digits won't affect carry propagation */ int digs = a->used + b->used + 1; #ifdef BN_FAST_S_MP_MUL_DIGS_C if ((digs < MP_WARRAY) && MIN(a->used, b->used) <= (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { res = fast_s_mp_mul_digs (a, b, c, digs); } else #endif #ifdef BN_S_MP_MUL_DIGS_C res = s_mp_mul (a, b, c); /* uses s_mp_mul_digs */ #else res = MP_VAL; #endif } c->sign = (c->used > 0) ? neg : MP_ZPOS; return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_mul.c */ /* Start: bn_mp_mul_2.c */ #include <tommath.h> #ifdef BN_MP_MUL_2_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* b = a*2 */ int mp_mul_2(mp_int * a, mp_int * b) { int x, res, oldused; /* grow to accomodate result */ if (b->alloc < a->used + 1) { if ((res = mp_grow (b, a->used + 1)) != MP_OKAY) { return res; } } oldused = b->used; b->used = a->used; { register mp_digit r, rr, *tmpa, *tmpb; /* alias for source */ tmpa = a->dp; /* alias for dest */ tmpb = b->dp; /* carry */ r = 0; for (x = 0; x < a->used; x++) { /* get what will be the *next* carry bit from the * MSB of the current digit */ rr = *tmpa >> ((mp_digit)(DIGIT_BIT - 1)); /* now shift up this digit, add in the carry [from the previous] */ *tmpb++ = ((*tmpa++ << ((mp_digit)1)) | r) & MP_MASK; /* copy the carry that would be from the source * digit into the next iteration */ r = rr; } /* new leading digit? */ if (r != 0) { /* add a MSB which is always 1 at this point */ *tmpb = 1; ++(b->used); } /* now zero any excess digits on the destination * that we didn't write to */ tmpb = b->dp + b->used; for (x = b->used; x < oldused; x++) { *tmpb++ = 0; } } b->sign = a->sign; return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_mul_2.c */ /* Start: bn_mp_mul_2d.c */ #include <tommath.h> #ifdef BN_MP_MUL_2D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* shift left by a certain bit count */ int mp_mul_2d (mp_int * a, int b, mp_int * c) { mp_digit d; int res; /* copy */ if (a != c) { if ((res = mp_copy (a, c)) != MP_OKAY) { return res; } } if (c->alloc < (int)(c->used + b/DIGIT_BIT + 1)) { if ((res = mp_grow (c, c->used + b / DIGIT_BIT + 1)) != MP_OKAY) { return res; } } /* shift by as many digits in the bit count */ if (b >= (int)DIGIT_BIT) { if ((res = mp_lshd (c, b / DIGIT_BIT)) != MP_OKAY) { return res; } } /* shift any bit count < DIGIT_BIT */ d = (mp_digit) (b % DIGIT_BIT); if (d != 0) { register mp_digit *tmpc, shift, mask, r, rr; register int x; /* bitmask for carries */ mask = (((mp_digit)1) << d) - 1; /* shift for msbs */ shift = DIGIT_BIT - d; /* alias */ tmpc = c->dp; /* carry */ r = 0; for (x = 0; x < c->used; x++) { /* get the higher bits of the current word */ rr = (*tmpc >> shift) & mask; /* shift the current word and OR in the carry */ *tmpc = ((*tmpc << d) | r) & MP_MASK; ++tmpc; /* set the carry to the carry bits of the current word */ r = rr; } /* set final carry */ if (r != 0) { c->dp[(c->used)++] = r; } } mp_clamp (c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_mul_2d.c */ /* Start: bn_mp_mul_d.c */ #include <tommath.h> #ifdef BN_MP_MUL_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* multiply by a digit */ int mp_mul_d (mp_int * a, mp_digit b, mp_int * c) { mp_digit u, *tmpa, *tmpc; mp_word r; int ix, res, olduse; /* make sure c is big enough to hold a*b */ if (c->alloc < a->used + 1) { if ((res = mp_grow (c, a->used + 1)) != MP_OKAY) { return res; } } /* get the original destinations used count */ olduse = c->used; /* set the sign */ c->sign = a->sign; /* alias for a->dp [source] */ tmpa = a->dp; /* alias for c->dp [dest] */ tmpc = c->dp; /* zero carry */ u = 0; /* compute columns */ for (ix = 0; ix < a->used; ix++) { /* compute product and carry sum for this term */ r = ((mp_word) u) + ((mp_word)*tmpa++) * ((mp_word)b); /* mask off higher bits to get a single digit */ *tmpc++ = (mp_digit) (r & ((mp_word) MP_MASK)); /* send carry into next iteration */ u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); } /* store final carry [if any] and increment ix offset */ *tmpc++ = u; ++ix; /* now zero digits above the top */ while (ix++ < olduse) { *tmpc++ = 0; } /* set used count */ c->used = a->used + 1; mp_clamp(c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_mul_d.c */ /* Start: bn_mp_mulmod.c */ #include <tommath.h> #ifdef BN_MP_MULMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* d = a * b (mod c) */ int mp_mulmod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) { int res; mp_int t; if ((res = mp_init (&t)) != MP_OKAY) { return res; } if ((res = mp_mul (a, b, &t)) != MP_OKAY) { mp_clear (&t); return res; } res = mp_mod (&t, c, d); mp_clear (&t); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_mulmod.c */ /* Start: bn_mp_n_root.c */ #include <tommath.h> #ifdef BN_MP_N_ROOT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* find the n'th root of an integer * * Result found such that (c)**b <= a and (c+1)**b > a * * This algorithm uses Newton's approximation * x[i+1] = x[i] - f(x[i])/f'(x[i]) * which will find the root in log(N) time where * each step involves a fair bit. This is not meant to * find huge roots [square and cube, etc]. */ int mp_n_root (mp_int * a, mp_digit b, mp_int * c) { mp_int t1, t2, t3; int res, neg; /* input must be positive if b is even */ if ((b & 1) == 0 && a->sign == MP_NEG) { return MP_VAL; } if ((res = mp_init (&t1)) != MP_OKAY) { return res; } if ((res = mp_init (&t2)) != MP_OKAY) { goto LBL_T1; } if ((res = mp_init (&t3)) != MP_OKAY) { goto LBL_T2; } /* if a is negative fudge the sign but keep track */ neg = a->sign; a->sign = MP_ZPOS; /* t2 = 2 */ mp_set (&t2, 2); do { /* t1 = t2 */ if ((res = mp_copy (&t2, &t1)) != MP_OKAY) { goto LBL_T3; } /* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */ /* t3 = t1**(b-1) */ if ((res = mp_expt_d (&t1, b - 1, &t3)) != MP_OKAY) { goto LBL_T3; } /* numerator */ /* t2 = t1**b */ if ((res = mp_mul (&t3, &t1, &t2)) != MP_OKAY) { goto LBL_T3; } /* t2 = t1**b - a */ if ((res = mp_sub (&t2, a, &t2)) != MP_OKAY) { goto LBL_T3; } /* denominator */ /* t3 = t1**(b-1) * b */ if ((res = mp_mul_d (&t3, b, &t3)) != MP_OKAY) { goto LBL_T3; } /* t3 = (t1**b - a)/(b * t1**(b-1)) */ if ((res = mp_div (&t2, &t3, &t3, NULL)) != MP_OKAY) { goto LBL_T3; } if ((res = mp_sub (&t1, &t3, &t2)) != MP_OKAY) { goto LBL_T3; } } while (mp_cmp (&t1, &t2) != MP_EQ); /* result can be off by a few so check */ for (;;) { if ((res = mp_expt_d (&t1, b, &t2)) != MP_OKAY) { goto LBL_T3; } if (mp_cmp (&t2, a) == MP_GT) { if ((res = mp_sub_d (&t1, 1, &t1)) != MP_OKAY) { goto LBL_T3; } } else { break; } } /* reset the sign of a first */ a->sign = neg; /* set the result */ mp_exch (&t1, c); /* set the sign of the result */ c->sign = neg; res = MP_OKAY; LBL_T3:mp_clear (&t3); LBL_T2:mp_clear (&t2); LBL_T1:mp_clear (&t1); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_n_root.c */ /* Start: bn_mp_neg.c */ #include <tommath.h> #ifdef BN_MP_NEG_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* b = -a */ int mp_neg (mp_int * a, mp_int * b) { int res; if (a != b) { if ((res = mp_copy (a, b)) != MP_OKAY) { return res; } } if (mp_iszero(b) != MP_YES) { b->sign = (a->sign == MP_ZPOS) ? MP_NEG : MP_ZPOS; } else { b->sign = MP_ZPOS; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_neg.c */ /* Start: bn_mp_or.c */ #include <tommath.h> #ifdef BN_MP_OR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* OR two ints together */ int mp_or (mp_int * a, mp_int * b, mp_int * c) { int res, ix, px; mp_int t, *x; if (a->used > b->used) { if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } px = b->used; x = b; } else { if ((res = mp_init_copy (&t, b)) != MP_OKAY) { return res; } px = a->used; x = a; } for (ix = 0; ix < px; ix++) { t.dp[ix] |= x->dp[ix]; } mp_clamp (&t); mp_exch (c, &t); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_or.c */ /* Start: bn_mp_prime_fermat.c */ #include <tommath.h> #ifdef BN_MP_PRIME_FERMAT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* performs one Fermat test. * * If "a" were prime then b**a == b (mod a) since the order of * the multiplicative sub-group would be phi(a) = a-1. That means * it would be the same as b**(a mod (a-1)) == b**1 == b (mod a). * * Sets result to 1 if the congruence holds, or zero otherwise. */ int mp_prime_fermat (mp_int * a, mp_int * b, int *result) { mp_int t; int err; /* default to composite */ *result = MP_NO; /* ensure b > 1 */ if (mp_cmp_d(b, 1) != MP_GT) { return MP_VAL; } /* init t */ if ((err = mp_init (&t)) != MP_OKAY) { return err; } /* compute t = b**a mod a */ if ((err = mp_exptmod (b, a, a, &t)) != MP_OKAY) { goto LBL_T; } /* is it equal to b? */ if (mp_cmp (&t, b) == MP_EQ) { *result = MP_YES; } err = MP_OKAY; LBL_T:mp_clear (&t); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_prime_fermat.c */ /* Start: bn_mp_prime_is_divisible.c */ #include <tommath.h> #ifdef BN_MP_PRIME_IS_DIVISIBLE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines if an integers is divisible by one * of the first PRIME_SIZE primes or not * * sets result to 0 if not, 1 if yes */ int mp_prime_is_divisible (mp_int * a, int *result) { int err, ix; mp_digit res; /* default to not */ *result = MP_NO; for (ix = 0; ix < PRIME_SIZE; ix++) { /* what is a mod LBL_prime_tab[ix] */ if ((err = mp_mod_d (a, ltm_prime_tab[ix], &res)) != MP_OKAY) { return err; } /* is the residue zero? */ if (res == 0) { *result = MP_YES; return MP_OKAY; } } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_prime_is_divisible.c */ /* Start: bn_mp_prime_is_prime.c */ #include <tommath.h> #ifdef BN_MP_PRIME_IS_PRIME_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* performs a variable number of rounds of Miller-Rabin * * Probability of error after t rounds is no more than * * Sets result to 1 if probably prime, 0 otherwise */ int mp_prime_is_prime (mp_int * a, int t, int *result) { mp_int b; int ix, err, res; /* default to no */ *result = MP_NO; /* valid value of t? */ if (t <= 0 || t > PRIME_SIZE) { return MP_VAL; } /* is the input equal to one of the primes in the table? */ for (ix = 0; ix < PRIME_SIZE; ix++) { if (mp_cmp_d(a, ltm_prime_tab[ix]) == MP_EQ) { *result = 1; return MP_OKAY; } } /* first perform trial division */ if ((err = mp_prime_is_divisible (a, &res)) != MP_OKAY) { return err; } /* return if it was trivially divisible */ if (res == MP_YES) { return MP_OKAY; } /* now perform the miller-rabin rounds */ if ((err = mp_init (&b)) != MP_OKAY) { return err; } for (ix = 0; ix < t; ix++) { /* set the prime */ mp_set (&b, ltm_prime_tab[ix]); if ((err = mp_prime_miller_rabin (a, &b, &res)) != MP_OKAY) { goto LBL_B; } if (res == MP_NO) { goto LBL_B; } } /* passed the test */ *result = MP_YES; LBL_B:mp_clear (&b); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_prime_is_prime.c */ /* Start: bn_mp_prime_miller_rabin.c */ #include <tommath.h> #ifdef BN_MP_PRIME_MILLER_RABIN_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Miller-Rabin test of "a" to the base of "b" as described in * HAC pp. 139 Algorithm 4.24 * * Sets result to 0 if definitely composite or 1 if probably prime. * Randomly the chance of error is no more than 1/4 and often * very much lower. */ int mp_prime_miller_rabin (mp_int * a, mp_int * b, int *result) { mp_int n1, y, r; int s, j, err; /* default */ *result = MP_NO; /* ensure b > 1 */ if (mp_cmp_d(b, 1) != MP_GT) { return MP_VAL; } /* get n1 = a - 1 */ if ((err = mp_init_copy (&n1, a)) != MP_OKAY) { return err; } if ((err = mp_sub_d (&n1, 1, &n1)) != MP_OKAY) { goto LBL_N1; } /* set 2**s * r = n1 */ if ((err = mp_init_copy (&r, &n1)) != MP_OKAY) { goto LBL_N1; } /* count the number of least significant bits * which are zero */ s = mp_cnt_lsb(&r); /* now divide n - 1 by 2**s */ if ((err = mp_div_2d (&r, s, &r, NULL)) != MP_OKAY) { goto LBL_R; } /* compute y = b**r mod a */ if ((err = mp_init (&y)) != MP_OKAY) { goto LBL_R; } if ((err = mp_exptmod (b, &r, a, &y)) != MP_OKAY) { goto LBL_Y; } /* if y != 1 and y != n1 do */ if (mp_cmp_d (&y, 1) != MP_EQ && mp_cmp (&y, &n1) != MP_EQ) { j = 1; /* while j <= s-1 and y != n1 */ while ((j <= (s - 1)) && mp_cmp (&y, &n1) != MP_EQ) { if ((err = mp_sqrmod (&y, a, &y)) != MP_OKAY) { goto LBL_Y; } /* if y == 1 then composite */ if (mp_cmp_d (&y, 1) == MP_EQ) { goto LBL_Y; } ++j; } /* if y != n1 then composite */ if (mp_cmp (&y, &n1) != MP_EQ) { goto LBL_Y; } } /* probably prime now */ *result = MP_YES; LBL_Y:mp_clear (&y); LBL_R:mp_clear (&r); LBL_N1:mp_clear (&n1); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_prime_miller_rabin.c */ /* Start: bn_mp_prime_next_prime.c */ #include <tommath.h> #ifdef BN_MP_PRIME_NEXT_PRIME_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* finds the next prime after the number "a" using "t" trials * of Miller-Rabin. * * bbs_style = 1 means the prime must be congruent to 3 mod 4 */ int mp_prime_next_prime(mp_int *a, int t, int bbs_style) { int err, res, x, y; mp_digit res_tab[PRIME_SIZE], step, kstep; mp_int b; /* ensure t is valid */ if (t <= 0 || t > PRIME_SIZE) { return MP_VAL; } /* force positive */ a->sign = MP_ZPOS; /* simple algo if a is less than the largest prime in the table */ if (mp_cmp_d(a, ltm_prime_tab[PRIME_SIZE-1]) == MP_LT) { /* find which prime it is bigger than */ for (x = PRIME_SIZE - 2; x >= 0; x--) { if (mp_cmp_d(a, ltm_prime_tab[x]) != MP_LT) { if (bbs_style == 1) { /* ok we found a prime smaller or * equal [so the next is larger] * * however, the prime must be * congruent to 3 mod 4 */ if ((ltm_prime_tab[x + 1] & 3) != 3) { /* scan upwards for a prime congruent to 3 mod 4 */ for (y = x + 1; y < PRIME_SIZE; y++) { if ((ltm_prime_tab[y] & 3) == 3) { mp_set(a, ltm_prime_tab[y]); return MP_OKAY; } } } } else { mp_set(a, ltm_prime_tab[x + 1]); return MP_OKAY; } } } /* at this point a maybe 1 */ if (mp_cmp_d(a, 1) == MP_EQ) { mp_set(a, 2); return MP_OKAY; } /* fall through to the sieve */ } /* generate a prime congruent to 3 mod 4 or 1/3 mod 4? */ if (bbs_style == 1) { kstep = 4; } else { kstep = 2; } /* at this point we will use a combination of a sieve and Miller-Rabin */ if (bbs_style == 1) { /* if a mod 4 != 3 subtract the correct value to make it so */ if ((a->dp[0] & 3) != 3) { if ((err = mp_sub_d(a, (a->dp[0] & 3) + 1, a)) != MP_OKAY) { return err; }; } } else { if (mp_iseven(a) == 1) { /* force odd */ if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) { return err; } } } /* generate the restable */ for (x = 1; x < PRIME_SIZE; x++) { if ((err = mp_mod_d(a, ltm_prime_tab[x], res_tab + x)) != MP_OKAY) { return err; } } /* init temp used for Miller-Rabin Testing */ if ((err = mp_init(&b)) != MP_OKAY) { return err; } for (;;) { /* skip to the next non-trivially divisible candidate */ step = 0; do { /* y == 1 if any residue was zero [e.g. cannot be prime] */ y = 0; /* increase step to next candidate */ step += kstep; /* compute the new residue without using division */ for (x = 1; x < PRIME_SIZE; x++) { /* add the step to each residue */ res_tab[x] += kstep; /* subtract the modulus [instead of using division] */ if (res_tab[x] >= ltm_prime_tab[x]) { res_tab[x] -= ltm_prime_tab[x]; } /* set flag if zero */ if (res_tab[x] == 0) { y = 1; } } } while (y == 1 && step < ((((mp_digit)1)<<DIGIT_BIT) - kstep)); /* add the step */ if ((err = mp_add_d(a, step, a)) != MP_OKAY) { goto LBL_ERR; } /* if didn't pass sieve and step == MAX then skip test */ if (y == 1 && step >= ((((mp_digit)1)<<DIGIT_BIT) - kstep)) { continue; } /* is this prime? */ for (x = 0; x < t; x++) { mp_set(&b, ltm_prime_tab[t]); if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) { goto LBL_ERR; } if (res == MP_NO) { break; } } if (res == MP_YES) { break; } } err = MP_OKAY; LBL_ERR: mp_clear(&b); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_prime_next_prime.c */ /* Start: bn_mp_prime_rabin_miller_trials.c */ #include <tommath.h> #ifdef BN_MP_PRIME_RABIN_MILLER_TRIALS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ static const struct { int k, t; } sizes[] = { { 128, 28 }, { 256, 16 }, { 384, 10 }, { 512, 7 }, { 640, 6 }, { 768, 5 }, { 896, 4 }, { 1024, 4 } }; /* returns # of RM trials required for a given bit size */ int mp_prime_rabin_miller_trials(int size) { int x; for (x = 0; x < (int)(sizeof(sizes)/(sizeof(sizes[0]))); x++) { if (sizes[x].k == size) { return sizes[x].t; } else if (sizes[x].k > size) { return (x == 0) ? sizes[0].t : sizes[x - 1].t; } } return sizes[x-1].t + 1; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_prime_rabin_miller_trials.c */ /* Start: bn_mp_prime_random_ex.c */ #include <tommath.h> #ifdef BN_MP_PRIME_RANDOM_EX_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* makes a truly random prime of a given size (bits), * * Flags are as follows: * * LTM_PRIME_BBS - make prime congruent to 3 mod 4 * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero * LTM_PRIME_2MSB_ON - make the 2nd highest bit one * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself * so it can be NULL * */ /* This is possibly the mother of all prime generation functions, muahahahahaha! */ int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat) { unsigned char *tmp, maskAND, maskOR_msb, maskOR_lsb; int res, err, bsize, maskOR_msb_offset; /* sanity check the input */ if (size <= 1 || t <= 0) { return MP_VAL; } /* LTM_PRIME_SAFE implies LTM_PRIME_BBS */ if (flags & LTM_PRIME_SAFE) { flags |= LTM_PRIME_BBS; } /* calc the byte size */ bsize = (size>>3) + ((size&7)?1:0); /* we need a buffer of bsize bytes */ tmp = OPT_CAST(unsigned char) XMALLOC(bsize); if (tmp == NULL) { return MP_MEM; } /* calc the maskAND value for the MSbyte*/ maskAND = ((size&7) == 0) ? 0xFF : (0xFF >> (8 - (size & 7))); /* calc the maskOR_msb */ maskOR_msb = 0; maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0; if (flags & LTM_PRIME_2MSB_ON) { maskOR_msb |= 0x80 >> ((9 - size) & 7); } /* get the maskOR_lsb */ maskOR_lsb = 1; if (flags & LTM_PRIME_BBS) { maskOR_lsb |= 3; } do { /* read the bytes */ if (cb(tmp, bsize, dat) != bsize) { err = MP_VAL; goto error; } /* work over the MSbyte */ tmp[0] &= maskAND; tmp[0] |= 1 << ((size - 1) & 7); /* mix in the maskORs */ tmp[maskOR_msb_offset] |= maskOR_msb; tmp[bsize-1] |= maskOR_lsb; /* read it in */ if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY) { goto error; } /* is it prime? */ if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { goto error; } if (res == MP_NO) { continue; } if (flags & LTM_PRIME_SAFE) { /* see if (a-1)/2 is prime */ if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) { goto error; } if ((err = mp_div_2(a, a)) != MP_OKAY) { goto error; } /* is it prime? */ if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { goto error; } } } while (res == MP_NO); if (flags & LTM_PRIME_SAFE) { /* restore a to the original value */ if ((err = mp_mul_2(a, a)) != MP_OKAY) { goto error; } if ((err = mp_add_d(a, 1, a)) != MP_OKAY) { goto error; } } err = MP_OKAY; error: XFREE(tmp); return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_prime_random_ex.c */ /* Start: bn_mp_radix_size.c */ #include <tommath.h> #ifdef BN_MP_RADIX_SIZE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* returns size of ASCII reprensentation */ int mp_radix_size (mp_int * a, int radix, int *size) { int res, digs; mp_int t; mp_digit d; *size = 0; /* special case for binary */ if (radix == 2) { *size = mp_count_bits (a) + (a->sign == MP_NEG ? 1 : 0) + 1; return MP_OKAY; } /* make sure the radix is in range */ if (radix < 2 || radix > 64) { return MP_VAL; } if (mp_iszero(a) == MP_YES) { *size = 2; return MP_OKAY; } /* digs is the digit count */ digs = 0; /* if it's negative add one for the sign */ if (a->sign == MP_NEG) { ++digs; } /* init a copy of the input */ if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } /* force temp to positive */ t.sign = MP_ZPOS; /* fetch out all of the digits */ while (mp_iszero (&t) == MP_NO) { if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { mp_clear (&t); return res; } ++digs; } mp_clear (&t); /* return digs + 1, the 1 is for the NULL byte that would be required. */ *size = digs + 1; return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_radix_size.c */ /* Start: bn_mp_radix_smap.c */ #include <tommath.h> #ifdef BN_MP_RADIX_SMAP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* chars used in radix conversions */ const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_radix_smap.c */ /* Start: bn_mp_rand.c */ #include <tommath.h> #ifdef BN_MP_RAND_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* makes a pseudo-random int of a given size */ int mp_rand (mp_int * a, int digits) { int res; mp_digit d; mp_zero (a); if (digits <= 0) { return MP_OKAY; } /* first place a random non-zero digit */ do { d = ((mp_digit) abs (rand ())) & MP_MASK; } while (d == 0); if ((res = mp_add_d (a, d, a)) != MP_OKAY) { return res; } while (--digits > 0) { if ((res = mp_lshd (a, 1)) != MP_OKAY) { return res; } if ((res = mp_add_d (a, ((mp_digit) abs (rand ())), a)) != MP_OKAY) { return res; } } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_rand.c */ /* Start: bn_mp_read_radix.c */ #include <tommath.h> #ifdef BN_MP_READ_RADIX_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* read a string [ASCII] in a given radix */ int mp_read_radix (mp_int * a, const char *str, int radix) { int y, res, neg; char ch; /* make sure the radix is ok */ if (radix < 2 || radix > 64) { return MP_VAL; } /* if the leading digit is a * minus set the sign to negative. */ if (*str == '-') { ++str; neg = MP_NEG; } else { neg = MP_ZPOS; } /* set the integer to the default of zero */ mp_zero (a); /* process each digit of the string */ while (*str) { /* if the radix < 36 the conversion is case insensitive * this allows numbers like 1AB and 1ab to represent the same value * [e.g. in hex] */ ch = (char) ((radix < 36) ? toupper (*str) : *str); for (y = 0; y < 64; y++) { if (ch == mp_s_rmap[y]) { break; } } /* if the char was found in the map * and is less than the given radix add it * to the number, otherwise exit the loop. */ if (y < radix) { if ((res = mp_mul_d (a, (mp_digit) radix, a)) != MP_OKAY) { return res; } if ((res = mp_add_d (a, (mp_digit) y, a)) != MP_OKAY) { return res; } } else { break; } ++str; } /* set the sign only if a != 0 */ if (mp_iszero(a) != 1) { a->sign = neg; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_read_radix.c */ /* Start: bn_mp_read_signed_bin.c */ #include <tommath.h> #ifdef BN_MP_READ_SIGNED_BIN_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* read signed bin, big endian, first byte is 0==positive or 1==negative */ int mp_read_signed_bin (mp_int * a, const unsigned char *b, int c) { int res; /* read magnitude */ if ((res = mp_read_unsigned_bin (a, b + 1, c - 1)) != MP_OKAY) { return res; } /* first byte is 0 for positive, non-zero for negative */ if (b[0] == 0) { a->sign = MP_ZPOS; } else { a->sign = MP_NEG; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_read_signed_bin.c */ /* Start: bn_mp_read_unsigned_bin.c */ #include <tommath.h> #ifdef BN_MP_READ_UNSIGNED_BIN_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* reads a unsigned char array, assumes the msb is stored first [big endian] */ int mp_read_unsigned_bin (mp_int * a, const unsigned char *b, int c) { int res; /* make sure there are at least two digits */ if (a->alloc < 2) { if ((res = mp_grow(a, 2)) != MP_OKAY) { return res; } } /* zero the int */ mp_zero (a); /* read the bytes in */ while (c-- > 0) { if ((res = mp_mul_2d (a, 8, a)) != MP_OKAY) { return res; } #ifndef MP_8BIT a->dp[0] |= *b++; a->used += 1; #else a->dp[0] = (*b & MP_MASK); a->dp[1] |= ((*b++ >> 7U) & 1); a->used += 2; #endif } mp_clamp (a); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_read_unsigned_bin.c */ /* Start: bn_mp_reduce.c */ #include <tommath.h> #ifdef BN_MP_REDUCE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* reduces x mod m, assumes 0 < x < m**2, mu is * precomputed via mp_reduce_setup. * From HAC pp.604 Algorithm 14.42 */ int mp_reduce (mp_int * x, mp_int * m, mp_int * mu) { mp_int q; int res, um = m->used; /* q = x */ if ((res = mp_init_copy (&q, x)) != MP_OKAY) { return res; } /* q1 = x / b**(k-1) */ mp_rshd (&q, um - 1); /* according to HAC this optimization is ok */ if (((unsigned long) um) > (((mp_digit)1) << (DIGIT_BIT - 1))) { if ((res = mp_mul (&q, mu, &q)) != MP_OKAY) { goto CLEANUP; } } else { #ifdef BN_S_MP_MUL_HIGH_DIGS_C if ((res = s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) { goto CLEANUP; } #elif defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C) if ((res = fast_s_mp_mul_high_digs (&q, mu, &q, um)) != MP_OKAY) { goto CLEANUP; } #else { res = MP_VAL; goto CLEANUP; } #endif } /* q3 = q2 / b**(k+1) */ mp_rshd (&q, um + 1); /* x = x mod b**(k+1), quick (no division) */ if ((res = mp_mod_2d (x, DIGIT_BIT * (um + 1), x)) != MP_OKAY) { goto CLEANUP; } /* q = q * m mod b**(k+1), quick (no division) */ if ((res = s_mp_mul_digs (&q, m, &q, um + 1)) != MP_OKAY) { goto CLEANUP; } /* x = x - q */ if ((res = mp_sub (x, &q, x)) != MP_OKAY) { goto CLEANUP; } /* If x < 0, add b**(k+1) to it */ if (mp_cmp_d (x, 0) == MP_LT) { mp_set (&q, 1); if ((res = mp_lshd (&q, um + 1)) != MP_OKAY) goto CLEANUP; if ((res = mp_add (x, &q, x)) != MP_OKAY) goto CLEANUP; } /* Back off if it's too big */ while (mp_cmp (x, m) != MP_LT) { if ((res = s_mp_sub (x, m, x)) != MP_OKAY) { goto CLEANUP; } } CLEANUP: mp_clear (&q); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_reduce.c */ /* Start: bn_mp_reduce_2k.c */ #include <tommath.h> #ifdef BN_MP_REDUCE_2K_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* reduces a modulo n where n is of the form 2**p - d */ int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d) { mp_int q; int p, res; if ((res = mp_init(&q)) != MP_OKAY) { return res; } p = mp_count_bits(n); top: /* q = a/2**p, a = a mod 2**p */ if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { goto ERR; } if (d != 1) { /* q = q * d */ if ((res = mp_mul_d(&q, d, &q)) != MP_OKAY) { goto ERR; } } /* a = a + q */ if ((res = s_mp_add(a, &q, a)) != MP_OKAY) { goto ERR; } if (mp_cmp_mag(a, n) != MP_LT) { s_mp_sub(a, n, a); goto top; } ERR: mp_clear(&q); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_reduce_2k.c */ /* Start: bn_mp_reduce_2k_l.c */ #include <tommath.h> #ifdef BN_MP_REDUCE_2K_L_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* reduces a modulo n where n is of the form 2**p - d This differs from reduce_2k since "d" can be larger than a single digit. */ int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d) { mp_int q; int p, res; if ((res = mp_init(&q)) != MP_OKAY) { return res; } p = mp_count_bits(n); top: /* q = a/2**p, a = a mod 2**p */ if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { goto ERR; } /* q = q * d */ if ((res = mp_mul(&q, d, &q)) != MP_OKAY) { goto ERR; } /* a = a + q */ if ((res = s_mp_add(a, &q, a)) != MP_OKAY) { goto ERR; } if (mp_cmp_mag(a, n) != MP_LT) { s_mp_sub(a, n, a); goto top; } ERR: mp_clear(&q); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_reduce_2k_l.c */ /* Start: bn_mp_reduce_2k_setup.c */ #include <tommath.h> #ifdef BN_MP_REDUCE_2K_SETUP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines the setup value */ int mp_reduce_2k_setup(mp_int *a, mp_digit *d) { int res, p; mp_int tmp; if ((res = mp_init(&tmp)) != MP_OKAY) { return res; } p = mp_count_bits(a); if ((res = mp_2expt(&tmp, p)) != MP_OKAY) { mp_clear(&tmp); return res; } if ((res = s_mp_sub(&tmp, a, &tmp)) != MP_OKAY) { mp_clear(&tmp); return res; } *d = tmp.dp[0]; mp_clear(&tmp); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_reduce_2k_setup.c */ /* Start: bn_mp_reduce_2k_setup_l.c */ #include <tommath.h> #ifdef BN_MP_REDUCE_2K_SETUP_L_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines the setup value */ int mp_reduce_2k_setup_l(mp_int *a, mp_int *d) { int res; mp_int tmp; if ((res = mp_init(&tmp)) != MP_OKAY) { return res; } if ((res = mp_2expt(&tmp, mp_count_bits(a))) != MP_OKAY) { goto ERR; } if ((res = s_mp_sub(&tmp, a, d)) != MP_OKAY) { goto ERR; } ERR: mp_clear(&tmp); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_reduce_2k_setup_l.c */ /* Start: bn_mp_reduce_is_2k.c */ #include <tommath.h> #ifdef BN_MP_REDUCE_IS_2K_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines if mp_reduce_2k can be used */ int mp_reduce_is_2k(mp_int *a) { int ix, iy, iw; mp_digit iz; if (a->used == 0) { return MP_NO; } else if (a->used == 1) { return MP_YES; } else if (a->used > 1) { iy = mp_count_bits(a); iz = 1; iw = 1; /* Test every bit from the second digit up, must be 1 */ for (ix = DIGIT_BIT; ix < iy; ix++) { if ((a->dp[iw] & iz) == 0) { return MP_NO; } iz <<= 1; if (iz > (mp_digit)MP_MASK) { ++iw; iz = 1; } } } return MP_YES; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_reduce_is_2k.c */ /* Start: bn_mp_reduce_is_2k_l.c */ #include <tommath.h> #ifdef BN_MP_REDUCE_IS_2K_L_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* determines if reduce_2k_l can be used */ int mp_reduce_is_2k_l(mp_int *a) { int ix, iy; if (a->used == 0) { return MP_NO; } else if (a->used == 1) { return MP_YES; } else if (a->used > 1) { /* if more than half of the digits are -1 we're sold */ for (iy = ix = 0; ix < a->used; ix++) { if (a->dp[ix] == MP_MASK) { ++iy; } } return (iy >= (a->used/2)) ? MP_YES : MP_NO; } return MP_NO; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_reduce_is_2k_l.c */ /* Start: bn_mp_reduce_setup.c */ #include <tommath.h> #ifdef BN_MP_REDUCE_SETUP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* pre-calculate the value required for Barrett reduction * For a given modulus "b" it calulates the value required in "a" */ int mp_reduce_setup (mp_int * a, mp_int * b) { int res; if ((res = mp_2expt (a, b->used * 2 * DIGIT_BIT)) != MP_OKAY) { return res; } return mp_div (a, b, a, NULL); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_reduce_setup.c */ /* Start: bn_mp_rshd.c */ #include <tommath.h> #ifdef BN_MP_RSHD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* shift right a certain amount of digits */ void mp_rshd (mp_int * a, int b) { int x; /* if b <= 0 then ignore it */ if (b <= 0) { return; } /* if b > used then simply zero it and return */ if (a->used <= b) { mp_zero (a); return; } { register mp_digit *bottom, *top; /* shift the digits down */ /* bottom */ bottom = a->dp; /* top [offset into digits] */ top = a->dp + b; /* this is implemented as a sliding window where * the window is b-digits long and digits from * the top of the window are copied to the bottom * * e.g. b-2 | b-1 | b0 | b1 | b2 | ... | bb | ----> /\ | ----> \-------------------/ ----> */ for (x = 0; x < (a->used - b); x++) { *bottom++ = *top++; } /* zero the top digits */ for (; x < a->used; x++) { *bottom++ = 0; } } /* remove excess digits */ a->used -= b; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_rshd.c */ /* Start: bn_mp_set.c */ #include <tommath.h> #ifdef BN_MP_SET_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* set to a digit */ void mp_set (mp_int * a, mp_digit b) { mp_zero (a); a->dp[0] = b & MP_MASK; a->used = (a->dp[0] != 0) ? 1 : 0; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_set.c */ /* Start: bn_mp_set_int.c */ #include <tommath.h> #ifdef BN_MP_SET_INT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* set a 32-bit const */ int mp_set_int (mp_int * a, unsigned long b) { int x, res; mp_zero (a); /* set four bits at a time */ for (x = 0; x < 8; x++) { /* shift the number up four bits */ if ((res = mp_mul_2d (a, 4, a)) != MP_OKAY) { return res; } /* OR in the top four bits of the source */ a->dp[0] |= (b >> 28) & 15; /* shift the source up to the next four bits */ b <<= 4; /* ensure that digits are not clamped off */ a->used += 1; } mp_clamp (a); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_set_int.c */ /* Start: bn_mp_shrink.c */ #include <tommath.h> #ifdef BN_MP_SHRINK_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* shrink a bignum */ int mp_shrink (mp_int * a) { mp_digit *tmp; if (a->alloc != a->used && a->used > 0) { if ((tmp = OPT_CAST(mp_digit) XREALLOC (a->dp, sizeof (mp_digit) * a->used)) == NULL) { return MP_MEM; } a->dp = tmp; a->alloc = a->used; } return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_shrink.c */ /* Start: bn_mp_signed_bin_size.c */ #include <tommath.h> #ifdef BN_MP_SIGNED_BIN_SIZE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* get the size for an signed equivalent */ int mp_signed_bin_size (mp_int * a) { return 1 + mp_unsigned_bin_size (a); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_signed_bin_size.c */ /* Start: bn_mp_sqr.c */ #include <tommath.h> #ifdef BN_MP_SQR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* computes b = a*a */ int mp_sqr (mp_int * a, mp_int * b) { int res; #ifdef BN_MP_TOOM_SQR_C /* use Toom-Cook? */ if (a->used >= TOOM_SQR_CUTOFF) { res = mp_toom_sqr(a, b); /* Karatsuba? */ } else #endif #ifdef BN_MP_KARATSUBA_SQR_C if (a->used >= KARATSUBA_SQR_CUTOFF) { res = mp_karatsuba_sqr (a, b); } else #endif { #ifdef BN_FAST_S_MP_SQR_C /* can we use the fast comba multiplier? */ if ((a->used * 2 + 1) < MP_WARRAY && a->used < (1 << (sizeof(mp_word) * CHAR_BIT - 2*DIGIT_BIT - 1))) { res = fast_s_mp_sqr (a, b); } else #endif #ifdef BN_S_MP_SQR_C res = s_mp_sqr (a, b); #else res = MP_VAL; #endif } b->sign = MP_ZPOS; return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_sqr.c */ /* Start: bn_mp_sqrmod.c */ #include <tommath.h> #ifdef BN_MP_SQRMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* c = a * a (mod b) */ int mp_sqrmod (mp_int * a, mp_int * b, mp_int * c) { int res; mp_int t; if ((res = mp_init (&t)) != MP_OKAY) { return res; } if ((res = mp_sqr (a, &t)) != MP_OKAY) { mp_clear (&t); return res; } res = mp_mod (&t, b, c); mp_clear (&t); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_sqrmod.c */ /* Start: bn_mp_sqrt.c */ #include <tommath.h> #ifdef BN_MP_SQRT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* this function is less generic than mp_n_root, simpler and faster */ int mp_sqrt(mp_int *arg, mp_int *ret) { int res; mp_int t1,t2; /* must be positive */ if (arg->sign == MP_NEG) { return MP_VAL; } /* easy out */ if (mp_iszero(arg) == MP_YES) { mp_zero(ret); return MP_OKAY; } if ((res = mp_init_copy(&t1, arg)) != MP_OKAY) { return res; } if ((res = mp_init(&t2)) != MP_OKAY) { goto E2; } /* First approx. (not very bad for large arg) */ mp_rshd (&t1,t1.used/2); /* t1 > 0 */ if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) { goto E1; } if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) { goto E1; } if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) { goto E1; } /* And now t1 > sqrt(arg) */ do { if ((res = mp_div(arg,&t1,&t2,NULL)) != MP_OKAY) { goto E1; } if ((res = mp_add(&t1,&t2,&t1)) != MP_OKAY) { goto E1; } if ((res = mp_div_2(&t1,&t1)) != MP_OKAY) { goto E1; } /* t1 >= sqrt(arg) >= t2 at this point */ } while (mp_cmp_mag(&t1,&t2) == MP_GT); mp_exch(&t1,ret); E1: mp_clear(&t2); E2: mp_clear(&t1); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_sqrt.c */ /* Start: bn_mp_sub.c */ #include <tommath.h> #ifdef BN_MP_SUB_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* high level subtraction (handles signs) */ int mp_sub (mp_int * a, mp_int * b, mp_int * c) { int sa, sb, res; sa = a->sign; sb = b->sign; if (sa != sb) { /* subtract a negative from a positive, OR */ /* subtract a positive from a negative. */ /* In either case, ADD their magnitudes, */ /* and use the sign of the first number. */ c->sign = sa; res = s_mp_add (a, b, c); } else { /* subtract a positive from a positive, OR */ /* subtract a negative from a negative. */ /* First, take the difference between their */ /* magnitudes, then... */ if (mp_cmp_mag (a, b) != MP_LT) { /* Copy the sign from the first */ c->sign = sa; /* The first has a larger or equal magnitude */ res = s_mp_sub (a, b, c); } else { /* The result has the *opposite* sign from */ /* the first number. */ c->sign = (sa == MP_ZPOS) ? MP_NEG : MP_ZPOS; /* The second has a larger magnitude */ res = s_mp_sub (b, a, c); } } return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_sub.c */ /* Start: bn_mp_sub_d.c */ #include <tommath.h> #ifdef BN_MP_SUB_D_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* single digit subtraction */ int mp_sub_d (mp_int * a, mp_digit b, mp_int * c) { mp_digit *tmpa, *tmpc, mu; int res, ix, oldused; /* grow c as required */ if (c->alloc < a->used + 1) { if ((res = mp_grow(c, a->used + 1)) != MP_OKAY) { return res; } } /* if a is negative just do an unsigned * addition [with fudged signs] */ if (a->sign == MP_NEG) { a->sign = MP_ZPOS; res = mp_add_d(a, b, c); a->sign = c->sign = MP_NEG; return res; } /* setup regs */ oldused = c->used; tmpa = a->dp; tmpc = c->dp; /* if a <= b simply fix the single digit */ if ((a->used == 1 && a->dp[0] <= b) || a->used == 0) { if (a->used == 1) { *tmpc++ = b - *tmpa; } else { *tmpc++ = b; } ix = 1; /* negative/1digit */ c->sign = MP_NEG; c->used = 1; } else { /* positive/size */ c->sign = MP_ZPOS; c->used = a->used; /* subtract first digit */ *tmpc = *tmpa++ - b; mu = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1); *tmpc++ &= MP_MASK; /* handle rest of the digits */ for (ix = 1; ix < a->used; ix++) { *tmpc = *tmpa++ - mu; mu = *tmpc >> (sizeof(mp_digit) * CHAR_BIT - 1); *tmpc++ &= MP_MASK; } } /* zero excess digits */ while (ix++ < oldused) { *tmpc++ = 0; } mp_clamp(c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_sub_d.c */ /* Start: bn_mp_submod.c */ #include <tommath.h> #ifdef BN_MP_SUBMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* d = a - b (mod c) */ int mp_submod (mp_int * a, mp_int * b, mp_int * c, mp_int * d) { int res; mp_int t; if ((res = mp_init (&t)) != MP_OKAY) { return res; } if ((res = mp_sub (a, b, &t)) != MP_OKAY) { mp_clear (&t); return res; } res = mp_mod (&t, c, d); mp_clear (&t); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_submod.c */ /* Start: bn_mp_to_signed_bin.c */ #include <tommath.h> #ifdef BN_MP_TO_SIGNED_BIN_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* store in signed [big endian] format */ int mp_to_signed_bin (mp_int * a, unsigned char *b) { int res; if ((res = mp_to_unsigned_bin (a, b + 1)) != MP_OKAY) { return res; } b[0] = (unsigned char) ((a->sign == MP_ZPOS) ? 0 : 1); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_to_signed_bin.c */ /* Start: bn_mp_to_signed_bin_n.c */ #include <tommath.h> #ifdef BN_MP_TO_SIGNED_BIN_N_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* store in signed [big endian] format */ int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) { if (*outlen < (unsigned long)mp_signed_bin_size(a)) { return MP_VAL; } *outlen = mp_signed_bin_size(a); return mp_to_signed_bin(a, b); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_to_signed_bin_n.c */ /* Start: bn_mp_to_unsigned_bin.c */ #include <tommath.h> #ifdef BN_MP_TO_UNSIGNED_BIN_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* store in unsigned [big endian] format */ int mp_to_unsigned_bin (mp_int * a, unsigned char *b) { int x, res; mp_int t; if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } x = 0; while (mp_iszero (&t) == 0) { #ifndef MP_8BIT b[x++] = (unsigned char) (t.dp[0] & 255); #else b[x++] = (unsigned char) (t.dp[0] | ((t.dp[1] & 0x01) << 7)); #endif if ((res = mp_div_2d (&t, 8, &t, NULL)) != MP_OKAY) { mp_clear (&t); return res; } } bn_reverse (b, x); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_to_unsigned_bin.c */ /* Start: bn_mp_to_unsigned_bin_n.c */ #include <tommath.h> #ifdef BN_MP_TO_UNSIGNED_BIN_N_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* store in unsigned [big endian] format */ int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen) { if (*outlen < (unsigned long)mp_unsigned_bin_size(a)) { return MP_VAL; } *outlen = mp_unsigned_bin_size(a); return mp_to_unsigned_bin(a, b); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_to_unsigned_bin_n.c */ /* Start: bn_mp_toom_mul.c */ #include <tommath.h> #ifdef BN_MP_TOOM_MUL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* multiplication using the Toom-Cook 3-way algorithm * * Much more complicated than Karatsuba but has a lower * asymptotic running time of O(N**1.464). This algorithm is * only particularly useful on VERY large inputs * (we're talking 1000s of digits here...). */ int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c) { mp_int w0, w1, w2, w3, w4, tmp1, tmp2, a0, a1, a2, b0, b1, b2; int res, B; /* init temps */ if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &b0, &b1, &b2, &tmp1, &tmp2, NULL)) != MP_OKAY) { return res; } /* B */ B = MIN(a->used, b->used) / 3; /* a = a2 * B**2 + a1 * B + a0 */ if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) { goto ERR; } if ((res = mp_copy(a, &a1)) != MP_OKAY) { goto ERR; } mp_rshd(&a1, B); mp_mod_2d(&a1, DIGIT_BIT * B, &a1); if ((res = mp_copy(a, &a2)) != MP_OKAY) { goto ERR; } mp_rshd(&a2, B*2); /* b = b2 * B**2 + b1 * B + b0 */ if ((res = mp_mod_2d(b, DIGIT_BIT * B, &b0)) != MP_OKAY) { goto ERR; } if ((res = mp_copy(b, &b1)) != MP_OKAY) { goto ERR; } mp_rshd(&b1, B); mp_mod_2d(&b1, DIGIT_BIT * B, &b1); if ((res = mp_copy(b, &b2)) != MP_OKAY) { goto ERR; } mp_rshd(&b2, B*2); /* w0 = a0*b0 */ if ((res = mp_mul(&a0, &b0, &w0)) != MP_OKAY) { goto ERR; } /* w4 = a2 * b2 */ if ((res = mp_mul(&a2, &b2, &w4)) != MP_OKAY) { goto ERR; } /* w1 = (a2 + 2(a1 + 2a0))(b2 + 2(b1 + 2b0)) */ if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&b0, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp2, &b2, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_mul(&tmp1, &tmp2, &w1)) != MP_OKAY) { goto ERR; } /* w3 = (a0 + 2(a1 + 2a2))(b0 + 2(b1 + 2b2)) */ if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&b2, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp2, &b1, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&tmp2, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_mul(&tmp1, &tmp2, &w3)) != MP_OKAY) { goto ERR; } /* w2 = (a2 + a1 + a0)(b2 + b1 + b0) */ if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&b2, &b1, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp2, &b0, &tmp2)) != MP_OKAY) { goto ERR; } if ((res = mp_mul(&tmp1, &tmp2, &w2)) != MP_OKAY) { goto ERR; } /* now solve the matrix 0 0 0 0 1 1 2 4 8 16 1 1 1 1 1 16 8 4 2 1 1 0 0 0 0 using 12 subtractions, 4 shifts, 2 small divisions and 1 small multiplication */ /* r1 - r4 */ if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) { goto ERR; } /* r3 - r0 */ if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) { goto ERR; } /* r1/2 */ if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) { goto ERR; } /* r3/2 */ if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) { goto ERR; } /* r2 - r0 - r4 */ if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) { goto ERR; } /* r1 - r2 */ if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { goto ERR; } /* r3 - r2 */ if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { goto ERR; } /* r1 - 8r0 */ if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) { goto ERR; } /* r3 - 8r4 */ if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { goto ERR; } /* 3r2 - r1 - r3 */ if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { goto ERR; } /* r1 - r2 */ if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { goto ERR; } /* r3 - r2 */ if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { goto ERR; } /* r1/3 */ if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) { goto ERR; } /* r3/3 */ if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) { goto ERR; } /* at this point shift W[n] by B*n */ if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) { goto ERR; } if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) { goto ERR; } if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) { goto ERR; } if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&w0, &w1, c)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, c, c)) != MP_OKAY) { goto ERR; } ERR: mp_clear_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &b0, &b1, &b2, &tmp1, &tmp2, NULL); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_toom_mul.c */ /* Start: bn_mp_toom_sqr.c */ #include <tommath.h> #ifdef BN_MP_TOOM_SQR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* squaring using Toom-Cook 3-way algorithm */ int mp_toom_sqr(mp_int *a, mp_int *b) { mp_int w0, w1, w2, w3, w4, tmp1, a0, a1, a2; int res, B; /* init temps */ if ((res = mp_init_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL)) != MP_OKAY) { return res; } /* B */ B = a->used / 3; /* a = a2 * B**2 + a1 * B + a0 */ if ((res = mp_mod_2d(a, DIGIT_BIT * B, &a0)) != MP_OKAY) { goto ERR; } if ((res = mp_copy(a, &a1)) != MP_OKAY) { goto ERR; } mp_rshd(&a1, B); mp_mod_2d(&a1, DIGIT_BIT * B, &a1); if ((res = mp_copy(a, &a2)) != MP_OKAY) { goto ERR; } mp_rshd(&a2, B*2); /* w0 = a0*a0 */ if ((res = mp_sqr(&a0, &w0)) != MP_OKAY) { goto ERR; } /* w4 = a2 * a2 */ if ((res = mp_sqr(&a2, &w4)) != MP_OKAY) { goto ERR; } /* w1 = (a2 + 2(a1 + 2a0))**2 */ if ((res = mp_mul_2(&a0, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a2, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sqr(&tmp1, &w1)) != MP_OKAY) { goto ERR; } /* w3 = (a0 + 2(a1 + 2a2))**2 */ if ((res = mp_mul_2(&a2, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_mul_2(&tmp1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sqr(&tmp1, &w3)) != MP_OKAY) { goto ERR; } /* w2 = (a2 + a1 + a0)**2 */ if ((res = mp_add(&a2, &a1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, &a0, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sqr(&tmp1, &w2)) != MP_OKAY) { goto ERR; } /* now solve the matrix 0 0 0 0 1 1 2 4 8 16 1 1 1 1 1 16 8 4 2 1 1 0 0 0 0 using 12 subtractions, 4 shifts, 2 small divisions and 1 small multiplication. */ /* r1 - r4 */ if ((res = mp_sub(&w1, &w4, &w1)) != MP_OKAY) { goto ERR; } /* r3 - r0 */ if ((res = mp_sub(&w3, &w0, &w3)) != MP_OKAY) { goto ERR; } /* r1/2 */ if ((res = mp_div_2(&w1, &w1)) != MP_OKAY) { goto ERR; } /* r3/2 */ if ((res = mp_div_2(&w3, &w3)) != MP_OKAY) { goto ERR; } /* r2 - r0 - r4 */ if ((res = mp_sub(&w2, &w0, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w4, &w2)) != MP_OKAY) { goto ERR; } /* r1 - r2 */ if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { goto ERR; } /* r3 - r2 */ if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { goto ERR; } /* r1 - 8r0 */ if ((res = mp_mul_2d(&w0, 3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w1, &tmp1, &w1)) != MP_OKAY) { goto ERR; } /* r3 - 8r4 */ if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { goto ERR; } /* 3r2 - r1 - r3 */ if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { goto ERR; } /* r1 - r2 */ if ((res = mp_sub(&w1, &w2, &w1)) != MP_OKAY) { goto ERR; } /* r3 - r2 */ if ((res = mp_sub(&w3, &w2, &w3)) != MP_OKAY) { goto ERR; } /* r1/3 */ if ((res = mp_div_3(&w1, &w1, NULL)) != MP_OKAY) { goto ERR; } /* r3/3 */ if ((res = mp_div_3(&w3, &w3, NULL)) != MP_OKAY) { goto ERR; } /* at this point shift W[n] by B*n */ if ((res = mp_lshd(&w1, 1*B)) != MP_OKAY) { goto ERR; } if ((res = mp_lshd(&w2, 2*B)) != MP_OKAY) { goto ERR; } if ((res = mp_lshd(&w3, 3*B)) != MP_OKAY) { goto ERR; } if ((res = mp_lshd(&w4, 4*B)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&w0, &w1, b)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&w2, &w3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&w4, &tmp1, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_add(&tmp1, b, b)) != MP_OKAY) { goto ERR; } ERR: mp_clear_multi(&w0, &w1, &w2, &w3, &w4, &a0, &a1, &a2, &tmp1, NULL); return res; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_toom_sqr.c */ /* Start: bn_mp_toradix.c */ #include <tommath.h> #ifdef BN_MP_TORADIX_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* stores a bignum as a ASCII string in a given radix (2..64) */ int mp_toradix (mp_int * a, char *str, int radix) { int res, digs; mp_int t; mp_digit d; char *_s = str; /* check range of the radix */ if (radix < 2 || radix > 64) { return MP_VAL; } /* quick out if its zero */ if (mp_iszero(a) == 1) { *str++ = '0'; *str = '\0'; return MP_OKAY; } if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } /* if it is negative output a - */ if (t.sign == MP_NEG) { ++_s; *str++ = '-'; t.sign = MP_ZPOS; } digs = 0; while (mp_iszero (&t) == 0) { if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { mp_clear (&t); return res; } *str++ = mp_s_rmap[d]; ++digs; } /* reverse the digits of the string. In this case _s points * to the first digit [exluding the sign] of the number] */ bn_reverse ((unsigned char *)_s, digs); /* append a NULL so the string is properly terminated */ *str = '\0'; mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_toradix.c */ /* Start: bn_mp_toradix_n.c */ #include <tommath.h> #ifdef BN_MP_TORADIX_N_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* stores a bignum as a ASCII string in a given radix (2..64) * * Stores upto maxlen-1 chars and always a NULL byte */ int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen) { int res, digs; mp_int t; mp_digit d; char *_s = str; /* check range of the maxlen, radix */ if (maxlen < 3 || radix < 2 || radix > 64) { return MP_VAL; } /* quick out if its zero */ if (mp_iszero(a) == 1) { *str++ = '0'; *str = '\0'; return MP_OKAY; } if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } /* if it is negative output a - */ if (t.sign == MP_NEG) { /* we have to reverse our digits later... but not the - sign!! */ ++_s; /* store the flag and mark the number as positive */ *str++ = '-'; t.sign = MP_ZPOS; /* subtract a char */ --maxlen; } digs = 0; while (mp_iszero (&t) == 0) { if ((res = mp_div_d (&t, (mp_digit) radix, &t, &d)) != MP_OKAY) { mp_clear (&t); return res; } *str++ = mp_s_rmap[d]; ++digs; if (--maxlen == 1) { /* no more room */ break; } } /* reverse the digits of the string. In this case _s points * to the first digit [exluding the sign] of the number] */ bn_reverse ((unsigned char *)_s, digs); /* append a NULL so the string is properly terminated */ *str = '\0'; mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_toradix_n.c */ /* Start: bn_mp_unsigned_bin_size.c */ #include <tommath.h> #ifdef BN_MP_UNSIGNED_BIN_SIZE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* get the size for an unsigned equivalent */ int mp_unsigned_bin_size (mp_int * a) { int size = mp_count_bits (a); return (size / 8 + ((size & 7) != 0 ? 1 : 0)); } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_unsigned_bin_size.c */ /* Start: bn_mp_xor.c */ #include <tommath.h> #ifdef BN_MP_XOR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* XOR two ints together */ int mp_xor (mp_int * a, mp_int * b, mp_int * c) { int res, ix, px; mp_int t, *x; if (a->used > b->used) { if ((res = mp_init_copy (&t, a)) != MP_OKAY) { return res; } px = b->used; x = b; } else { if ((res = mp_init_copy (&t, b)) != MP_OKAY) { return res; } px = a->used; x = a; } for (ix = 0; ix < px; ix++) { t.dp[ix] ^= x->dp[ix]; } mp_clamp (&t); mp_exch (c, &t); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_xor.c */ /* Start: bn_mp_zero.c */ #include <tommath.h> #ifdef BN_MP_ZERO_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* set to zero */ void mp_zero (mp_int * a) { int n; mp_digit *tmp; a->sign = MP_ZPOS; a->used = 0; tmp = a->dp; for (n = 0; n < a->alloc; n++) { *tmp++ = 0; } } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_mp_zero.c */ /* Start: bn_prime_tab.c */ #include <tommath.h> #ifdef BN_PRIME_TAB_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ const mp_digit ltm_prime_tab[] = { 0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013, 0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035, 0x003B, 0x003D, 0x0043, 0x0047, 0x0049, 0x004F, 0x0053, 0x0059, 0x0061, 0x0065, 0x0067, 0x006B, 0x006D, 0x0071, 0x007F, #ifndef MP_8BIT 0x0083, 0x0089, 0x008B, 0x0095, 0x0097, 0x009D, 0x00A3, 0x00A7, 0x00AD, 0x00B3, 0x00B5, 0x00BF, 0x00C1, 0x00C5, 0x00C7, 0x00D3, 0x00DF, 0x00E3, 0x00E5, 0x00E9, 0x00EF, 0x00F1, 0x00FB, 0x0101, 0x0107, 0x010D, 0x010F, 0x0115, 0x0119, 0x011B, 0x0125, 0x0133, 0x0137, 0x0139, 0x013D, 0x014B, 0x0151, 0x015B, 0x015D, 0x0161, 0x0167, 0x016F, 0x0175, 0x017B, 0x017F, 0x0185, 0x018D, 0x0191, 0x0199, 0x01A3, 0x01A5, 0x01AF, 0x01B1, 0x01B7, 0x01BB, 0x01C1, 0x01C9, 0x01CD, 0x01CF, 0x01D3, 0x01DF, 0x01E7, 0x01EB, 0x01F3, 0x01F7, 0x01FD, 0x0209, 0x020B, 0x021D, 0x0223, 0x022D, 0x0233, 0x0239, 0x023B, 0x0241, 0x024B, 0x0251, 0x0257, 0x0259, 0x025F, 0x0265, 0x0269, 0x026B, 0x0277, 0x0281, 0x0283, 0x0287, 0x028D, 0x0293, 0x0295, 0x02A1, 0x02A5, 0x02AB, 0x02B3, 0x02BD, 0x02C5, 0x02CF, 0x02D7, 0x02DD, 0x02E3, 0x02E7, 0x02EF, 0x02F5, 0x02F9, 0x0301, 0x0305, 0x0313, 0x031D, 0x0329, 0x032B, 0x0335, 0x0337, 0x033B, 0x033D, 0x0347, 0x0355, 0x0359, 0x035B, 0x035F, 0x036D, 0x0371, 0x0373, 0x0377, 0x038B, 0x038F, 0x0397, 0x03A1, 0x03A9, 0x03AD, 0x03B3, 0x03B9, 0x03C7, 0x03CB, 0x03D1, 0x03D7, 0x03DF, 0x03E5, 0x03F1, 0x03F5, 0x03FB, 0x03FD, 0x0407, 0x0409, 0x040F, 0x0419, 0x041B, 0x0425, 0x0427, 0x042D, 0x043F, 0x0443, 0x0445, 0x0449, 0x044F, 0x0455, 0x045D, 0x0463, 0x0469, 0x047F, 0x0481, 0x048B, 0x0493, 0x049D, 0x04A3, 0x04A9, 0x04B1, 0x04BD, 0x04C1, 0x04C7, 0x04CD, 0x04CF, 0x04D5, 0x04E1, 0x04EB, 0x04FD, 0x04FF, 0x0503, 0x0509, 0x050B, 0x0511, 0x0515, 0x0517, 0x051B, 0x0527, 0x0529, 0x052F, 0x0551, 0x0557, 0x055D, 0x0565, 0x0577, 0x0581, 0x058F, 0x0593, 0x0595, 0x0599, 0x059F, 0x05A7, 0x05AB, 0x05AD, 0x05B3, 0x05BF, 0x05C9, 0x05CB, 0x05CF, 0x05D1, 0x05D5, 0x05DB, 0x05E7, 0x05F3, 0x05FB, 0x0607, 0x060D, 0x0611, 0x0617, 0x061F, 0x0623, 0x062B, 0x062F, 0x063D, 0x0641, 0x0647, 0x0649, 0x064D, 0x0653 #endif }; #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_prime_tab.c */ /* Start: bn_reverse.c */ #include <tommath.h> #ifdef BN_REVERSE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* reverse an array, used for radix code */ void bn_reverse (unsigned char *s, int len) { int ix, iy; unsigned char t; ix = 0; iy = len - 1; while (ix < iy) { t = s[ix]; s[ix] = s[iy]; s[iy] = t; ++ix; --iy; } } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_reverse.c */ /* Start: bn_s_mp_add.c */ #include <tommath.h> #ifdef BN_S_MP_ADD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* low level addition, based on HAC pp.594, Algorithm 14.7 */ int s_mp_add (mp_int * a, mp_int * b, mp_int * c) { mp_int *x; int olduse, res, min, max; /* find sizes, we let |a| <= |b| which means we have to sort * them. "x" will point to the input with the most digits */ if (a->used > b->used) { min = b->used; max = a->used; x = a; } else { min = a->used; max = b->used; x = b; } /* init result */ if (c->alloc < max + 1) { if ((res = mp_grow (c, max + 1)) != MP_OKAY) { return res; } } /* get old used digit count and set new one */ olduse = c->used; c->used = max + 1; { register mp_digit u, *tmpa, *tmpb, *tmpc; register int i; /* alias for digit pointers */ /* first input */ tmpa = a->dp; /* second input */ tmpb = b->dp; /* destination */ tmpc = c->dp; /* zero the carry */ u = 0; for (i = 0; i < min; i++) { /* Compute the sum at one digit, T[i] = A[i] + B[i] + U */ *tmpc = *tmpa++ + *tmpb++ + u; /* U = carry bit of T[i] */ u = *tmpc >> ((mp_digit)DIGIT_BIT); /* take away carry bit from T[i] */ *tmpc++ &= MP_MASK; } /* now copy higher words if any, that is in A+B * if A or B has more digits add those in */ if (min != max) { for (; i < max; i++) { /* T[i] = X[i] + U */ *tmpc = x->dp[i] + u; /* U = carry bit of T[i] */ u = *tmpc >> ((mp_digit)DIGIT_BIT); /* take away carry bit from T[i] */ *tmpc++ &= MP_MASK; } } /* add carry */ *tmpc++ = u; /* clear digits above oldused */ for (i = c->used; i < olduse; i++) { *tmpc++ = 0; } } mp_clamp (c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_s_mp_add.c */ /* Start: bn_s_mp_exptmod.c */ #include <tommath.h> #ifdef BN_S_MP_EXPTMOD_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ #ifdef MP_LOW_MEM #define TAB_SIZE 32 #else #define TAB_SIZE 256 #endif int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int redmode) { mp_int M[TAB_SIZE], res, mu; mp_digit buf; int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; int (*redux)(mp_int*,mp_int*,mp_int*); /* find window size */ x = mp_count_bits (X); if (x <= 7) { winsize = 2; } else if (x <= 36) { winsize = 3; } else if (x <= 140) { winsize = 4; } else if (x <= 450) { winsize = 5; } else if (x <= 1303) { winsize = 6; } else if (x <= 3529) { winsize = 7; } else { winsize = 8; } #ifdef MP_LOW_MEM if (winsize > 5) { winsize = 5; } #endif /* init M array */ /* init first cell */ if ((err = mp_init(&M[1])) != MP_OKAY) { return err; } /* now init the second half of the array */ for (x = 1<<(winsize-1); x < (1 << winsize); x++) { if ((err = mp_init(&M[x])) != MP_OKAY) { for (y = 1<<(winsize-1); y < x; y++) { mp_clear (&M[y]); } mp_clear(&M[1]); return err; } } /* create mu, used for Barrett reduction */ if ((err = mp_init (&mu)) != MP_OKAY) { goto LBL_M; } if (redmode == 0) { if ((err = mp_reduce_setup (&mu, P)) != MP_OKAY) { goto LBL_MU; } redux = mp_reduce; } else { if ((err = mp_reduce_2k_setup_l (P, &mu)) != MP_OKAY) { goto LBL_MU; } redux = mp_reduce_2k_l; } /* create M table * * The M table contains powers of the base, * e.g. M[x] = G**x mod P * * The first half of the table is not * computed though accept for M[0] and M[1] */ if ((err = mp_mod (G, P, &M[1])) != MP_OKAY) { goto LBL_MU; } /* compute the value at M[1<<(winsize-1)] by squaring * M[1] (winsize-1) times */ if ((err = mp_copy (&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) { goto LBL_MU; } for (x = 0; x < (winsize - 1); x++) { /* square it */ if ((err = mp_sqr (&M[1 << (winsize - 1)], &M[1 << (winsize - 1)])) != MP_OKAY) { goto LBL_MU; } /* reduce modulo P */ if ((err = redux (&M[1 << (winsize - 1)], P, &mu)) != MP_OKAY) { goto LBL_MU; } } /* create upper table, that is M[x] = M[x-1] * M[1] (mod P) * for x = (2**(winsize - 1) + 1) to (2**winsize - 1) */ for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) { if ((err = mp_mul (&M[x - 1], &M[1], &M[x])) != MP_OKAY) { goto LBL_MU; } if ((err = redux (&M[x], P, &mu)) != MP_OKAY) { goto LBL_MU; } } /* setup result */ if ((err = mp_init (&res)) != MP_OKAY) { goto LBL_MU; } mp_set (&res, 1); /* set initial mode and bit cnt */ mode = 0; bitcnt = 1; buf = 0; digidx = X->used - 1; bitcpy = 0; bitbuf = 0; for (;;) { /* grab next digit as required */ if (--bitcnt == 0) { /* if digidx == -1 we are out of digits */ if (digidx == -1) { break; } /* read next digit and reset the bitcnt */ buf = X->dp[digidx--]; bitcnt = (int) DIGIT_BIT; } /* grab the next msb from the exponent */ y = (buf >> (mp_digit)(DIGIT_BIT - 1)) & 1; buf <<= (mp_digit)1; /* if the bit is zero and mode == 0 then we ignore it * These represent the leading zero bits before the first 1 bit * in the exponent. Technically this opt is not required but it * does lower the # of trivial squaring/reductions used */ if (mode == 0 && y == 0) { continue; } /* if the bit is zero and mode == 1 then we square */ if (mode == 1 && y == 0) { if ((err = mp_sqr (&res, &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, &mu)) != MP_OKAY) { goto LBL_RES; } continue; } /* else we add it to the window */ bitbuf |= (y << (winsize - ++bitcpy)); mode = 2; if (bitcpy == winsize) { /* ok window is filled so square as required and multiply */ /* square first */ for (x = 0; x < winsize; x++) { if ((err = mp_sqr (&res, &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, &mu)) != MP_OKAY) { goto LBL_RES; } } /* then multiply */ if ((err = mp_mul (&res, &M[bitbuf], &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, &mu)) != MP_OKAY) { goto LBL_RES; } /* empty window and reset */ bitcpy = 0; bitbuf = 0; mode = 1; } } /* if bits remain then square/multiply */ if (mode == 2 && bitcpy > 0) { /* square then multiply if the bit is set */ for (x = 0; x < bitcpy; x++) { if ((err = mp_sqr (&res, &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, &mu)) != MP_OKAY) { goto LBL_RES; } bitbuf <<= 1; if ((bitbuf & (1 << winsize)) != 0) { /* then multiply */ if ((err = mp_mul (&res, &M[1], &res)) != MP_OKAY) { goto LBL_RES; } if ((err = redux (&res, P, &mu)) != MP_OKAY) { goto LBL_RES; } } } } mp_exch (&res, Y); err = MP_OKAY; LBL_RES:mp_clear (&res); LBL_MU:mp_clear (&mu); LBL_M: mp_clear(&M[1]); for (x = 1<<(winsize-1); x < (1 << winsize); x++) { mp_clear (&M[x]); } return err; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_s_mp_exptmod.c */ /* Start: bn_s_mp_mul_digs.c */ #include <tommath.h> #ifdef BN_S_MP_MUL_DIGS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* multiplies |a| * |b| and only computes upto digs digits of result * HAC pp. 595, Algorithm 14.12 Modified so you can control how * many digits of output are created. */ int s_mp_mul_digs (mp_int * a, mp_int * b, mp_int * c, int digs) { mp_int t; int res, pa, pb, ix, iy; mp_digit u; mp_word r; mp_digit tmpx, *tmpt, *tmpy; /* can we use the fast multiplier? */ if (((digs) < MP_WARRAY) && MIN (a->used, b->used) < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { return fast_s_mp_mul_digs (a, b, c, digs); } if ((res = mp_init_size (&t, digs)) != MP_OKAY) { return res; } t.used = digs; /* compute the digits of the product directly */ pa = a->used; for (ix = 0; ix < pa; ix++) { /* set the carry to zero */ u = 0; /* limit ourselves to making digs digits of output */ pb = MIN (b->used, digs - ix); /* setup some aliases */ /* copy of the digit from a used within the nested loop */ tmpx = a->dp[ix]; /* an alias for the destination shifted ix places */ tmpt = t.dp + ix; /* an alias for the digits of b */ tmpy = b->dp; /* compute the columns of the output and propagate the carry */ for (iy = 0; iy < pb; iy++) { /* compute the column as a mp_word */ r = ((mp_word)*tmpt) + ((mp_word)tmpx) * ((mp_word)*tmpy++) + ((mp_word) u); /* the new column is the lower part of the result */ *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); /* get the carry word from the result */ u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); } /* set carry if it is placed below digs */ if (ix + iy < digs) { *tmpt = u; } } mp_clamp (&t); mp_exch (&t, c); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_s_mp_mul_digs.c */ /* Start: bn_s_mp_mul_high_digs.c */ #include <tommath.h> #ifdef BN_S_MP_MUL_HIGH_DIGS_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* multiplies |a| * |b| and does not compute the lower digs digits * [meant to get the higher part of the product] */ int s_mp_mul_high_digs (mp_int * a, mp_int * b, mp_int * c, int digs) { mp_int t; int res, pa, pb, ix, iy; mp_digit u; mp_word r; mp_digit tmpx, *tmpt, *tmpy; /* can we use the fast multiplier? */ #ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C if (((a->used + b->used + 1) < MP_WARRAY) && MIN (a->used, b->used) < (1 << ((CHAR_BIT * sizeof (mp_word)) - (2 * DIGIT_BIT)))) { return fast_s_mp_mul_high_digs (a, b, c, digs); } #endif if ((res = mp_init_size (&t, a->used + b->used + 1)) != MP_OKAY) { return res; } t.used = a->used + b->used + 1; pa = a->used; pb = b->used; for (ix = 0; ix < pa; ix++) { /* clear the carry */ u = 0; /* left hand side of A[ix] * B[iy] */ tmpx = a->dp[ix]; /* alias to the address of where the digits will be stored */ tmpt = &(t.dp[digs]); /* alias for where to read the right hand side from */ tmpy = b->dp + (digs - ix); for (iy = digs - ix; iy < pb; iy++) { /* calculate the double precision result */ r = ((mp_word)*tmpt) + ((mp_word)tmpx) * ((mp_word)*tmpy++) + ((mp_word) u); /* get the lower part */ *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); /* carry the carry */ u = (mp_digit) (r >> ((mp_word) DIGIT_BIT)); } *tmpt = u; } mp_clamp (&t); mp_exch (&t, c); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_s_mp_mul_high_digs.c */ /* Start: bn_s_mp_sqr.c */ #include <tommath.h> #ifdef BN_S_MP_SQR_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* low level squaring, b = a*a, HAC pp.596-597, Algorithm 14.16 */ int s_mp_sqr (mp_int * a, mp_int * b) { mp_int t; int res, ix, iy, pa; mp_word r; mp_digit u, tmpx, *tmpt; pa = a->used; if ((res = mp_init_size (&t, 2*pa + 1)) != MP_OKAY) { return res; } /* default used is maximum possible size */ t.used = 2*pa + 1; for (ix = 0; ix < pa; ix++) { /* first calculate the digit at 2*ix */ /* calculate double precision result */ r = ((mp_word) t.dp[2*ix]) + ((mp_word)a->dp[ix])*((mp_word)a->dp[ix]); /* store lower part in result */ t.dp[ix+ix] = (mp_digit) (r & ((mp_word) MP_MASK)); /* get the carry */ u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); /* left hand side of A[ix] * A[iy] */ tmpx = a->dp[ix]; /* alias for where to store the results */ tmpt = t.dp + (2*ix + 1); for (iy = ix + 1; iy < pa; iy++) { /* first calculate the product */ r = ((mp_word)tmpx) * ((mp_word)a->dp[iy]); /* now calculate the double precision result, note we use * addition instead of *2 since it's easier to optimize */ r = ((mp_word) *tmpt) + r + r + ((mp_word) u); /* store lower part */ *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); /* get carry */ u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); } /* propagate upwards */ while (u != ((mp_digit) 0)) { r = ((mp_word) *tmpt) + ((mp_word) u); *tmpt++ = (mp_digit) (r & ((mp_word) MP_MASK)); u = (mp_digit)(r >> ((mp_word) DIGIT_BIT)); } } mp_clamp (&t); mp_exch (&t, b); mp_clear (&t); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_s_mp_sqr.c */ /* Start: bn_s_mp_sub.c */ #include <tommath.h> #ifdef BN_S_MP_SUB_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* low level subtraction (assumes |a| > |b|), HAC pp.595 Algorithm 14.9 */ int s_mp_sub (mp_int * a, mp_int * b, mp_int * c) { int olduse, res, min, max; /* find sizes */ min = b->used; max = a->used; /* init result */ if (c->alloc < max) { if ((res = mp_grow (c, max)) != MP_OKAY) { return res; } } olduse = c->used; c->used = max; { register mp_digit u, *tmpa, *tmpb, *tmpc; register int i; /* alias for digit pointers */ tmpa = a->dp; tmpb = b->dp; tmpc = c->dp; /* set carry to zero */ u = 0; for (i = 0; i < min; i++) { /* T[i] = A[i] - B[i] - U */ *tmpc = *tmpa++ - *tmpb++ - u; /* U = carry bit of T[i] * Note this saves performing an AND operation since * if a carry does occur it will propagate all the way to the * MSB. As a result a single shift is enough to get the carry */ u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1)); /* Clear carry from T[i] */ *tmpc++ &= MP_MASK; } /* now copy higher words if any, e.g. if A has more digits than B */ for (; i < max; i++) { /* T[i] = A[i] - U */ *tmpc = *tmpa++ - u; /* U = carry bit of T[i] */ u = *tmpc >> ((mp_digit)(CHAR_BIT * sizeof (mp_digit) - 1)); /* Clear carry from T[i] */ *tmpc++ &= MP_MASK; } /* clear digits above used (since we may not have grown result above) */ for (i = c->used; i < olduse; i++) { *tmpc++ = 0; } } mp_clamp (c); return MP_OKAY; } #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bn_s_mp_sub.c */ /* Start: bncore.c */ #include <tommath.h> #ifdef BNCORE_C /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ /* Known optimal configurations CPU /Compiler /MUL CUTOFF/SQR CUTOFF ------------------------------------------------------------- Intel P4 Northwood /GCC v3.4.1 / 88/ 128/LTM 0.32 ;-) AMD Athlon64 /GCC v3.4.4 / 80/ 120/LTM 0.35 */ int KARATSUBA_MUL_CUTOFF = 80, /* Min. number of digits before Karatsuba multiplication is used. */ KARATSUBA_SQR_CUTOFF = 120, /* Min. number of digits before Karatsuba squaring is used. */ TOOM_MUL_CUTOFF = 350, /* no optimal values of these are known yet so set em high */ TOOM_SQR_CUTOFF = 400; #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/pre_gen/mpi.c,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ /* End: bncore.c */ /* EOF */ |
Added libtommath/tombc/grammar.txt.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | program := program statement | statement | empty statement := { statement } | identifier = numexpression; | identifier[numexpression] = numexpression; | function(expressionlist); | for (identifer = numexpression; numexpression; identifier = numexpression) { statement } | while (numexpression) { statement } | if (numexpresion) { statement } elif | break; | continue; elif := else statement | empty function := abs | countbits | exptmod | jacobi | print | isprime | nextprime | issquare | readinteger | exit expressionlist := expressionlist, expression | expression // LR(1) !!!? expression := string | numexpression numexpression := cmpexpr && cmpexpr | cmpexpr \|\| cmpexpr | cmpexpr cmpexpr := boolexpr < boolexpr | boolexpr > boolexpr | boolexpr == boolexpr | boolexpr <= boolexpr | boolexpr >= boolexpr | boolexpr boolexpr := shiftexpr & shiftexpr | shiftexpr ^ shiftexpr | shiftexpr \| shiftexpr | shiftexpr shiftexpr := addsubexpr << addsubexpr | addsubexpr >> addsubexpr | addsubexpr addsubexpr := mulexpr + mulexpr | mulexpr - mulexpr | mulexpr mulexpr := expr * expr | expr / expr | expr % expr | expr expr := -nexpr | nexpr nexpr := integer | identifier | ( numexpression ) | identifier[numexpression] identifier := identifer digits | identifier alpha | alpha alpha := a ... z | A ... Z integer := hexnumber | digits hexnumber := 0xhexdigits hexdigits := hexdigits hexdigit | hexdigit hexdigit := 0 ... 9 | a ... f | A ... F digits := digits digit | digit digit := 0 ... 9 |
Added libtommath/tommath.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | /* LibTomMath, multiple-precision integer library -- Tom St Denis * * LibTomMath is a library that provides multiple-precision * integer arithmetic as well as number theoretic functionality. * * The library was designed directly after the MPI library by * Michael Fromberger but has been written from scratch with * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://math.libtomcrypt.org */ #ifndef BN_H_ #define BN_H_ #include <stdio.h> #include <string.h> #include <stdlib.h> #include <ctype.h> #include <limits.h> #include <tommath_class.h> #ifndef MIN #define MIN(x,y) ((x)<(y)?(x):(y)) #endif #ifndef MAX #define MAX(x,y) ((x)>(y)?(x):(y)) #endif #ifdef __cplusplus extern "C" { /* C++ compilers don't like assigning void * to mp_digit * */ #define OPT_CAST(x) (x *) #else /* C on the other hand doesn't care */ #define OPT_CAST(x) #endif /* detect 64-bit mode if possible */ #if defined(__x86_64__) #if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT)) #define MP_64BIT #endif #endif /* some default configurations. * * A "mp_digit" must be able to hold DIGIT_BIT + 1 bits * A "mp_word" must be able to hold 2*DIGIT_BIT + 1 bits * * At the very least a mp_digit must be able to hold 7 bits * [any size beyond that is ok provided it doesn't overflow the data type] */ #ifdef MP_8BIT typedef unsigned char mp_digit; typedef unsigned short mp_word; #elif defined(MP_16BIT) typedef unsigned short mp_digit; typedef unsigned long mp_word; #elif defined(MP_64BIT) /* for GCC only on supported platforms */ #ifndef CRYPT typedef unsigned long long ulong64; typedef signed long long long64; #endif typedef unsigned long mp_digit; typedef unsigned long mp_word __attribute__ ((mode(TI))); #define DIGIT_BIT 60 #else /* this is the default case, 28-bit digits */ /* this is to make porting into LibTomCrypt easier :-) */ #ifndef CRYPT #if defined(_MSC_VER) || defined(__BORLANDC__) typedef unsigned __int64 ulong64; typedef signed __int64 long64; #else typedef unsigned long long ulong64; typedef signed long long long64; #endif #endif typedef unsigned long mp_digit; typedef ulong64 mp_word; #ifdef MP_31BIT /* this is an extension that uses 31-bit digits */ #define DIGIT_BIT 31 #else /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ #define DIGIT_BIT 28 #define MP_28BIT #endif #endif /* define heap macros */ #ifndef CRYPT /* default to libc stuff */ #ifndef XMALLOC #define XMALLOC malloc #define XFREE free #define XREALLOC realloc #define XCALLOC calloc #else /* prototypes for our heap functions */ extern void *XMALLOC(size_t n); extern void *XREALLOC(void *p, size_t n); extern void *XCALLOC(size_t n, size_t s); extern void XFREE(void *p); #endif #endif /* otherwise the bits per digit is calculated automatically from the size of a mp_digit */ #ifndef DIGIT_BIT #define DIGIT_BIT ((int)((CHAR_BIT * sizeof(mp_digit) - 1))) /* bits per digit */ #endif #define MP_DIGIT_BIT DIGIT_BIT #define MP_MASK ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1)) #define MP_DIGIT_MAX MP_MASK /* equalities */ #define MP_LT -1 /* less than */ #define MP_EQ 0 /* equal to */ #define MP_GT 1 /* greater than */ #define MP_ZPOS 0 /* positive integer */ #define MP_NEG 1 /* negative */ #define MP_OKAY 0 /* ok result */ #define MP_MEM -2 /* out of mem */ #define MP_VAL -3 /* invalid input */ #define MP_RANGE MP_VAL #define MP_YES 1 /* yes response */ #define MP_NO 0 /* no response */ /* Primality generation flags */ #define LTM_PRIME_BBS 0x0001 /* BBS style prime */ #define LTM_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */ #define LTM_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */ typedef int mp_err; /* you'll have to tune these... */ extern int KARATSUBA_MUL_CUTOFF, KARATSUBA_SQR_CUTOFF, TOOM_MUL_CUTOFF, TOOM_SQR_CUTOFF; /* define this to use lower memory usage routines (exptmods mostly) */ /* #define MP_LOW_MEM */ /* default precision */ #ifndef MP_PREC #ifndef MP_LOW_MEM #define MP_PREC 32 /* default digits of precision */ #else #define MP_PREC 8 /* default digits of precision */ #endif #endif /* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ #define MP_WARRAY (1 << (sizeof(mp_word) * CHAR_BIT - 2 * DIGIT_BIT + 1)) /* the infamous mp_int structure */ typedef struct { int used, alloc, sign; mp_digit *dp; } mp_int; /* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */ typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); #define USED(m) ((m)->used) #define DIGIT(m,k) ((m)->dp[(k)]) #define SIGN(m) ((m)->sign) /* error code to char* string */ char *mp_error_to_string(int code); /* ---> init and deinit bignum functions <--- */ /* init a bignum */ int mp_init(mp_int *a); /* free a bignum */ void mp_clear(mp_int *a); /* init a null terminated series of arguments */ int mp_init_multi(mp_int *mp, ...); /* clear a null terminated series of arguments */ void mp_clear_multi(mp_int *mp, ...); /* exchange two ints */ void mp_exch(mp_int *a, mp_int *b); /* shrink ram required for a bignum */ int mp_shrink(mp_int *a); /* grow an int to a given size */ int mp_grow(mp_int *a, int size); /* init to a given number of digits */ int mp_init_size(mp_int *a, int size); /* ---> Basic Manipulations <--- */ #define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO) #define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO) #define mp_isodd(a) (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO) /* set to zero */ void mp_zero(mp_int *a); /* set to a digit */ void mp_set(mp_int *a, mp_digit b); /* set a 32-bit const */ int mp_set_int(mp_int *a, unsigned long b); /* get a 32-bit value */ unsigned long mp_get_int(mp_int * a); /* initialize and set a digit */ int mp_init_set (mp_int * a, mp_digit b); /* initialize and set 32-bit value */ int mp_init_set_int (mp_int * a, unsigned long b); /* copy, b = a */ int mp_copy(mp_int *a, mp_int *b); /* inits and copies, a = b */ int mp_init_copy(mp_int *a, mp_int *b); /* trim unused digits */ void mp_clamp(mp_int *a); /* ---> digit manipulation <--- */ /* right shift by "b" digits */ void mp_rshd(mp_int *a, int b); /* left shift by "b" digits */ int mp_lshd(mp_int *a, int b); /* c = a / 2**b */ int mp_div_2d(mp_int *a, int b, mp_int *c, mp_int *d); /* b = a/2 */ int mp_div_2(mp_int *a, mp_int *b); /* c = a * 2**b */ int mp_mul_2d(mp_int *a, int b, mp_int *c); /* b = a*2 */ int mp_mul_2(mp_int *a, mp_int *b); /* c = a mod 2**d */ int mp_mod_2d(mp_int *a, int b, mp_int *c); /* computes a = 2**b */ int mp_2expt(mp_int *a, int b); /* Counts the number of lsbs which are zero before the first zero bit */ int mp_cnt_lsb(mp_int *a); /* I Love Earth! */ /* makes a pseudo-random int of a given size */ int mp_rand(mp_int *a, int digits); /* ---> binary operations <--- */ /* c = a XOR b */ int mp_xor(mp_int *a, mp_int *b, mp_int *c); /* c = a OR b */ int mp_or(mp_int *a, mp_int *b, mp_int *c); /* c = a AND b */ int mp_and(mp_int *a, mp_int *b, mp_int *c); /* ---> Basic arithmetic <--- */ /* b = -a */ int mp_neg(mp_int *a, mp_int *b); /* b = |a| */ int mp_abs(mp_int *a, mp_int *b); /* compare a to b */ int mp_cmp(mp_int *a, mp_int *b); /* compare |a| to |b| */ int mp_cmp_mag(mp_int *a, mp_int *b); /* c = a + b */ int mp_add(mp_int *a, mp_int *b, mp_int *c); /* c = a - b */ int mp_sub(mp_int *a, mp_int *b, mp_int *c); /* c = a * b */ int mp_mul(mp_int *a, mp_int *b, mp_int *c); /* b = a*a */ int mp_sqr(mp_int *a, mp_int *b); /* a/b => cb + d == a */ int mp_div(mp_int *a, mp_int *b, mp_int *c, mp_int *d); /* c = a mod b, 0 <= c < b */ int mp_mod(mp_int *a, mp_int *b, mp_int *c); /* ---> single digit functions <--- */ /* compare against a single digit */ int mp_cmp_d(mp_int *a, mp_digit b); /* c = a + b */ int mp_add_d(mp_int *a, mp_digit b, mp_int *c); /* c = a - b */ int mp_sub_d(mp_int *a, mp_digit b, mp_int *c); /* c = a * b */ int mp_mul_d(mp_int *a, mp_digit b, mp_int *c); /* a/b => cb + d == a */ int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d); /* a/3 => 3c + d == a */ int mp_div_3(mp_int *a, mp_int *c, mp_digit *d); /* c = a**b */ int mp_expt_d(mp_int *a, mp_digit b, mp_int *c); /* c = a mod b, 0 <= c < b */ int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c); /* ---> number theory <--- */ /* d = a + b (mod c) */ int mp_addmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); /* d = a - b (mod c) */ int mp_submod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); /* d = a * b (mod c) */ int mp_mulmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); /* c = a * a (mod b) */ int mp_sqrmod(mp_int *a, mp_int *b, mp_int *c); /* c = 1/a (mod b) */ int mp_invmod(mp_int *a, mp_int *b, mp_int *c); /* c = (a, b) */ int mp_gcd(mp_int *a, mp_int *b, mp_int *c); /* produces value such that U1*a + U2*b = U3 */ int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3); /* c = [a, b] or (a*b)/(a, b) */ int mp_lcm(mp_int *a, mp_int *b, mp_int *c); /* finds one of the b'th root of a, such that |c|**b <= |a| * * returns error if a < 0 and b is even */ int mp_n_root(mp_int *a, mp_digit b, mp_int *c); /* special sqrt algo */ int mp_sqrt(mp_int *arg, mp_int *ret); /* is number a square? */ int mp_is_square(mp_int *arg, int *ret); /* computes the jacobi c = (a | n) (or Legendre if b is prime) */ int mp_jacobi(mp_int *a, mp_int *n, int *c); /* used to setup the Barrett reduction for a given modulus b */ int mp_reduce_setup(mp_int *a, mp_int *b); /* Barrett Reduction, computes a (mod b) with a precomputed value c * * Assumes that 0 < a <= b*b, note if 0 > a > -(b*b) then you can merely * compute the reduction as -1 * mp_reduce(mp_abs(a)) [pseudo code]. */ int mp_reduce(mp_int *a, mp_int *b, mp_int *c); /* setups the montgomery reduction */ int mp_montgomery_setup(mp_int *a, mp_digit *mp); /* computes a = B**n mod b without division or multiplication useful for * normalizing numbers in a Montgomery system. */ int mp_montgomery_calc_normalization(mp_int *a, mp_int *b); /* computes x/R == x (mod N) via Montgomery Reduction */ int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); /* returns 1 if a is a valid DR modulus */ int mp_dr_is_modulus(mp_int *a); /* sets the value of "d" required for mp_dr_reduce */ void mp_dr_setup(mp_int *a, mp_digit *d); /* reduces a modulo b using the Diminished Radix method */ int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp); /* returns true if a can be reduced with mp_reduce_2k */ int mp_reduce_is_2k(mp_int *a); /* determines k value for 2k reduction */ int mp_reduce_2k_setup(mp_int *a, mp_digit *d); /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d); /* returns true if a can be reduced with mp_reduce_2k_l */ int mp_reduce_is_2k_l(mp_int *a); /* determines k value for 2k reduction */ int mp_reduce_2k_setup_l(mp_int *a, mp_int *d); /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d); /* d = a**b (mod c) */ int mp_exptmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); /* ---> Primes <--- */ /* number of primes */ #ifdef MP_8BIT #define PRIME_SIZE 31 #else #define PRIME_SIZE 256 #endif /* table of first PRIME_SIZE primes */ extern const mp_digit ltm_prime_tab[]; /* result=1 if a is divisible by one of the first PRIME_SIZE primes */ int mp_prime_is_divisible(mp_int *a, int *result); /* performs one Fermat test of "a" using base "b". * Sets result to 0 if composite or 1 if probable prime */ int mp_prime_fermat(mp_int *a, mp_int *b, int *result); /* performs one Miller-Rabin test of "a" using base "b". * Sets result to 0 if composite or 1 if probable prime */ int mp_prime_miller_rabin(mp_int *a, mp_int *b, int *result); /* This gives [for a given bit size] the number of trials required * such that Miller-Rabin gives a prob of failure lower than 2^-96 */ int mp_prime_rabin_miller_trials(int size); /* performs t rounds of Miller-Rabin on "a" using the first * t prime bases. Also performs an initial sieve of trial * division. Determines if "a" is prime with probability * of error no more than (1/4)**t. * * Sets result to 1 if probably prime, 0 otherwise */ int mp_prime_is_prime(mp_int *a, int t, int *result); /* finds the next prime after the number "a" using "t" trials * of Miller-Rabin. * * bbs_style = 1 means the prime must be congruent to 3 mod 4 */ int mp_prime_next_prime(mp_int *a, int t, int bbs_style); /* makes a truly random prime of a given size (bytes), * call with bbs = 1 if you want it to be congruent to 3 mod 4 * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself * so it can be NULL * * The prime generated will be larger than 2^(8*size). */ #define mp_prime_random(a, t, size, bbs, cb, dat) mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?LTM_PRIME_BBS:0, cb, dat) /* makes a truly random prime of a given size (bits), * * Flags are as follows: * * LTM_PRIME_BBS - make prime congruent to 3 mod 4 * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero * LTM_PRIME_2MSB_ON - make the 2nd highest bit one * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself * so it can be NULL * */ int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat); /* ---> radix conversion <--- */ int mp_count_bits(mp_int *a); int mp_unsigned_bin_size(mp_int *a); int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c); int mp_to_unsigned_bin(mp_int *a, unsigned char *b); int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); int mp_signed_bin_size(mp_int *a); int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c); int mp_to_signed_bin(mp_int *a, unsigned char *b); int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); int mp_read_radix(mp_int *a, const char *str, int radix); int mp_toradix(mp_int *a, char *str, int radix); int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen); int mp_radix_size(mp_int *a, int radix, int *size); int mp_fread(mp_int *a, int radix, FILE *stream); int mp_fwrite(mp_int *a, int radix, FILE *stream); #define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len)) #define mp_raw_size(mp) mp_signed_bin_size(mp) #define mp_toraw(mp, str) mp_to_signed_bin((mp), (str)) #define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len)) #define mp_mag_size(mp) mp_unsigned_bin_size(mp) #define mp_tomag(mp, str) mp_to_unsigned_bin((mp), (str)) #define mp_tobinary(M, S) mp_toradix((M), (S), 2) #define mp_tooctal(M, S) mp_toradix((M), (S), 8) #define mp_todecimal(M, S) mp_toradix((M), (S), 10) #define mp_tohex(M, S) mp_toradix((M), (S), 16) /* lowlevel functions, do not call! */ int s_mp_add(mp_int *a, mp_int *b, mp_int *c); int s_mp_sub(mp_int *a, mp_int *b, mp_int *c); #define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1) int fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); int s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); int fast_s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); int s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); int fast_s_mp_sqr(mp_int *a, mp_int *b); int s_mp_sqr(mp_int *a, mp_int *b); int mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c); int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c); int mp_karatsuba_sqr(mp_int *a, mp_int *b); int mp_toom_sqr(mp_int *a, mp_int *b); int fast_mp_invmod(mp_int *a, mp_int *b, mp_int *c); int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c); int fast_mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); int mp_exptmod_fast(mp_int *G, mp_int *X, mp_int *P, mp_int *Y, int mode); int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int mode); void bn_reverse(unsigned char *s, int len); extern const char *mp_s_rmap; #ifdef __cplusplus } #endif #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/tommath.h,v $ */ /* $Revision: 1.1.1.1.2.4 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/tommath.pdf.
cannot compute difference between binary files
Added libtommath/tommath.src.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 | \documentclass[b5paper]{book} \usepackage{hyperref} \usepackage{makeidx} \usepackage{amssymb} \usepackage{color} \usepackage{alltt} \usepackage{graphicx} \usepackage{layout} \def\union{\cup} \def\intersect{\cap} \def\getsrandom{\stackrel{\rm R}{\gets}} \def\cross{\times} \def\cat{\hspace{0.5em} \| \hspace{0.5em}} \def\catn{$\|$} \def\divides{\hspace{0.3em} | \hspace{0.3em}} \def\nequiv{\not\equiv} \def\approx{\raisebox{0.2ex}{\mbox{\small $\sim$}}} \def\lcm{{\rm lcm}} \def\gcd{{\rm gcd}} \def\log{{\rm log}} \def\ord{{\rm ord}} \def\abs{{\mathit abs}} \def\rep{{\mathit rep}} \def\mod{{\mathit\ mod\ }} \renewcommand{\pmod}[1]{\ ({\rm mod\ }{#1})} \newcommand{\floor}[1]{\left\lfloor{#1}\right\rfloor} \newcommand{\ceil}[1]{\left\lceil{#1}\right\rceil} \def\Or{{\rm\ or\ }} \def\And{{\rm\ and\ }} \def\iff{\hspace{1em}\Longleftrightarrow\hspace{1em}} \def\implies{\Rightarrow} \def\undefined{{\rm ``undefined"}} \def\Proof{\vspace{1ex}\noindent {\bf Proof:}\hspace{1em}} \let\oldphi\phi \def\phi{\varphi} \def\Pr{{\rm Pr}} \newcommand{\str}[1]{{\mathbf{#1}}} \def\F{{\mathbb F}} \def\N{{\mathbb N}} \def\Z{{\mathbb Z}} \def\R{{\mathbb R}} \def\C{{\mathbb C}} \def\Q{{\mathbb Q}} \definecolor{DGray}{gray}{0.5} \newcommand{\emailaddr}[1]{\mbox{$<${#1}$>$}} \def\twiddle{\raisebox{0.3ex}{\mbox{\tiny $\sim$}}} \def\gap{\vspace{0.5ex}} \makeindex \begin{document} \frontmatter \pagestyle{empty} \title{Multi--Precision Math} \author{\mbox{ %\begin{small} \begin{tabular}{c} Tom St Denis \\ Algonquin College \\ \\ Mads Rasmussen \\ Open Communications Security \\ \\ Greg Rose \\ QUALCOMM Australia \\ \end{tabular} %\end{small} } } \maketitle This text has been placed in the public domain. This text corresponds to the v0.36 release of the LibTomMath project. \begin{alltt} Tom St Denis 111 Banning Rd Ottawa, Ontario K2L 1C3 Canada Phone: 1-613-836-3160 Email: [email protected] \end{alltt} This text is formatted to the international B5 paper size of 176mm wide by 250mm tall using the \LaTeX{} {\em book} macro package and the Perl {\em booker} package. \tableofcontents \listoffigures \chapter*{Prefaces} When I tell people about my LibTom projects and that I release them as public domain they are often puzzled. They ask why I did it and especially why I continue to work on them for free. The best I can explain it is ``Because I can.'' Which seems odd and perhaps too terse for adult conversation. I often qualify it with ``I am able, I am willing.'' which perhaps explains it better. I am the first to admit there is not anything that special with what I have done. Perhaps others can see that too and then we would have a society to be proud of. My LibTom projects are what I am doing to give back to society in the form of tools and knowledge that can help others in their endeavours. I started writing this book because it was the most logical task to further my goal of open academia. The LibTomMath source code itself was written to be easy to follow and learn from. There are times, however, where pure C source code does not explain the algorithms properly. Hence this book. The book literally starts with the foundation of the library and works itself outwards to the more complicated algorithms. The use of both pseudo--code and verbatim source code provides a duality of ``theory'' and ``practice'' that the computer science students of the world shall appreciate. I never deviate too far from relatively straightforward algebra and I hope that this book can be a valuable learning asset. This book and indeed much of the LibTom projects would not exist in their current form if it was not for a plethora of kind people donating their time, resources and kind words to help support my work. Writing a text of significant length (along with the source code) is a tiresome and lengthy process. Currently the LibTom project is four years old, comprises of literally thousands of users and over 100,000 lines of source code, TeX and other material. People like Mads and Greg were there at the beginning to encourage me to work well. It is amazing how timely validation from others can boost morale to continue the project. Definitely my parents were there for me by providing room and board during the many months of work in 2003. To my many friends whom I have met through the years I thank you for the good times and the words of encouragement. I hope I honour your kind gestures with this project. Open Source. Open Academia. Open Minds. \begin{flushright} Tom St Denis \end{flushright} \newpage I found the opportunity to work with Tom appealing for several reasons, not only could I broaden my own horizons, but also contribute to educate others facing the problem of having to handle big number mathematical calculations. This book is Tom's child and he has been caring and fostering the project ever since the beginning with a clear mind of how he wanted the project to turn out. I have helped by proofreading the text and we have had several discussions about the layout and language used. I hold a masters degree in cryptography from the University of Southern Denmark and have always been interested in the practical aspects of cryptography. Having worked in the security consultancy business for several years in S\~{a}o Paulo, Brazil, I have been in touch with a great deal of work in which multiple precision mathematics was needed. Understanding the possibilities for speeding up multiple precision calculations is often very important since we deal with outdated machine architecture where modular reductions, for example, become painfully slow. This text is for people who stop and wonder when first examining algorithms such as RSA for the first time and asks themselves, ``You tell me this is only secure for large numbers, fine; but how do you implement these numbers?'' \begin{flushright} Mads Rasmussen S\~{a}o Paulo - SP Brazil \end{flushright} \newpage It's all because I broke my leg. That just happened to be at about the same time that Tom asked for someone to review the section of the book about Karatsuba multiplication. I was laid up, alone and immobile, and thought ``Why not?'' I vaguely knew what Karatsuba multiplication was, but not really, so I thought I could help, learn, and stop myself from watching daytime cable TV, all at once. At the time of writing this, I've still not met Tom or Mads in meatspace. I've been following Tom's progress since his first splash on the sci.crypt Usenet news group. I watched him go from a clueless newbie, to the cryptographic equivalent of a reformed smoker, to a real contributor to the field, over a period of about two years. I've been impressed with his obvious intelligence, and astounded by his productivity. Of course, he's young enough to be my own child, so he doesn't have my problems with staying awake. When I reviewed that single section of the book, in its very earliest form, I was very pleasantly surprised. So I decided to collaborate more fully, and at least review all of it, and perhaps write some bits too. There's still a long way to go with it, and I have watched a number of close friends go through the mill of publication, so I think that the way to go is longer than Tom thinks it is. Nevertheless, it's a good effort, and I'm pleased to be involved with it. \begin{flushright} Greg Rose, Sydney, Australia, June 2003. \end{flushright} \mainmatter \pagestyle{headings} \chapter{Introduction} \section{Multiple Precision Arithmetic} \subsection{What is Multiple Precision Arithmetic?} When we think of long-hand arithmetic such as addition or multiplication we rarely consider the fact that we instinctively raise or lower the precision of the numbers we are dealing with. For example, in decimal we almost immediate can reason that $7$ times $6$ is $42$. However, $42$ has two digits of precision as opposed to one digit we started with. Further multiplications of say $3$ result in a larger precision result $126$. In these few examples we have multiple precisions for the numbers we are working with. Despite the various levels of precision a single subset\footnote{With the occasional optimization.} of algorithms can be designed to accomodate them. By way of comparison a fixed or single precision operation would lose precision on various operations. For example, in the decimal system with fixed precision $6 \cdot 7 = 2$. Essentially at the heart of computer based multiple precision arithmetic are the same long-hand algorithms taught in schools to manually add, subtract, multiply and divide. \subsection{The Need for Multiple Precision Arithmetic} The most prevalent need for multiple precision arithmetic, often referred to as ``bignum'' math, is within the implementation of public-key cryptography algorithms. Algorithms such as RSA \cite{RSAREF} and Diffie-Hellman \cite{DHREF} require integers of significant magnitude to resist known cryptanalytic attacks. For example, at the time of this writing a typical RSA modulus would be at least greater than $10^{309}$. However, modern programming languages such as ISO C \cite{ISOC} and Java \cite{JAVA} only provide instrinsic support for integers which are relatively small and single precision. \begin{figure}[!here] \begin{center} \begin{tabular}{|r|c|} \hline \textbf{Data Type} & \textbf{Range} \\ \hline char & $-128 \ldots 127$ \\ \hline short & $-32768 \ldots 32767$ \\ \hline long & $-2147483648 \ldots 2147483647$ \\ \hline long long & $-9223372036854775808 \ldots 9223372036854775807$ \\ \hline \end{tabular} \end{center} \caption{Typical Data Types for the C Programming Language} \label{fig:ISOC} \end{figure} The largest data type guaranteed to be provided by the ISO C programming language\footnote{As per the ISO C standard. However, each compiler vendor is allowed to augment the precision as they see fit.} can only represent values up to $10^{19}$ as shown in figure \ref{fig:ISOC}. On its own the C language is insufficient to accomodate the magnitude required for the problem at hand. An RSA modulus of magnitude $10^{19}$ could be trivially factored\footnote{A Pollard-Rho factoring would take only $2^{16}$ time.} on the average desktop computer, rendering any protocol based on the algorithm insecure. Multiple precision algorithms solve this very problem by extending the range of representable integers while using single precision data types. Most advancements in fast multiple precision arithmetic stem from the need for faster and more efficient cryptographic primitives. Faster modular reduction and exponentiation algorithms such as Barrett's algorithm, which have appeared in various cryptographic journals, can render algorithms such as RSA and Diffie-Hellman more efficient. In fact, several major companies such as RSA Security, Certicom and Entrust have built entire product lines on the implementation and deployment of efficient algorithms. However, cryptography is not the only field of study that can benefit from fast multiple precision integer routines. Another auxiliary use of multiple precision integers is high precision floating point data types. The basic IEEE \cite{IEEE} standard floating point type is made up of an integer mantissa $q$, an exponent $e$ and a sign bit $s$. Numbers are given in the form $n = q \cdot b^e \cdot -1^s$ where $b = 2$ is the most common base for IEEE. Since IEEE floating point is meant to be implemented in hardware the precision of the mantissa is often fairly small (\textit{23, 48 and 64 bits}). The mantissa is merely an integer and a multiple precision integer could be used to create a mantissa of much larger precision than hardware alone can efficiently support. This approach could be useful where scientific applications must minimize the total output error over long calculations. Yet another use for large integers is within arithmetic on polynomials of large characteristic (i.e. $GF(p)[x]$ for large $p$). In fact the library discussed within this text has already been used to form a polynomial basis library\footnote{See \url{http://poly.libtomcrypt.org} for more details.}. \subsection{Benefits of Multiple Precision Arithmetic} \index{precision} The benefit of multiple precision representations over single or fixed precision representations is that no precision is lost while representing the result of an operation which requires excess precision. For example, the product of two $n$-bit integers requires at least $2n$ bits of precision to be represented faithfully. A multiple precision algorithm would augment the precision of the destination to accomodate the result while a single precision system would truncate excess bits to maintain a fixed level of precision. It is possible to implement algorithms which require large integers with fixed precision algorithms. For example, elliptic curve cryptography (\textit{ECC}) is often implemented on smartcards by fixing the precision of the integers to the maximum size the system will ever need. Such an approach can lead to vastly simpler algorithms which can accomodate the integers required even if the host platform cannot natively accomodate them\footnote{For example, the average smartcard processor has an 8 bit accumulator.}. However, as efficient as such an approach may be, the resulting source code is not normally very flexible. It cannot, at runtime, accomodate inputs of higher magnitude than the designer anticipated. Multiple precision algorithms have the most overhead of any style of arithmetic. For the the most part the overhead can be kept to a minimum with careful planning, but overall, it is not well suited for most memory starved platforms. However, multiple precision algorithms do offer the most flexibility in terms of the magnitude of the inputs. That is, the same algorithms based on multiple precision integers can accomodate any reasonable size input without the designer's explicit forethought. This leads to lower cost of ownership for the code as it only has to be written and tested once. \section{Purpose of This Text} The purpose of this text is to instruct the reader regarding how to implement efficient multiple precision algorithms. That is to not only explain a limited subset of the core theory behind the algorithms but also the various ``house keeping'' elements that are neglected by authors of other texts on the subject. Several well reknowned texts \cite{TAOCPV2,HAC} give considerably detailed explanations of the theoretical aspects of algorithms and often very little information regarding the practical implementation aspects. In most cases how an algorithm is explained and how it is actually implemented are two very different concepts. For example, the Handbook of Applied Cryptography (\textit{HAC}), algorithm 14.7 on page 594, gives a relatively simple algorithm for performing multiple precision integer addition. However, the description lacks any discussion concerning the fact that the two integer inputs may be of differing magnitudes. As a result the implementation is not as simple as the text would lead people to believe. Similarly the division routine (\textit{algorithm 14.20, pp. 598}) does not discuss how to handle sign or handle the dividend's decreasing magnitude in the main loop (\textit{step \#3}). Both texts also do not discuss several key optimal algorithms required such as ``Comba'' and Karatsuba multipliers and fast modular inversion, which we consider practical oversights. These optimal algorithms are vital to achieve any form of useful performance in non-trivial applications. To solve this problem the focus of this text is on the practical aspects of implementing a multiple precision integer package. As a case study the ``LibTomMath''\footnote{Available at \url{http://math.libtomcrypt.org}} package is used to demonstrate algorithms with real implementations\footnote{In the ISO C programming language.} that have been field tested and work very well. The LibTomMath library is freely available on the Internet for all uses and this text discusses a very large portion of the inner workings of the library. The algorithms that are presented will always include at least one ``pseudo-code'' description followed by the actual C source code that implements the algorithm. The pseudo-code can be used to implement the same algorithm in other programming languages as the reader sees fit. This text shall also serve as a walkthrough of the creation of multiple precision algorithms from scratch. Showing the reader how the algorithms fit together as well as where to start on various taskings. \section{Discussion and Notation} \subsection{Notation} A multiple precision integer of $n$-digits shall be denoted as $x = (x_{n-1}, \ldots, x_1, x_0)_{ \beta }$ and represent the integer $x \equiv \sum_{i=0}^{n-1} x_i\beta^i$. The elements of the array $x$ are said to be the radix $\beta$ digits of the integer. For example, $x = (1,2,3)_{10}$ would represent the integer $1\cdot 10^2 + 2\cdot10^1 + 3\cdot10^0 = 123$. \index{mp\_int} The term ``mp\_int'' shall refer to a composite structure which contains the digits of the integer it represents, as well as auxilary data required to manipulate the data. These additional members are discussed further in section \ref{sec:MPINT}. For the purposes of this text a ``multiple precision integer'' and an ``mp\_int'' are assumed to be synonymous. When an algorithm is specified to accept an mp\_int variable it is assumed the various auxliary data members are present as well. An expression of the type \textit{variablename.item} implies that it should evaluate to the member named ``item'' of the variable. For example, a string of characters may have a member ``length'' which would evaluate to the number of characters in the string. If the string $a$ equals ``hello'' then it follows that $a.length = 5$. For certain discussions more generic algorithms are presented to help the reader understand the final algorithm used to solve a given problem. When an algorithm is described as accepting an integer input it is assumed the input is a plain integer with no additional multiple-precision members. That is, algorithms that use integers as opposed to mp\_ints as inputs do not concern themselves with the housekeeping operations required such as memory management. These algorithms will be used to establish the relevant theory which will subsequently be used to describe a multiple precision algorithm to solve the same problem. \subsection{Precision Notation} The variable $\beta$ represents the radix of a single digit of a multiple precision integer and must be of the form $q^p$ for $q, p \in \Z^+$. A single precision variable must be able to represent integers in the range $0 \le x < q \beta$ while a double precision variable must be able to represent integers in the range $0 \le x < q \beta^2$. The extra radix-$q$ factor allows additions and subtractions to proceed without truncation of the carry. Since all modern computers are binary, it is assumed that $q$ is two. \index{mp\_digit} \index{mp\_word} Within the source code that will be presented for each algorithm, the data type \textbf{mp\_digit} will represent a single precision integer type, while, the data type \textbf{mp\_word} will represent a double precision integer type. In several algorithms (notably the Comba routines) temporary results will be stored in arrays of double precision mp\_words. For the purposes of this text $x_j$ will refer to the $j$'th digit of a single precision array and $\hat x_j$ will refer to the $j$'th digit of a double precision array. Whenever an expression is to be assigned to a double precision variable it is assumed that all single precision variables are promoted to double precision during the evaluation. Expressions that are assigned to a single precision variable are truncated to fit within the precision of a single precision data type. For example, if $\beta = 10^2$ a single precision data type may represent a value in the range $0 \le x < 10^3$, while a double precision data type may represent a value in the range $0 \le x < 10^5$. Let $a = 23$ and $b = 49$ represent two single precision variables. The single precision product shall be written as $c \leftarrow a \cdot b$ while the double precision product shall be written as $\hat c \leftarrow a \cdot b$. In this particular case, $\hat c = 1127$ and $c = 127$. The most significant digit of the product would not fit in a single precision data type and as a result $c \ne \hat c$. \subsection{Algorithm Inputs and Outputs} Within the algorithm descriptions all variables are assumed to be scalars of either single or double precision as indicated. The only exception to this rule is when variables have been indicated to be of type mp\_int. This distinction is important as scalars are often used as array indicies and various other counters. \subsection{Mathematical Expressions} The $\lfloor \mbox{ } \rfloor$ brackets imply an expression truncated to an integer not greater than the expression itself. For example, $\lfloor 5.7 \rfloor = 5$. Similarly the $\lceil \mbox{ } \rceil$ brackets imply an expression rounded to an integer not less than the expression itself. For example, $\lceil 5.1 \rceil = 6$. Typically when the $/$ division symbol is used the intention is to perform an integer division with truncation. For example, $5/2 = 2$ which will often be written as $\lfloor 5/2 \rfloor = 2$ for clarity. When an expression is written as a fraction a real value division is implied, for example ${5 \over 2} = 2.5$. The norm of a multiple precision integer, for example $\vert \vert x \vert \vert$, will be used to represent the number of digits in the representation of the integer. For example, $\vert \vert 123 \vert \vert = 3$ and $\vert \vert 79452 \vert \vert = 5$. \subsection{Work Effort} \index{big-Oh} To measure the efficiency of the specified algorithms, a modified big-Oh notation is used. In this system all single precision operations are considered to have the same cost\footnote{Except where explicitly noted.}. That is a single precision addition, multiplication and division are assumed to take the same time to complete. While this is generally not true in practice, it will simplify the discussions considerably. Some algorithms have slight advantages over others which is why some constants will not be removed in the notation. For example, a normal baseline multiplication (section \ref{sec:basemult}) requires $O(n^2)$ work while a baseline squaring (section \ref{sec:basesquare}) requires $O({{n^2 + n}\over 2})$ work. In standard big-Oh notation these would both be said to be equivalent to $O(n^2)$. However, in the context of the this text this is not the case as the magnitude of the inputs will typically be rather small. As a result small constant factors in the work effort will make an observable difference in algorithm efficiency. All of the algorithms presented in this text have a polynomial time work level. That is, of the form $O(n^k)$ for $n, k \in \Z^{+}$. This will help make useful comparisons in terms of the speed of the algorithms and how various optimizations will help pay off in the long run. \section{Exercises} Within the more advanced chapters a section will be set aside to give the reader some challenging exercises related to the discussion at hand. These exercises are not designed to be prize winning problems, but instead to be thought provoking. Wherever possible the problems are forward minded, stating problems that will be answered in subsequent chapters. The reader is encouraged to finish the exercises as they appear to get a better understanding of the subject material. That being said, the problems are designed to affirm knowledge of a particular subject matter. Students in particular are encouraged to verify they can answer the problems correctly before moving on. Similar to the exercises of \cite[pp. ix]{TAOCPV2} these exercises are given a scoring system based on the difficulty of the problem. However, unlike \cite{TAOCPV2} the problems do not get nearly as hard. The scoring of these exercises ranges from one (the easiest) to five (the hardest). The following table sumarizes the scoring system used. \begin{figure}[here] \begin{center} \begin{small} \begin{tabular}{|c|l|} \hline $\left [ 1 \right ]$ & An easy problem that should only take the reader a manner of \\ & minutes to solve. Usually does not involve much computer time \\ & to solve. \\ \hline $\left [ 2 \right ]$ & An easy problem that involves a marginal amount of computer \\ & time usage. Usually requires a program to be written to \\ & solve the problem. \\ \hline $\left [ 3 \right ]$ & A moderately hard problem that requires a non-trivial amount \\ & of work. Usually involves trivial research and development of \\ & new theory from the perspective of a student. \\ \hline $\left [ 4 \right ]$ & A moderately hard problem that involves a non-trivial amount \\ & of work and research, the solution to which will demonstrate \\ & a higher mastery of the subject matter. \\ \hline $\left [ 5 \right ]$ & A hard problem that involves concepts that are difficult for a \\ & novice to solve. Solutions to these problems will demonstrate a \\ & complete mastery of the given subject. \\ \hline \end{tabular} \end{small} \end{center} \caption{Exercise Scoring System} \end{figure} Problems at the first level are meant to be simple questions that the reader can answer quickly without programming a solution or devising new theory. These problems are quick tests to see if the material is understood. Problems at the second level are also designed to be easy but will require a program or algorithm to be implemented to arrive at the answer. These two levels are essentially entry level questions. Problems at the third level are meant to be a bit more difficult than the first two levels. The answer is often fairly obvious but arriving at an exacting solution requires some thought and skill. These problems will almost always involve devising a new algorithm or implementing a variation of another algorithm previously presented. Readers who can answer these questions will feel comfortable with the concepts behind the topic at hand. Problems at the fourth level are meant to be similar to those of the level three questions except they will require additional research to be completed. The reader will most likely not know the answer right away, nor will the text provide the exact details of the answer until a subsequent chapter. Problems at the fifth level are meant to be the hardest problems relative to all the other problems in the chapter. People who can correctly answer fifth level problems have a mastery of the subject matter at hand. Often problems will be tied together. The purpose of this is to start a chain of thought that will be discussed in future chapters. The reader is encouraged to answer the follow-up problems and try to draw the relevance of problems. \section{Introduction to LibTomMath} \subsection{What is LibTomMath?} LibTomMath is a free and open source multiple precision integer library written entirely in portable ISO C. By portable it is meant that the library does not contain any code that is computer platform dependent or otherwise problematic to use on any given platform. The library has been successfully tested under numerous operating systems including Unix\footnote{All of these trademarks belong to their respective rightful owners.}, MacOS, Windows, Linux, PalmOS and on standalone hardware such as the Gameboy Advance. The library is designed to contain enough functionality to be able to develop applications such as public key cryptosystems and still maintain a relatively small footprint. \subsection{Goals of LibTomMath} Libraries which obtain the most efficiency are rarely written in a high level programming language such as C. However, even though this library is written entirely in ISO C, considerable care has been taken to optimize the algorithm implementations within the library. Specifically the code has been written to work well with the GNU C Compiler (\textit{GCC}) on both x86 and ARM processors. Wherever possible, highly efficient algorithms, such as Karatsuba multiplication, sliding window exponentiation and Montgomery reduction have been provided to make the library more efficient. Even with the nearly optimal and specialized algorithms that have been included the Application Programing Interface (\textit{API}) has been kept as simple as possible. Often generic place holder routines will make use of specialized algorithms automatically without the developer's specific attention. One such example is the generic multiplication algorithm \textbf{mp\_mul()} which will automatically use Toom--Cook, Karatsuba, Comba or baseline multiplication based on the magnitude of the inputs and the configuration of the library. Making LibTomMath as efficient as possible is not the only goal of the LibTomMath project. Ideally the library should be source compatible with another popular library which makes it more attractive for developers to use. In this case the MPI library was used as a API template for all the basic functions. MPI was chosen because it is another library that fits in the same niche as LibTomMath. Even though LibTomMath uses MPI as the template for the function names and argument passing conventions, it has been written from scratch by Tom St Denis. The project is also meant to act as a learning tool for students, the logic being that no easy-to-follow ``bignum'' library exists which can be used to teach computer science students how to perform fast and reliable multiple precision integer arithmetic. To this end the source code has been given quite a few comments and algorithm discussion points. \section{Choice of LibTomMath} LibTomMath was chosen as the case study of this text not only because the author of both projects is one and the same but for more worthy reasons. Other libraries such as GMP \cite{GMP}, MPI \cite{MPI}, LIP \cite{LIP} and OpenSSL \cite{OPENSSL} have multiple precision integer arithmetic routines but would not be ideal for this text for reasons that will be explained in the following sub-sections. \subsection{Code Base} The LibTomMath code base is all portable ISO C source code. This means that there are no platform dependent conditional segments of code littered throughout the source. This clean and uncluttered approach to the library means that a developer can more readily discern the true intent of a given section of source code without trying to keep track of what conditional code will be used. The code base of LibTomMath is well organized. Each function is in its own separate source code file which allows the reader to find a given function very quickly. On average there are $76$ lines of code per source file which makes the source very easily to follow. By comparison MPI and LIP are single file projects making code tracing very hard. GMP has many conditional code segments which also hinder tracing. When compiled with GCC for the x86 processor and optimized for speed the entire library is approximately $100$KiB\footnote{The notation ``KiB'' means $2^{10}$ octets, similarly ``MiB'' means $2^{20}$ octets.} which is fairly small compared to GMP (over $250$KiB). LibTomMath is slightly larger than MPI (which compiles to about $50$KiB) but LibTomMath is also much faster and more complete than MPI. \subsection{API Simplicity} LibTomMath is designed after the MPI library and shares the API design. Quite often programs that use MPI will build with LibTomMath without change. The function names correlate directly to the action they perform. Almost all of the functions share the same parameter passing convention. The learning curve is fairly shallow with the API provided which is an extremely valuable benefit for the student and developer alike. The LIP library is an example of a library with an API that is awkward to work with. LIP uses function names that are often ``compressed'' to illegible short hand. LibTomMath does not share this characteristic. The GMP library also does not return error codes. Instead it uses a POSIX.1 \cite{POSIX1} signal system where errors are signaled to the host application. This happens to be the fastest approach but definitely not the most versatile. In effect a math error (i.e. invalid input, heap error, etc) can cause a program to stop functioning which is definitely undersireable in many situations. \subsection{Optimizations} While LibTomMath is certainly not the fastest library (GMP often beats LibTomMath by a factor of two) it does feature a set of optimal algorithms for tasks such as modular reduction, exponentiation, multiplication and squaring. GMP and LIP also feature such optimizations while MPI only uses baseline algorithms with no optimizations. GMP lacks a few of the additional modular reduction optimizations that LibTomMath features\footnote{At the time of this writing GMP only had Barrett and Montgomery modular reduction algorithms.}. LibTomMath is almost always an order of magnitude faster than the MPI library at computationally expensive tasks such as modular exponentiation. In the grand scheme of ``bignum'' libraries LibTomMath is faster than the average library and usually slower than the best libraries such as GMP and OpenSSL by only a small factor. \subsection{Portability and Stability} LibTomMath will build ``out of the box'' on any platform equipped with a modern version of the GNU C Compiler (\textit{GCC}). This means that without changes the library will build without configuration or setting up any variables. LIP and MPI will build ``out of the box'' as well but have numerous known bugs. Most notably the author of MPI has recently stopped working on his library and LIP has long since been discontinued. GMP requires a configuration script to run and will not build out of the box. GMP and LibTomMath are still in active development and are very stable across a variety of platforms. \subsection{Choice} LibTomMath is a relatively compact, well documented, highly optimized and portable library which seems only natural for the case study of this text. Various source files from the LibTomMath project will be included within the text. However, the reader is encouraged to download their own copy of the library to actually be able to work with the library. \chapter{Getting Started} \section{Library Basics} The trick to writing any useful library of source code is to build a solid foundation and work outwards from it. First, a problem along with allowable solution parameters should be identified and analyzed. In this particular case the inability to accomodate multiple precision integers is the problem. Futhermore, the solution must be written as portable source code that is reasonably efficient across several different computer platforms. After a foundation is formed the remainder of the library can be designed and implemented in a hierarchical fashion. That is, to implement the lowest level dependencies first and work towards the most abstract functions last. For example, before implementing a modular exponentiation algorithm one would implement a modular reduction algorithm. By building outwards from a base foundation instead of using a parallel design methodology the resulting project is highly modular. Being highly modular is a desirable property of any project as it often means the resulting product has a small footprint and updates are easy to perform. Usually when I start a project I will begin with the header files. I define the data types I think I will need and prototype the initial functions that are not dependent on other functions (within the library). After I implement these base functions I prototype more dependent functions and implement them. The process repeats until I implement all of the functions I require. For example, in the case of LibTomMath I implemented functions such as mp\_init() well before I implemented mp\_mul() and even further before I implemented mp\_exptmod(). As an example as to why this design works note that the Karatsuba and Toom-Cook multipliers were written \textit{after} the dependent function mp\_exptmod() was written. Adding the new multiplication algorithms did not require changes to the mp\_exptmod() function itself and lowered the total cost of ownership (\textit{so to speak}) and of development for new algorithms. This methodology allows new algorithms to be tested in a complete framework with relative ease. FIGU,design_process,Design Flow of the First Few Original LibTomMath Functions. Only after the majority of the functions were in place did I pursue a less hierarchical approach to auditing and optimizing the source code. For example, one day I may audit the multipliers and the next day the polynomial basis functions. It only makes sense to begin the text with the preliminary data types and support algorithms required as well. This chapter discusses the core algorithms of the library which are the dependents for every other algorithm. \section{What is a Multiple Precision Integer?} Recall that most programming languages, in particular ISO C \cite{ISOC}, only have fixed precision data types that on their own cannot be used to represent values larger than their precision will allow. The purpose of multiple precision algorithms is to use fixed precision data types to create and manipulate multiple precision integers which may represent values that are very large. As a well known analogy, school children are taught how to form numbers larger than nine by prepending more radix ten digits. In the decimal system the largest single digit value is $9$. However, by concatenating digits together larger numbers may be represented. Newly prepended digits (\textit{to the left}) are said to be in a different power of ten column. That is, the number $123$ can be described as having a $1$ in the hundreds column, $2$ in the tens column and $3$ in the ones column. Or more formally $123 = 1 \cdot 10^2 + 2 \cdot 10^1 + 3 \cdot 10^0$. Computer based multiple precision arithmetic is essentially the same concept. Larger integers are represented by adjoining fixed precision computer words with the exception that a different radix is used. What most people probably do not think about explicitly are the various other attributes that describe a multiple precision integer. For example, the integer $154_{10}$ has two immediately obvious properties. First, the integer is positive, that is the sign of this particular integer is positive as opposed to negative. Second, the integer has three digits in its representation. There is an additional property that the integer posesses that does not concern pencil-and-paper arithmetic. The third property is how many digits placeholders are available to hold the integer. The human analogy of this third property is ensuring there is enough space on the paper to write the integer. For example, if one starts writing a large number too far to the right on a piece of paper they will have to erase it and move left. Similarly, computer algorithms must maintain strict control over memory usage to ensure that the digits of an integer will not exceed the allowed boundaries. These three properties make up what is known as a multiple precision integer or mp\_int for short. \subsection{The mp\_int Structure} \label{sec:MPINT} The mp\_int structure is the ISO C based manifestation of what represents a multiple precision integer. The ISO C standard does not provide for any such data type but it does provide for making composite data types known as structures. The following is the structure definition used within LibTomMath. \index{mp\_int} \begin{figure}[here] \begin{center} \begin{small} %\begin{verbatim} \begin{tabular}{|l|} \hline typedef struct \{ \\ \hspace{3mm}int used, alloc, sign;\\ \hspace{3mm}mp\_digit *dp;\\ \} \textbf{mp\_int}; \\ \hline \end{tabular} %\end{verbatim} \end{small} \caption{The mp\_int Structure} \label{fig:mpint} \end{center} \end{figure} The mp\_int structure (fig. \ref{fig:mpint}) can be broken down as follows. \begin{enumerate} \item The \textbf{used} parameter denotes how many digits of the array \textbf{dp} contain the digits used to represent a given integer. The \textbf{used} count must be positive (or zero) and may not exceed the \textbf{alloc} count. \item The \textbf{alloc} parameter denotes how many digits are available in the array to use by functions before it has to increase in size. When the \textbf{used} count of a result would exceed the \textbf{alloc} count all of the algorithms will automatically increase the size of the array to accommodate the precision of the result. \item The pointer \textbf{dp} points to a dynamically allocated array of digits that represent the given multiple precision integer. It is padded with $(\textbf{alloc} - \textbf{used})$ zero digits. The array is maintained in a least significant digit order. As a pencil and paper analogy the array is organized such that the right most digits are stored first starting at the location indexed by zero\footnote{In C all arrays begin at zero.} in the array. For example, if \textbf{dp} contains $\lbrace a, b, c, \ldots \rbrace$ where \textbf{dp}$_0 = a$, \textbf{dp}$_1 = b$, \textbf{dp}$_2 = c$, $\ldots$ then it would represent the integer $a + b\beta + c\beta^2 + \ldots$ \index{MP\_ZPOS} \index{MP\_NEG} \item The \textbf{sign} parameter denotes the sign as either zero/positive (\textbf{MP\_ZPOS}) or negative (\textbf{MP\_NEG}). \end{enumerate} \subsubsection{Valid mp\_int Structures} Several rules are placed on the state of an mp\_int structure and are assumed to be followed for reasons of efficiency. The only exceptions are when the structure is passed to initialization functions such as mp\_init() and mp\_init\_copy(). \begin{enumerate} \item The value of \textbf{alloc} may not be less than one. That is \textbf{dp} always points to a previously allocated array of digits. \item The value of \textbf{used} may not exceed \textbf{alloc} and must be greater than or equal to zero. \item The value of \textbf{used} implies the digit at index $(used - 1)$ of the \textbf{dp} array is non-zero. That is, leading zero digits in the most significant positions must be trimmed. \begin{enumerate} \item Digits in the \textbf{dp} array at and above the \textbf{used} location must be zero. \end{enumerate} \item The value of \textbf{sign} must be \textbf{MP\_ZPOS} if \textbf{used} is zero; this represents the mp\_int value of zero. \end{enumerate} \section{Argument Passing} A convention of argument passing must be adopted early on in the development of any library. Making the function prototypes consistent will help eliminate many headaches in the future as the library grows to significant complexity. In LibTomMath the multiple precision integer functions accept parameters from left to right as pointers to mp\_int structures. That means that the source (input) operands are placed on the left and the destination (output) on the right. Consider the following examples. \begin{verbatim} mp_mul(&a, &b, &c); /* c = a * b */ mp_add(&a, &b, &a); /* a = a + b */ mp_sqr(&a, &b); /* b = a * a */ \end{verbatim} The left to right order is a fairly natural way to implement the functions since it lets the developer read aloud the functions and make sense of them. For example, the first function would read ``multiply a and b and store in c''. Certain libraries (\textit{LIP by Lenstra for instance}) accept parameters the other way around, to mimic the order of assignment expressions. That is, the destination (output) is on the left and arguments (inputs) are on the right. In truth, it is entirely a matter of preference. In the case of LibTomMath the convention from the MPI library has been adopted. Another very useful design consideration, provided for in LibTomMath, is whether to allow argument sources to also be a destination. For example, the second example (\textit{mp\_add}) adds $a$ to $b$ and stores in $a$. This is an important feature to implement since it allows the calling functions to cut down on the number of variables it must maintain. However, to implement this feature specific care has to be given to ensure the destination is not modified before the source is fully read. \section{Return Values} A well implemented application, no matter what its purpose, should trap as many runtime errors as possible and return them to the caller. By catching runtime errors a library can be guaranteed to prevent undefined behaviour. However, the end developer can still manage to cause a library to crash. For example, by passing an invalid pointer an application may fault by dereferencing memory not owned by the application. In the case of LibTomMath the only errors that are checked for are related to inappropriate inputs (division by zero for instance) and memory allocation errors. It will not check that the mp\_int passed to any function is valid nor will it check pointers for validity. Any function that can cause a runtime error will return an error code as an \textbf{int} data type with one of the following values (fig \ref{fig:errcodes}). \index{MP\_OKAY} \index{MP\_VAL} \index{MP\_MEM} \begin{figure}[here] \begin{center} \begin{tabular}{|l|l|} \hline \textbf{Value} & \textbf{Meaning} \\ \hline \textbf{MP\_OKAY} & The function was successful \\ \hline \textbf{MP\_VAL} & One of the input value(s) was invalid \\ \hline \textbf{MP\_MEM} & The function ran out of heap memory \\ \hline \end{tabular} \end{center} \caption{LibTomMath Error Codes} \label{fig:errcodes} \end{figure} When an error is detected within a function it should free any memory it allocated, often during the initialization of temporary mp\_ints, and return as soon as possible. The goal is to leave the system in the same state it was when the function was called. Error checking with this style of API is fairly simple. \begin{verbatim} int err; if ((err = mp_add(&a, &b, &c)) != MP_OKAY) { printf("Error: %s\n", mp_error_to_string(err)); exit(EXIT_FAILURE); } \end{verbatim} The GMP \cite{GMP} library uses C style \textit{signals} to flag errors which is of questionable use. Not all errors are fatal and it was not deemed ideal by the author of LibTomMath to force developers to have signal handlers for such cases. \section{Initialization and Clearing} The logical starting point when actually writing multiple precision integer functions is the initialization and clearing of the mp\_int structures. These two algorithms will be used by the majority of the higher level algorithms. Given the basic mp\_int structure an initialization routine must first allocate memory to hold the digits of the integer. Often it is optimal to allocate a sufficiently large pre-set number of digits even though the initial integer will represent zero. If only a single digit were allocated quite a few subsequent re-allocations would occur when operations are performed on the integers. There is a tradeoff between how many default digits to allocate and how many re-allocations are tolerable. Obviously allocating an excessive amount of digits initially will waste memory and become unmanageable. If the memory for the digits has been successfully allocated then the rest of the members of the structure must be initialized. Since the initial state of an mp\_int is to represent the zero integer, the allocated digits must be set to zero. The \textbf{used} count set to zero and \textbf{sign} set to \textbf{MP\_ZPOS}. \subsection{Initializing an mp\_int} An mp\_int is said to be initialized if it is set to a valid, preferably default, state such that all of the members of the structure are set to valid values. The mp\_init algorithm will perform such an action. \index{mp\_init} \begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_init}. \\ \textbf{Input}. An mp\_int $a$ \\ \textbf{Output}. Allocate memory and initialize $a$ to a known valid mp\_int state. \\ \hline \\ 1. Allocate memory for \textbf{MP\_PREC} digits. \\ 2. If the allocation failed return(\textit{MP\_MEM}) \\ 3. for $n$ from $0$ to $MP\_PREC - 1$ do \\ \hspace{3mm}3.1 $a_n \leftarrow 0$\\ 4. $a.sign \leftarrow MP\_ZPOS$\\ 5. $a.used \leftarrow 0$\\ 6. $a.alloc \leftarrow MP\_PREC$\\ 7. Return(\textit{MP\_OKAY})\\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_init} \end{figure} \textbf{Algorithm mp\_init.} The purpose of this function is to initialize an mp\_int structure so that the rest of the library can properly manipulte it. It is assumed that the input may not have had any of its members previously initialized which is certainly a valid assumption if the input resides on the stack. Before any of the members such as \textbf{sign}, \textbf{used} or \textbf{alloc} are initialized the memory for the digits is allocated. If this fails the function returns before setting any of the other members. The \textbf{MP\_PREC} name represents a constant\footnote{Defined in the ``tommath.h'' header file within LibTomMath.} used to dictate the minimum precision of newly initialized mp\_int integers. Ideally, it is at least equal to the smallest precision number you'll be working with. Allocating a block of digits at first instead of a single digit has the benefit of lowering the number of usually slow heap operations later functions will have to perform in the future. If \textbf{MP\_PREC} is set correctly the slack memory and the number of heap operations will be trivial. Once the allocation has been made the digits have to be set to zero as well as the \textbf{used}, \textbf{sign} and \textbf{alloc} members initialized. This ensures that the mp\_int will always represent the default state of zero regardless of the original condition of the input. \textbf{Remark.} This function introduces the idiosyncrasy that all iterative loops, commonly initiated with the ``for'' keyword, iterate incrementally when the ``to'' keyword is placed between two expressions. For example, ``for $a$ from $b$ to $c$ do'' means that a subsequent expression (or body of expressions) are to be evaluated upto $c - b$ times so long as $b \le c$. In each iteration the variable $a$ is substituted for a new integer that lies inclusively between $b$ and $c$. If $b > c$ occured the loop would not iterate. By contrast if the ``downto'' keyword were used in place of ``to'' the loop would iterate decrementally. EXAM,bn_mp_init.c One immediate observation of this initializtion function is that it does not return a pointer to a mp\_int structure. It is assumed that the caller has already allocated memory for the mp\_int structure, typically on the application stack. The call to mp\_init() is used only to initialize the members of the structure to a known default state. Here we see (line @23,XMALLOC@) the memory allocation is performed first. This allows us to exit cleanly and quickly if there is an error. If the allocation fails the routine will return \textbf{MP\_MEM} to the caller to indicate there was a memory error. The function XMALLOC is what actually allocates the memory. Technically XMALLOC is not a function but a macro defined in ``tommath.h``. By default, XMALLOC will evaluate to malloc() which is the C library's built--in memory allocation routine. In order to assure the mp\_int is in a known state the digits must be set to zero. On most platforms this could have been accomplished by using calloc() instead of malloc(). However, to correctly initialize a integer type to a given value in a portable fashion you have to actually assign the value. The for loop (line @28,for@) performs this required operation. After the memory has been successfully initialized the remainder of the members are initialized (lines @29,used@ through @31,sign@) to their respective default states. At this point the algorithm has succeeded and a success code is returned to the calling function. If this function returns \textbf{MP\_OKAY} it is safe to assume the mp\_int structure has been properly initialized and is safe to use with other functions within the library. \subsection{Clearing an mp\_int} When an mp\_int is no longer required by the application, the memory that has been allocated for its digits must be returned to the application's memory pool with the mp\_clear algorithm. \begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_clear}. \\ \textbf{Input}. An mp\_int $a$ \\ \textbf{Output}. The memory for $a$ shall be deallocated. \\ \hline \\ 1. If $a$ has been previously freed then return(\textit{MP\_OKAY}). \\ 2. for $n$ from 0 to $a.used - 1$ do \\ \hspace{3mm}2.1 $a_n \leftarrow 0$ \\ 3. Free the memory allocated for the digits of $a$. \\ 4. $a.used \leftarrow 0$ \\ 5. $a.alloc \leftarrow 0$ \\ 6. $a.sign \leftarrow MP\_ZPOS$ \\ 7. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_clear} \end{figure} \textbf{Algorithm mp\_clear.} This algorithm accomplishes two goals. First, it clears the digits and the other mp\_int members. This ensures that if a developer accidentally re-uses a cleared structure it is less likely to cause problems. The second goal is to free the allocated memory. The logic behind the algorithm is extended by marking cleared mp\_int structures so that subsequent calls to this algorithm will not try to free the memory multiple times. Cleared mp\_ints are detectable by having a pre-defined invalid digit pointer \textbf{dp} setting. Once an mp\_int has been cleared the mp\_int structure is no longer in a valid state for any other algorithm with the exception of algorithms mp\_init, mp\_init\_copy, mp\_init\_size and mp\_clear. EXAM,bn_mp_clear.c The algorithm only operates on the mp\_int if it hasn't been previously cleared. The if statement (line @23,a->dp != NULL@) checks to see if the \textbf{dp} member is not \textbf{NULL}. If the mp\_int is a valid mp\_int then \textbf{dp} cannot be \textbf{NULL} in which case the if statement will evaluate to true. The digits of the mp\_int are cleared by the for loop (line @25,for@) which assigns a zero to every digit. Similar to mp\_init() the digits are assigned zero instead of using block memory operations (such as memset()) since this is more portable. The digits are deallocated off the heap via the XFREE macro. Similar to XMALLOC the XFREE macro actually evaluates to a standard C library function. In this case the free() function. Since free() only deallocates the memory the pointer still has to be reset to \textbf{NULL} manually (line @33,NULL@). Now that the digits have been cleared and deallocated the other members are set to their final values (lines @34,= 0@ and @35,ZPOS@). \section{Maintenance Algorithms} The previous sections describes how to initialize and clear an mp\_int structure. To further support operations that are to be performed on mp\_int structures (such as addition and multiplication) the dependent algorithms must be able to augment the precision of an mp\_int and initialize mp\_ints with differing initial conditions. These algorithms complete the set of low level algorithms required to work with mp\_int structures in the higher level algorithms such as addition, multiplication and modular exponentiation. \subsection{Augmenting an mp\_int's Precision} When storing a value in an mp\_int structure, a sufficient number of digits must be available to accomodate the entire result of an operation without loss of precision. Quite often the size of the array given by the \textbf{alloc} member is large enough to simply increase the \textbf{used} digit count. However, when the size of the array is too small it must be re-sized appropriately to accomodate the result. The mp\_grow algorithm will provide this functionality. \newpage\begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_grow}. \\ \textbf{Input}. An mp\_int $a$ and an integer $b$. \\ \textbf{Output}. $a$ is expanded to accomodate $b$ digits. \\ \hline \\ 1. if $a.alloc \ge b$ then return(\textit{MP\_OKAY}) \\ 2. $u \leftarrow b\mbox{ (mod }MP\_PREC\mbox{)}$ \\ 3. $v \leftarrow b + 2 \cdot MP\_PREC - u$ \\ 4. Re-allocate the array of digits $a$ to size $v$ \\ 5. If the allocation failed then return(\textit{MP\_MEM}). \\ 6. for n from a.alloc to $v - 1$ do \\ \hspace{+3mm}6.1 $a_n \leftarrow 0$ \\ 7. $a.alloc \leftarrow v$ \\ 8. Return(\textit{MP\_OKAY}) \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_grow} \end{figure} \textbf{Algorithm mp\_grow.} It is ideal to prevent re-allocations from being performed if they are not required (step one). This is useful to prevent mp\_ints from growing excessively in code that erroneously calls mp\_grow. The requested digit count is padded up to next multiple of \textbf{MP\_PREC} plus an additional \textbf{MP\_PREC} (steps two and three). This helps prevent many trivial reallocations that would grow an mp\_int by trivially small values. It is assumed that the reallocation (step four) leaves the lower $a.alloc$ digits of the mp\_int intact. This is much akin to how the \textit{realloc} function from the standard C library works. Since the newly allocated digits are assumed to contain undefined values they are initially set to zero. EXAM,bn_mp_grow.c A quick optimization is to first determine if a memory re-allocation is required at all. The if statement (line @24,alloc@) checks if the \textbf{alloc} member of the mp\_int is smaller than the requested digit count. If the count is not larger than \textbf{alloc} the function skips the re-allocation part thus saving time. When a re-allocation is performed it is turned into an optimal request to save time in the future. The requested digit count is padded upwards to 2nd multiple of \textbf{MP\_PREC} larger than \textbf{alloc} (line @25, size@). The XREALLOC function is used to re-allocate the memory. As per the other functions XREALLOC is actually a macro which evaluates to realloc by default. The realloc function leaves the base of the allocation intact which means the first \textbf{alloc} digits of the mp\_int are the same as before the re-allocation. All that is left is to clear the newly allocated digits and return. Note that the re-allocation result is actually stored in a temporary pointer $tmp$. This is to allow this function to return an error with a valid pointer. Earlier releases of the library stored the result of XREALLOC into the mp\_int $a$. That would result in a memory leak if XREALLOC ever failed. \subsection{Initializing Variable Precision mp\_ints} Occasionally the number of digits required will be known in advance of an initialization, based on, for example, the size of input mp\_ints to a given algorithm. The purpose of algorithm mp\_init\_size is similar to mp\_init except that it will allocate \textit{at least} a specified number of digits. \begin{figure}[here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_init\_size}. \\ \textbf{Input}. An mp\_int $a$ and the requested number of digits $b$. \\ \textbf{Output}. $a$ is initialized to hold at least $b$ digits. \\ \hline \\ 1. $u \leftarrow b \mbox{ (mod }MP\_PREC\mbox{)}$ \\ 2. $v \leftarrow b + 2 \cdot MP\_PREC - u$ \\ 3. Allocate $v$ digits. \\ 4. for $n$ from $0$ to $v - 1$ do \\ \hspace{3mm}4.1 $a_n \leftarrow 0$ \\ 5. $a.sign \leftarrow MP\_ZPOS$\\ 6. $a.used \leftarrow 0$\\ 7. $a.alloc \leftarrow v$\\ 8. Return(\textit{MP\_OKAY})\\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_init\_size} \end{figure} \textbf{Algorithm mp\_init\_size.} This algorithm will initialize an mp\_int structure $a$ like algorithm mp\_init with the exception that the number of digits allocated can be controlled by the second input argument $b$. The input size is padded upwards so it is a multiple of \textbf{MP\_PREC} plus an additional \textbf{MP\_PREC} digits. This padding is used to prevent trivial allocations from becoming a bottleneck in the rest of the algorithms. Like algorithm mp\_init, the mp\_int structure is initialized to a default state representing the integer zero. This particular algorithm is useful if it is known ahead of time the approximate size of the input. If the approximation is correct no further memory re-allocations are required to work with the mp\_int. EXAM,bn_mp_init_size.c The number of digits $b$ requested is padded (line @22,MP_PREC@) by first augmenting it to the next multiple of \textbf{MP\_PREC} and then adding \textbf{MP\_PREC} to the result. If the memory can be successfully allocated the mp\_int is placed in a default state representing the integer zero. Otherwise, the error code \textbf{MP\_MEM} will be returned (line @27,return@). The digits are allocated and set to zero at the same time with the calloc() function (line @25,XCALLOC@). The \textbf{used} count is set to zero, the \textbf{alloc} count set to the padded digit count and the \textbf{sign} flag set to \textbf{MP\_ZPOS} to achieve a default valid mp\_int state (lines @29,used@, @30,alloc@ and @31,sign@). If the function returns succesfully then it is correct to assume that the mp\_int structure is in a valid state for the remainder of the functions to work with. \subsection{Multiple Integer Initializations and Clearings} Occasionally a function will require a series of mp\_int data types to be made available simultaneously. The purpose of algorithm mp\_init\_multi is to initialize a variable length array of mp\_int structures in a single statement. It is essentially a shortcut to multiple initializations. \newpage\begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_init\_multi}. \\ \textbf{Input}. Variable length array $V_k$ of mp\_int variables of length $k$. \\ \textbf{Output}. The array is initialized such that each mp\_int of $V_k$ is ready to use. \\ \hline \\ 1. for $n$ from 0 to $k - 1$ do \\ \hspace{+3mm}1.1. Initialize the mp\_int $V_n$ (\textit{mp\_init}) \\ \hspace{+3mm}1.2. If initialization failed then do \\ \hspace{+6mm}1.2.1. for $j$ from $0$ to $n$ do \\ \hspace{+9mm}1.2.1.1. Free the mp\_int $V_j$ (\textit{mp\_clear}) \\ \hspace{+6mm}1.2.2. Return(\textit{MP\_MEM}) \\ 2. Return(\textit{MP\_OKAY}) \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_init\_multi} \end{figure} \textbf{Algorithm mp\_init\_multi.} The algorithm will initialize the array of mp\_int variables one at a time. If a runtime error has been detected (\textit{step 1.2}) all of the previously initialized variables are cleared. The goal is an ``all or nothing'' initialization which allows for quick recovery from runtime errors. EXAM,bn_mp_init_multi.c This function intializes a variable length list of mp\_int structure pointers. However, instead of having the mp\_int structures in an actual C array they are simply passed as arguments to the function. This function makes use of the ``...'' argument syntax of the C programming language. The list is terminated with a final \textbf{NULL} argument appended on the right. The function uses the ``stdarg.h'' \textit{va} functions to step portably through the arguments to the function. A count $n$ of succesfully initialized mp\_int structures is maintained (line @47,n++@) such that if a failure does occur, the algorithm can backtrack and free the previously initialized structures (lines @27,if@ to @46,}@). \subsection{Clamping Excess Digits} When a function anticipates a result will be $n$ digits it is simpler to assume this is true within the body of the function instead of checking during the computation. For example, a multiplication of a $i$ digit number by a $j$ digit produces a result of at most $i + j$ digits. It is entirely possible that the result is $i + j - 1$ though, with no final carry into the last position. However, suppose the destination had to be first expanded (\textit{via mp\_grow}) to accomodate $i + j - 1$ digits than further expanded to accomodate the final carry. That would be a considerable waste of time since heap operations are relatively slow. The ideal solution is to always assume the result is $i + j$ and fix up the \textbf{used} count after the function terminates. This way a single heap operation (\textit{at most}) is required. However, if the result was not checked there would be an excess high order zero digit. For example, suppose the product of two integers was $x_n = (0x_{n-1}x_{n-2}...x_0)_{\beta}$. The leading zero digit will not contribute to the precision of the result. In fact, through subsequent operations more leading zero digits would accumulate to the point the size of the integer would be prohibitive. As a result even though the precision is very low the representation is excessively large. The mp\_clamp algorithm is designed to solve this very problem. It will trim high-order zeros by decrementing the \textbf{used} count until a non-zero most significant digit is found. Also in this system, zero is considered to be a positive number which means that if the \textbf{used} count is decremented to zero, the sign must be set to \textbf{MP\_ZPOS}. \begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_clamp}. \\ \textbf{Input}. An mp\_int $a$ \\ \textbf{Output}. Any excess leading zero digits of $a$ are removed \\ \hline \\ 1. while $a.used > 0$ and $a_{a.used - 1} = 0$ do \\ \hspace{+3mm}1.1 $a.used \leftarrow a.used - 1$ \\ 2. if $a.used = 0$ then do \\ \hspace{+3mm}2.1 $a.sign \leftarrow MP\_ZPOS$ \\ \hline \\ \end{tabular} \end{center} \caption{Algorithm mp\_clamp} \end{figure} \textbf{Algorithm mp\_clamp.} As can be expected this algorithm is very simple. The loop on step one is expected to iterate only once or twice at the most. For example, this will happen in cases where there is not a carry to fill the last position. Step two fixes the sign for when all of the digits are zero to ensure that the mp\_int is valid at all times. EXAM,bn_mp_clamp.c Note on line @27,while@ how to test for the \textbf{used} count is made on the left of the \&\& operator. In the C programming language the terms to \&\& are evaluated left to right with a boolean short-circuit if any condition fails. This is important since if the \textbf{used} is zero the test on the right would fetch below the array. That is obviously undesirable. The parenthesis on line @28,a->used@ is used to make sure the \textbf{used} count is decremented and not the pointer ``a''. \section*{Exercises} \begin{tabular}{cl} $\left [ 1 \right ]$ & Discuss the relevance of the \textbf{used} member of the mp\_int structure. \\ & \\ $\left [ 1 \right ]$ & Discuss the consequences of not using padding when performing allocations. \\ & \\ $\left [ 2 \right ]$ & Estimate an ideal value for \textbf{MP\_PREC} when performing 1024-bit RSA \\ & encryption when $\beta = 2^{28}$. \\ & \\ $\left [ 1 \right ]$ & Discuss the relevance of the algorithm mp\_clamp. What does it prevent? \\ & \\ $\left [ 1 \right ]$ & Give an example of when the algorithm mp\_init\_copy might be useful. \\ & \\ \end{tabular} %%% % CHAPTER FOUR %%% \chapter{Basic Operations} \section{Introduction} In the previous chapter a series of low level algorithms were established that dealt with initializing and maintaining mp\_int structures. This chapter will discuss another set of seemingly non-algebraic algorithms which will form the low level basis of the entire library. While these algorithm are relatively trivial it is important to understand how they work before proceeding since these algorithms will be used almost intrinsically in the following chapters. The algorithms in this chapter deal primarily with more ``programmer'' related tasks such as creating copies of mp\_int structures, assigning small values to mp\_int structures and comparisons of the values mp\_int structures represent. \section{Assigning Values to mp\_int Structures} \subsection{Copying an mp\_int} Assigning the value that a given mp\_int structure represents to another mp\_int structure shall be known as making a copy for the purposes of this text. The copy of the mp\_int will be a separate entity that represents the same value as the mp\_int it was copied from. The mp\_copy algorithm provides this functionality. \newpage\begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_copy}. \\ \textbf{Input}. An mp\_int $a$ and $b$. \\ \textbf{Output}. Store a copy of $a$ in $b$. \\ \hline \\ 1. If $b.alloc < a.used$ then grow $b$ to $a.used$ digits. (\textit{mp\_grow}) \\ 2. for $n$ from 0 to $a.used - 1$ do \\ \hspace{3mm}2.1 $b_{n} \leftarrow a_{n}$ \\ 3. for $n$ from $a.used$ to $b.used - 1$ do \\ \hspace{3mm}3.1 $b_{n} \leftarrow 0$ \\ 4. $b.used \leftarrow a.used$ \\ 5. $b.sign \leftarrow a.sign$ \\ 6. return(\textit{MP\_OKAY}) \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_copy} \end{figure} \textbf{Algorithm mp\_copy.} This algorithm copies the mp\_int $a$ such that upon succesful termination of the algorithm the mp\_int $b$ will represent the same integer as the mp\_int $a$. The mp\_int $b$ shall be a complete and distinct copy of the mp\_int $a$ meaing that the mp\_int $a$ can be modified and it shall not affect the value of the mp\_int $b$. If $b$ does not have enough room for the digits of $a$ it must first have its precision augmented via the mp\_grow algorithm. The digits of $a$ are copied over the digits of $b$ and any excess digits of $b$ are set to zero (step two and three). The \textbf{used} and \textbf{sign} members of $a$ are finally copied over the respective members of $b$. \textbf{Remark.} This algorithm also introduces a new idiosyncrasy that will be used throughout the rest of the text. The error return codes of other algorithms are not explicitly checked in the pseudo-code presented. For example, in step one of the mp\_copy algorithm the return of mp\_grow is not explicitly checked to ensure it succeeded. Text space is limited so it is assumed that if a algorithm fails it will clear all temporarily allocated mp\_ints and return the error code itself. However, the C code presented will demonstrate all of the error handling logic required to implement the pseudo-code. EXAM,bn_mp_copy.c Occasionally a dependent algorithm may copy an mp\_int effectively into itself such as when the input and output mp\_int structures passed to a function are one and the same. For this case it is optimal to return immediately without copying digits (line @24,a == b@). The mp\_int $b$ must have enough digits to accomodate the used digits of the mp\_int $a$. If $b.alloc$ is less than $a.used$ the algorithm mp\_grow is used to augment the precision of $b$ (lines @29,alloc@ to @33,}@). In order to simplify the inner loop that copies the digits from $a$ to $b$, two aliases $tmpa$ and $tmpb$ point directly at the digits of the mp\_ints $a$ and $b$ respectively. These aliases (lines @42,tmpa@ and @45,tmpb@) allow the compiler to access the digits without first dereferencing the mp\_int pointers and then subsequently the pointer to the digits. After the aliases are established the digits from $a$ are copied into $b$ (lines @48,for@ to @50,}@) and then the excess digits of $b$ are set to zero (lines @53,for@ to @55,}@). Both ``for'' loops make use of the pointer aliases and in fact the alias for $b$ is carried through into the second ``for'' loop to clear the excess digits. This optimization allows the alias to stay in a machine register fairly easy between the two loops. \textbf{Remarks.} The use of pointer aliases is an implementation methodology first introduced in this function that will be used considerably in other functions. Technically, a pointer alias is simply a short hand alias used to lower the number of pointer dereferencing operations required to access data. For example, a for loop may resemble \begin{alltt} for (x = 0; x < 100; x++) \{ a->num[4]->dp[x] = 0; \} \end{alltt} This could be re-written using aliases as \begin{alltt} mp_digit *tmpa; a = a->num[4]->dp; for (x = 0; x < 100; x++) \{ *a++ = 0; \} \end{alltt} In this case an alias is used to access the array of digits within an mp\_int structure directly. It may seem that a pointer alias is strictly not required as a compiler may optimize out the redundant pointer operations. However, there are two dominant reasons to use aliases. The first reason is that most compilers will not effectively optimize pointer arithmetic. For example, some optimizations may work for the Microsoft Visual C++ compiler (MSVC) and not for the GNU C Compiler (GCC). Also some optimizations may work for GCC and not MSVC. As such it is ideal to find a common ground for as many compilers as possible. Pointer aliases optimize the code considerably before the compiler even reads the source code which means the end compiled code stands a better chance of being faster. The second reason is that pointer aliases often can make an algorithm simpler to read. Consider the first ``for'' loop of the function mp\_copy() re-written to not use pointer aliases. \begin{alltt} /* copy all the digits */ for (n = 0; n < a->used; n++) \{ b->dp[n] = a->dp[n]; \} \end{alltt} Whether this code is harder to read depends strongly on the individual. However, it is quantifiably slightly more complicated as there are four variables within the statement instead of just two. \subsubsection{Nested Statements} Another commonly used technique in the source routines is that certain sections of code are nested. This is used in particular with the pointer aliases to highlight code phases. For example, a Comba multiplier (discussed in chapter six) will typically have three different phases. First the temporaries are initialized, then the columns calculated and finally the carries are propagated. In this example the middle column production phase will typically be nested as it uses temporary variables and aliases the most. The nesting also simplies the source code as variables that are nested are only valid for their scope. As a result the various temporary variables required do not propagate into other sections of code. \subsection{Creating a Clone} Another common operation is to make a local temporary copy of an mp\_int argument. To initialize an mp\_int and then copy another existing mp\_int into the newly intialized mp\_int will be known as creating a clone. This is useful within functions that need to modify an argument but do not wish to actually modify the original copy. The mp\_init\_copy algorithm has been designed to help perform this task. \begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_init\_copy}. \\ \textbf{Input}. An mp\_int $a$ and $b$\\ \textbf{Output}. $a$ is initialized to be a copy of $b$. \\ \hline \\ 1. Init $a$. (\textit{mp\_init}) \\ 2. Copy $b$ to $a$. (\textit{mp\_copy}) \\ 3. Return the status of the copy operation. \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_init\_copy} \end{figure} \textbf{Algorithm mp\_init\_copy.} This algorithm will initialize an mp\_int variable and copy another previously initialized mp\_int variable into it. As such this algorithm will perform two operations in one step. EXAM,bn_mp_init_copy.c This will initialize \textbf{a} and make it a verbatim copy of the contents of \textbf{b}. Note that \textbf{a} will have its own memory allocated which means that \textbf{b} may be cleared after the call and \textbf{a} will be left intact. \section{Zeroing an Integer} Reseting an mp\_int to the default state is a common step in many algorithms. The mp\_zero algorithm will be the algorithm used to perform this task. \begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_zero}. \\ \textbf{Input}. An mp\_int $a$ \\ \textbf{Output}. Zero the contents of $a$ \\ \hline \\ 1. $a.used \leftarrow 0$ \\ 2. $a.sign \leftarrow$ MP\_ZPOS \\ 3. for $n$ from 0 to $a.alloc - 1$ do \\ \hspace{3mm}3.1 $a_n \leftarrow 0$ \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_zero} \end{figure} \textbf{Algorithm mp\_zero.} This algorithm simply resets a mp\_int to the default state. EXAM,bn_mp_zero.c After the function is completed, all of the digits are zeroed, the \textbf{used} count is zeroed and the \textbf{sign} variable is set to \textbf{MP\_ZPOS}. \section{Sign Manipulation} \subsection{Absolute Value} With the mp\_int representation of an integer, calculating the absolute value is trivial. The mp\_abs algorithm will compute the absolute value of an mp\_int. \begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_abs}. \\ \textbf{Input}. An mp\_int $a$ \\ \textbf{Output}. Computes $b = \vert a \vert$ \\ \hline \\ 1. Copy $a$ to $b$. (\textit{mp\_copy}) \\ 2. If the copy failed return(\textit{MP\_MEM}). \\ 3. $b.sign \leftarrow MP\_ZPOS$ \\ 4. Return(\textit{MP\_OKAY}) \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_abs} \end{figure} \textbf{Algorithm mp\_abs.} This algorithm computes the absolute of an mp\_int input. First it copies $a$ over $b$. This is an example of an algorithm where the check in mp\_copy that determines if the source and destination are equal proves useful. This allows, for instance, the developer to pass the same mp\_int as the source and destination to this function without addition logic to handle it. EXAM,bn_mp_abs.c This fairly trivial algorithm first eliminates non--required duplications (line @27,a != b@) and then sets the \textbf{sign} flag to \textbf{MP\_ZPOS}. \subsection{Integer Negation} With the mp\_int representation of an integer, calculating the negation is also trivial. The mp\_neg algorithm will compute the negative of an mp\_int input. \begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_neg}. \\ \textbf{Input}. An mp\_int $a$ \\ \textbf{Output}. Computes $b = -a$ \\ \hline \\ 1. Copy $a$ to $b$. (\textit{mp\_copy}) \\ 2. If the copy failed return(\textit{MP\_MEM}). \\ 3. If $a.used = 0$ then return(\textit{MP\_OKAY}). \\ 4. If $a.sign = MP\_ZPOS$ then do \\ \hspace{3mm}4.1 $b.sign = MP\_NEG$. \\ 5. else do \\ \hspace{3mm}5.1 $b.sign = MP\_ZPOS$. \\ 6. Return(\textit{MP\_OKAY}) \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_neg} \end{figure} \textbf{Algorithm mp\_neg.} This algorithm computes the negation of an input. First it copies $a$ over $b$. If $a$ has no used digits then the algorithm returns immediately. Otherwise it flips the sign flag and stores the result in $b$. Note that if $a$ had no digits then it must be positive by definition. Had step three been omitted then the algorithm would return zero as negative. EXAM,bn_mp_neg.c Like mp\_abs() this function avoids non--required duplications (line @21,a != b@) and then sets the sign. We have to make sure that only non--zero values get a \textbf{sign} of \textbf{MP\_NEG}. If the mp\_int is zero than the \textbf{sign} is hard--coded to \textbf{MP\_ZPOS}. \section{Small Constants} \subsection{Setting Small Constants} Often a mp\_int must be set to a relatively small value such as $1$ or $2$. For these cases the mp\_set algorithm is useful. \newpage\begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_set}. \\ \textbf{Input}. An mp\_int $a$ and a digit $b$ \\ \textbf{Output}. Make $a$ equivalent to $b$ \\ \hline \\ 1. Zero $a$ (\textit{mp\_zero}). \\ 2. $a_0 \leftarrow b \mbox{ (mod }\beta\mbox{)}$ \\ 3. $a.used \leftarrow \left \lbrace \begin{array}{ll} 1 & \mbox{if }a_0 > 0 \\ 0 & \mbox{if }a_0 = 0 \end{array} \right .$ \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_set} \end{figure} \textbf{Algorithm mp\_set.} This algorithm sets a mp\_int to a small single digit value. Step number 1 ensures that the integer is reset to the default state. The single digit is set (\textit{modulo $\beta$}) and the \textbf{used} count is adjusted accordingly. EXAM,bn_mp_set.c First we zero (line @21,mp_zero@) the mp\_int to make sure that the other members are initialized for a small positive constant. mp\_zero() ensures that the \textbf{sign} is positive and the \textbf{used} count is zero. Next we set the digit and reduce it modulo $\beta$ (line @22,MP_MASK@). After this step we have to check if the resulting digit is zero or not. If it is not then we set the \textbf{used} count to one, otherwise to zero. We can quickly reduce modulo $\beta$ since it is of the form $2^k$ and a quick binary AND operation with $2^k - 1$ will perform the same operation. One important limitation of this function is that it will only set one digit. The size of a digit is not fixed, meaning source that uses this function should take that into account. Only trivially small constants can be set using this function. \subsection{Setting Large Constants} To overcome the limitations of the mp\_set algorithm the mp\_set\_int algorithm is ideal. It accepts a ``long'' data type as input and will always treat it as a 32-bit integer. \begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_set\_int}. \\ \textbf{Input}. An mp\_int $a$ and a ``long'' integer $b$ \\ \textbf{Output}. Make $a$ equivalent to $b$ \\ \hline \\ 1. Zero $a$ (\textit{mp\_zero}) \\ 2. for $n$ from 0 to 7 do \\ \hspace{3mm}2.1 $a \leftarrow a \cdot 16$ (\textit{mp\_mul2d}) \\ \hspace{3mm}2.2 $u \leftarrow \lfloor b / 2^{4(7 - n)} \rfloor \mbox{ (mod }16\mbox{)}$\\ \hspace{3mm}2.3 $a_0 \leftarrow a_0 + u$ \\ \hspace{3mm}2.4 $a.used \leftarrow a.used + 1$ \\ 3. Clamp excess used digits (\textit{mp\_clamp}) \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_set\_int} \end{figure} \textbf{Algorithm mp\_set\_int.} The algorithm performs eight iterations of a simple loop where in each iteration four bits from the source are added to the mp\_int. Step 2.1 will multiply the current result by sixteen making room for four more bits in the less significant positions. In step 2.2 the next four bits from the source are extracted and are added to the mp\_int. The \textbf{used} digit count is incremented to reflect the addition. The \textbf{used} digit counter is incremented since if any of the leading digits were zero the mp\_int would have zero digits used and the newly added four bits would be ignored. Excess zero digits are trimmed in steps 2.1 and 3 by using higher level algorithms mp\_mul2d and mp\_clamp. EXAM,bn_mp_set_int.c This function sets four bits of the number at a time to handle all practical \textbf{DIGIT\_BIT} sizes. The weird addition on line @38,a->used@ ensures that the newly added in bits are added to the number of digits. While it may not seem obvious as to why the digit counter does not grow exceedingly large it is because of the shift on line @27,mp_mul_2d@ as well as the call to mp\_clamp() on line @40,mp_clamp@. Both functions will clamp excess leading digits which keeps the number of used digits low. \section{Comparisons} \subsection{Unsigned Comparisions} Comparing a multiple precision integer is performed with the exact same algorithm used to compare two decimal numbers. For example, to compare $1,234$ to $1,264$ the digits are extracted by their positions. That is we compare $1 \cdot 10^3 + 2 \cdot 10^2 + 3 \cdot 10^1 + 4 \cdot 10^0$ to $1 \cdot 10^3 + 2 \cdot 10^2 + 6 \cdot 10^1 + 4 \cdot 10^0$ by comparing single digits at a time starting with the highest magnitude positions. If any leading digit of one integer is greater than a digit in the same position of another integer then obviously it must be greater. The first comparision routine that will be developed is the unsigned magnitude compare which will perform a comparison based on the digits of two mp\_int variables alone. It will ignore the sign of the two inputs. Such a function is useful when an absolute comparison is required or if the signs are known to agree in advance. To facilitate working with the results of the comparison functions three constants are required. \begin{figure}[here] \begin{center} \begin{tabular}{|r|l|} \hline \textbf{Constant} & \textbf{Meaning} \\ \hline \textbf{MP\_GT} & Greater Than \\ \hline \textbf{MP\_EQ} & Equal To \\ \hline \textbf{MP\_LT} & Less Than \\ \hline \end{tabular} \end{center} \caption{Comparison Return Codes} \end{figure} \begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_cmp\_mag}. \\ \textbf{Input}. Two mp\_ints $a$ and $b$. \\ \textbf{Output}. Unsigned comparison results ($a$ to the left of $b$). \\ \hline \\ 1. If $a.used > b.used$ then return(\textit{MP\_GT}) \\ 2. If $a.used < b.used$ then return(\textit{MP\_LT}) \\ 3. for n from $a.used - 1$ to 0 do \\ \hspace{+3mm}3.1 if $a_n > b_n$ then return(\textit{MP\_GT}) \\ \hspace{+3mm}3.2 if $a_n < b_n$ then return(\textit{MP\_LT}) \\ 4. Return(\textit{MP\_EQ}) \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_cmp\_mag} \end{figure} \textbf{Algorithm mp\_cmp\_mag.} By saying ``$a$ to the left of $b$'' it is meant that the comparison is with respect to $a$, that is if $a$ is greater than $b$ it will return \textbf{MP\_GT} and similar with respect to when $a = b$ and $a < b$. The first two steps compare the number of digits used in both $a$ and $b$. Obviously if the digit counts differ there would be an imaginary zero digit in the smaller number where the leading digit of the larger number is. If both have the same number of digits than the actual digits themselves must be compared starting at the leading digit. By step three both inputs must have the same number of digits so its safe to start from either $a.used - 1$ or $b.used - 1$ and count down to the zero'th digit. If after all of the digits have been compared, no difference is found, the algorithm returns \textbf{MP\_EQ}. EXAM,bn_mp_cmp_mag.c The two if statements (lines @24,if@ and @28,if@) compare the number of digits in the two inputs. These two are performed before all of the digits are compared since it is a very cheap test to perform and can potentially save considerable time. The implementation given is also not valid without those two statements. $b.alloc$ may be smaller than $a.used$, meaning that undefined values will be read from $b$ past the end of the array of digits. \subsection{Signed Comparisons} Comparing with sign considerations is also fairly critical in several routines (\textit{division for example}). Based on an unsigned magnitude comparison a trivial signed comparison algorithm can be written. \begin{figure}[here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_cmp}. \\ \textbf{Input}. Two mp\_ints $a$ and $b$ \\ \textbf{Output}. Signed Comparison Results ($a$ to the left of $b$) \\ \hline \\ 1. if $a.sign = MP\_NEG$ and $b.sign = MP\_ZPOS$ then return(\textit{MP\_LT}) \\ 2. if $a.sign = MP\_ZPOS$ and $b.sign = MP\_NEG$ then return(\textit{MP\_GT}) \\ 3. if $a.sign = MP\_NEG$ then \\ \hspace{+3mm}3.1 Return the unsigned comparison of $b$ and $a$ (\textit{mp\_cmp\_mag}) \\ 4 Otherwise \\ \hspace{+3mm}4.1 Return the unsigned comparison of $a$ and $b$ \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_cmp} \end{figure} \textbf{Algorithm mp\_cmp.} The first two steps compare the signs of the two inputs. If the signs do not agree then it can return right away with the appropriate comparison code. When the signs are equal the digits of the inputs must be compared to determine the correct result. In step three the unsigned comparision flips the order of the arguments since they are both negative. For instance, if $-a > -b$ then $\vert a \vert < \vert b \vert$. Step number four will compare the two when they are both positive. EXAM,bn_mp_cmp.c The two if statements (lines @22,if@ and @26,if@) perform the initial sign comparison. If the signs are not the equal then which ever has the positive sign is larger. The inputs are compared (line @30,if@) based on magnitudes. If the signs were both negative then the unsigned comparison is performed in the opposite direction (line @31,mp_cmp_mag@). Otherwise, the signs are assumed to be both positive and a forward direction unsigned comparison is performed. \section*{Exercises} \begin{tabular}{cl} $\left [ 2 \right ]$ & Modify algorithm mp\_set\_int to accept as input a variable length array of bits. \\ & \\ $\left [ 3 \right ]$ & Give the probability that algorithm mp\_cmp\_mag will have to compare $k$ digits \\ & of two random digits (of equal magnitude) before a difference is found. \\ & \\ $\left [ 1 \right ]$ & Suggest a simple method to speed up the implementation of mp\_cmp\_mag based \\ & on the observations made in the previous problem. \\ & \end{tabular} \chapter{Basic Arithmetic} \section{Introduction} At this point algorithms for initialization, clearing, zeroing, copying, comparing and setting small constants have been established. The next logical set of algorithms to develop are addition, subtraction and digit shifting algorithms. These algorithms make use of the lower level algorithms and are the cruicial building block for the multiplication algorithms. It is very important that these algorithms are highly optimized. On their own they are simple $O(n)$ algorithms but they can be called from higher level algorithms which easily places them at $O(n^2)$ or even $O(n^3)$ work levels. MARK,SHIFTS All of the algorithms within this chapter make use of the logical bit shift operations denoted by $<<$ and $>>$ for left and right logical shifts respectively. A logical shift is analogous to sliding the decimal point of radix-10 representations. For example, the real number $0.9345$ is equivalent to $93.45\%$ which is found by sliding the the decimal two places to the right (\textit{multiplying by $\beta^2 = 10^2$}). Algebraically a binary logical shift is equivalent to a division or multiplication by a power of two. For example, $a << k = a \cdot 2^k$ while $a >> k = \lfloor a/2^k \rfloor$. One significant difference between a logical shift and the way decimals are shifted is that digits below the zero'th position are removed from the number. For example, consider $1101_2 >> 1$ using decimal notation this would produce $110.1_2$. However, with a logical shift the result is $110_2$. \section{Addition and Subtraction} In common twos complement fixed precision arithmetic negative numbers are easily represented by subtraction from the modulus. For example, with 32-bit integers $a - b\mbox{ (mod }2^{32}\mbox{)}$ is the same as $a + (2^{32} - b) \mbox{ (mod }2^{32}\mbox{)}$ since $2^{32} \equiv 0 \mbox{ (mod }2^{32}\mbox{)}$. As a result subtraction can be performed with a trivial series of logical operations and an addition. However, in multiple precision arithmetic negative numbers are not represented in the same way. Instead a sign flag is used to keep track of the sign of the integer. As a result signed addition and subtraction are actually implemented as conditional usage of lower level addition or subtraction algorithms with the sign fixed up appropriately. The lower level algorithms will add or subtract integers without regard to the sign flag. That is they will add or subtract the magnitude of the integers respectively. \subsection{Low Level Addition} An unsigned addition of multiple precision integers is performed with the same long-hand algorithm used to add decimal numbers. That is to add the trailing digits first and propagate the resulting carry upwards. Since this is a lower level algorithm the name will have a ``s\_'' prefix. Historically that convention stems from the MPI library where ``s\_'' stood for static functions that were hidden from the developer entirely. \newpage \begin{figure}[!here] \begin{center} \begin{small} \begin{tabular}{l} \hline Algorithm \textbf{s\_mp\_add}. \\ \textbf{Input}. Two mp\_ints $a$ and $b$ \\ \textbf{Output}. The unsigned addition $c = \vert a \vert + \vert b \vert$. \\ \hline \\ 1. if $a.used > b.used$ then \\ \hspace{+3mm}1.1 $min \leftarrow b.used$ \\ \hspace{+3mm}1.2 $max \leftarrow a.used$ \\ \hspace{+3mm}1.3 $x \leftarrow a$ \\ 2. else \\ \hspace{+3mm}2.1 $min \leftarrow a.used$ \\ \hspace{+3mm}2.2 $max \leftarrow b.used$ \\ \hspace{+3mm}2.3 $x \leftarrow b$ \\ 3. If $c.alloc < max + 1$ then grow $c$ to hold at least $max + 1$ digits (\textit{mp\_grow}) \\ 4. $oldused \leftarrow c.used$ \\ 5. $c.used \leftarrow max + 1$ \\ 6. $u \leftarrow 0$ \\ 7. for $n$ from $0$ to $min - 1$ do \\ \hspace{+3mm}7.1 $c_n \leftarrow a_n + b_n + u$ \\ \hspace{+3mm}7.2 $u \leftarrow c_n >> lg(\beta)$ \\ \hspace{+3mm}7.3 $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\ 8. if $min \ne max$ then do \\ \hspace{+3mm}8.1 for $n$ from $min$ to $max - 1$ do \\ \hspace{+6mm}8.1.1 $c_n \leftarrow x_n + u$ \\ \hspace{+6mm}8.1.2 $u \leftarrow c_n >> lg(\beta)$ \\ \hspace{+6mm}8.1.3 $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\ 9. $c_{max} \leftarrow u$ \\ 10. if $olduse > max$ then \\ \hspace{+3mm}10.1 for $n$ from $max + 1$ to $oldused - 1$ do \\ \hspace{+6mm}10.1.1 $c_n \leftarrow 0$ \\ 11. Clamp excess digits in $c$. (\textit{mp\_clamp}) \\ 12. Return(\textit{MP\_OKAY}) \\ \hline \end{tabular} \end{small} \end{center} \caption{Algorithm s\_mp\_add} \end{figure} \textbf{Algorithm s\_mp\_add.} This algorithm is loosely based on algorithm 14.7 of HAC \cite[pp. 594]{HAC} but has been extended to allow the inputs to have different magnitudes. Coincidentally the description of algorithm A in Knuth \cite[pp. 266]{TAOCPV2} shares the same deficiency as the algorithm from \cite{HAC}. Even the MIX pseudo machine code presented by Knuth \cite[pp. 266-267]{TAOCPV2} is incapable of handling inputs which are of different magnitudes. The first thing that has to be accomplished is to sort out which of the two inputs is the largest. The addition logic will simply add all of the smallest input to the largest input and store that first part of the result in the destination. Then it will apply a simpler addition loop to excess digits of the larger input. The first two steps will handle sorting the inputs such that $min$ and $max$ hold the digit counts of the two inputs. The variable $x$ will be an mp\_int alias for the largest input or the second input $b$ if they have the same number of digits. After the inputs are sorted the destination $c$ is grown as required to accomodate the sum of the two inputs. The original \textbf{used} count of $c$ is copied and set to the new used count. At this point the first addition loop will go through as many digit positions that both inputs have. The carry variable $\mu$ is set to zero outside the loop. Inside the loop an ``addition'' step requires three statements to produce one digit of the summand. First two digits from $a$ and $b$ are added together along with the carry $\mu$. The carry of this step is extracted and stored in $\mu$ and finally the digit of the result $c_n$ is truncated within the range $0 \le c_n < \beta$. Now all of the digit positions that both inputs have in common have been exhausted. If $min \ne max$ then $x$ is an alias for one of the inputs that has more digits. A simplified addition loop is then used to essentially copy the remaining digits and the carry to the destination. The final carry is stored in $c_{max}$ and digits above $max$ upto $oldused$ are zeroed which completes the addition. EXAM,bn_s_mp_add.c We first sort (lines @27,if@ to @35,}@) the inputs based on magnitude and determine the $min$ and $max$ variables. Note that $x$ is a pointer to an mp\_int assigned to the largest input, in effect it is a local alias. Next we grow the destination (@37,init@ to @42,}@) ensure that it can accomodate the result of the addition. Similar to the implementation of mp\_copy this function uses the braced code and local aliases coding style. The three aliases that are on lines @56,tmpa@, @59,tmpb@ and @62,tmpc@ represent the two inputs and destination variables respectively. These aliases are used to ensure the compiler does not have to dereference $a$, $b$ or $c$ (respectively) to access the digits of the respective mp\_int. The initial carry $u$ will be cleared (line @65,u = 0@), note that $u$ is of type mp\_digit which ensures type compatibility within the implementation. The initial addition (line @66,for@ to @75,}@) adds digits from both inputs until the smallest input runs out of digits. Similarly the conditional addition loop (line @81,for@ to @90,}@) adds the remaining digits from the larger of the two inputs. The addition is finished with the final carry being stored in $tmpc$ (line @94,tmpc++@). Note the ``++'' operator within the same expression. After line @94,tmpc++@, $tmpc$ will point to the $c.used$'th digit of the mp\_int $c$. This is useful for the next loop (line @97,for@ to @99,}@) which set any old upper digits to zero. \subsection{Low Level Subtraction} The low level unsigned subtraction algorithm is very similar to the low level unsigned addition algorithm. The principle difference is that the unsigned subtraction algorithm requires the result to be positive. That is when computing $a - b$ the condition $\vert a \vert \ge \vert b\vert$ must be met for this algorithm to function properly. Keep in mind this low level algorithm is not meant to be used in higher level algorithms directly. This algorithm as will be shown can be used to create functional signed addition and subtraction algorithms. MARK,GAMMA For this algorithm a new variable is required to make the description simpler. Recall from section 1.3.1 that a mp\_digit must be able to represent the range $0 \le x < 2\beta$ for the algorithms to work correctly. However, it is allowable that a mp\_digit represent a larger range of values. For this algorithm we will assume that the variable $\gamma$ represents the number of bits available in a mp\_digit (\textit{this implies $2^{\gamma} > \beta$}). For example, the default for LibTomMath is to use a ``unsigned long'' for the mp\_digit ``type'' while $\beta = 2^{28}$. In ISO C an ``unsigned long'' data type must be able to represent $0 \le x < 2^{32}$ meaning that in this case $\gamma \ge 32$. \newpage\begin{figure}[!here] \begin{center} \begin{small} \begin{tabular}{l} \hline Algorithm \textbf{s\_mp\_sub}. \\ \textbf{Input}. Two mp\_ints $a$ and $b$ ($\vert a \vert \ge \vert b \vert$) \\ \textbf{Output}. The unsigned subtraction $c = \vert a \vert - \vert b \vert$. \\ \hline \\ 1. $min \leftarrow b.used$ \\ 2. $max \leftarrow a.used$ \\ 3. If $c.alloc < max$ then grow $c$ to hold at least $max$ digits. (\textit{mp\_grow}) \\ 4. $oldused \leftarrow c.used$ \\ 5. $c.used \leftarrow max$ \\ 6. $u \leftarrow 0$ \\ 7. for $n$ from $0$ to $min - 1$ do \\ \hspace{3mm}7.1 $c_n \leftarrow a_n - b_n - u$ \\ \hspace{3mm}7.2 $u \leftarrow c_n >> (\gamma - 1)$ \\ \hspace{3mm}7.3 $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\ 8. if $min < max$ then do \\ \hspace{3mm}8.1 for $n$ from $min$ to $max - 1$ do \\ \hspace{6mm}8.1.1 $c_n \leftarrow a_n - u$ \\ \hspace{6mm}8.1.2 $u \leftarrow c_n >> (\gamma - 1)$ \\ \hspace{6mm}8.1.3 $c_n \leftarrow c_n \mbox{ (mod }\beta\mbox{)}$ \\ 9. if $oldused > max$ then do \\ \hspace{3mm}9.1 for $n$ from $max$ to $oldused - 1$ do \\ \hspace{6mm}9.1.1 $c_n \leftarrow 0$ \\ 10. Clamp excess digits of $c$. (\textit{mp\_clamp}). \\ 11. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{small} \end{center} \caption{Algorithm s\_mp\_sub} \end{figure} \textbf{Algorithm s\_mp\_sub.} This algorithm performs the unsigned subtraction of two mp\_int variables under the restriction that the result must be positive. That is when passing variables $a$ and $b$ the condition that $\vert a \vert \ge \vert b \vert$ must be met for the algorithm to function correctly. This algorithm is loosely based on algorithm 14.9 \cite[pp. 595]{HAC} and is similar to algorithm S in \cite[pp. 267]{TAOCPV2} as well. As was the case of the algorithm s\_mp\_add both other references lack discussion concerning various practical details such as when the inputs differ in magnitude. The initial sorting of the inputs is trivial in this algorithm since $a$ is guaranteed to have at least the same magnitude of $b$. Steps 1 and 2 set the $min$ and $max$ variables. Unlike the addition routine there is guaranteed to be no carry which means that the final result can be at most $max$ digits in length as opposed to $max + 1$. Similar to the addition algorithm the \textbf{used} count of $c$ is copied locally and set to the maximal count for the operation. The subtraction loop that begins on step seven is essentially the same as the addition loop of algorithm s\_mp\_add except single precision subtraction is used instead. Note the use of the $\gamma$ variable to extract the carry (\textit{also known as the borrow}) within the subtraction loops. Under the assumption that two's complement single precision arithmetic is used this will successfully extract the desired carry. For example, consider subtracting $0101_2$ from $0100_2$ where $\gamma = 4$ and $\beta = 2$. The least significant bit will force a carry upwards to the third bit which will be set to zero after the borrow. After the very first bit has been subtracted $4 - 1 \equiv 0011_2$ will remain, When the third bit of $0101_2$ is subtracted from the result it will cause another carry. In this case though the carry will be forced to propagate all the way to the most significant bit. Recall that $\beta < 2^{\gamma}$. This means that if a carry does occur just before the $lg(\beta)$'th bit it will propagate all the way to the most significant bit. Thus, the high order bits of the mp\_digit that are not part of the actual digit will either be all zero, or all one. All that is needed is a single zero or one bit for the carry. Therefore a single logical shift right by $\gamma - 1$ positions is sufficient to extract the carry. This method of carry extraction may seem awkward but the reason for it becomes apparent when the implementation is discussed. If $b$ has a smaller magnitude than $a$ then step 9 will force the carry and copy operation to propagate through the larger input $a$ into $c$. Step 10 will ensure that any leading digits of $c$ above the $max$'th position are zeroed. EXAM,bn_s_mp_sub.c Like low level addition we ``sort'' the inputs. Except in this case the sorting is hardcoded (lines @24,min@ and @25,max@). In reality the $min$ and $max$ variables are only aliases and are only used to make the source code easier to read. Again the pointer alias optimization is used within this algorithm. The aliases $tmpa$, $tmpb$ and $tmpc$ are initialized (lines @42,tmpa@, @43,tmpb@ and @44,tmpc@) for $a$, $b$ and $c$ respectively. The first subtraction loop (lines @47,u = 0@ through @61,}@) subtract digits from both inputs until the smaller of the two inputs has been exhausted. As remarked earlier there is an implementation reason for using the ``awkward'' method of extracting the carry (line @57, >>@). The traditional method for extracting the carry would be to shift by $lg(\beta)$ positions and logically AND the least significant bit. The AND operation is required because all of the bits above the $\lg(\beta)$'th bit will be set to one after a carry occurs from subtraction. This carry extraction requires two relatively cheap operations to extract the carry. The other method is to simply shift the most significant bit to the least significant bit thus extracting the carry with a single cheap operation. This optimization only works on twos compliment machines which is a safe assumption to make. If $a$ has a larger magnitude than $b$ an additional loop (lines @64,for@ through @73,}@) is required to propagate the carry through $a$ and copy the result to $c$. \subsection{High Level Addition} Now that both lower level addition and subtraction algorithms have been established an effective high level signed addition algorithm can be established. This high level addition algorithm will be what other algorithms and developers will use to perform addition of mp\_int data types. Recall from section 5.2 that an mp\_int represents an integer with an unsigned mantissa (\textit{the array of digits}) and a \textbf{sign} flag. A high level addition is actually performed as a series of eight separate cases which can be optimized down to three unique cases. \begin{figure}[!here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_add}. \\ \textbf{Input}. Two mp\_ints $a$ and $b$ \\ \textbf{Output}. The signed addition $c = a + b$. \\ \hline \\ 1. if $a.sign = b.sign$ then do \\ \hspace{3mm}1.1 $c.sign \leftarrow a.sign$ \\ \hspace{3mm}1.2 $c \leftarrow \vert a \vert + \vert b \vert$ (\textit{s\_mp\_add})\\ 2. else do \\ \hspace{3mm}2.1 if $\vert a \vert < \vert b \vert$ then do (\textit{mp\_cmp\_mag}) \\ \hspace{6mm}2.1.1 $c.sign \leftarrow b.sign$ \\ \hspace{6mm}2.1.2 $c \leftarrow \vert b \vert - \vert a \vert$ (\textit{s\_mp\_sub}) \\ \hspace{3mm}2.2 else do \\ \hspace{6mm}2.2.1 $c.sign \leftarrow a.sign$ \\ \hspace{6mm}2.2.2 $c \leftarrow \vert a \vert - \vert b \vert$ \\ 3. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_add} \end{figure} \textbf{Algorithm mp\_add.} This algorithm performs the signed addition of two mp\_int variables. There is no reference algorithm to draw upon from either \cite{TAOCPV2} or \cite{HAC} since they both only provide unsigned operations. The algorithm is fairly straightforward but restricted since subtraction can only produce positive results. \begin{figure}[here] \begin{small} \begin{center} \begin{tabular}{|c|c|c|c|c|} \hline \textbf{Sign of $a$} & \textbf{Sign of $b$} & \textbf{$\vert a \vert > \vert b \vert $} & \textbf{Unsigned Operation} & \textbf{Result Sign Flag} \\ \hline $+$ & $+$ & Yes & $c = a + b$ & $a.sign$ \\ \hline $+$ & $+$ & No & $c = a + b$ & $a.sign$ \\ \hline $-$ & $-$ & Yes & $c = a + b$ & $a.sign$ \\ \hline $-$ & $-$ & No & $c = a + b$ & $a.sign$ \\ \hline &&&&\\ \hline $+$ & $-$ & No & $c = b - a$ & $b.sign$ \\ \hline $-$ & $+$ & No & $c = b - a$ & $b.sign$ \\ \hline &&&&\\ \hline $+$ & $-$ & Yes & $c = a - b$ & $a.sign$ \\ \hline $-$ & $+$ & Yes & $c = a - b$ & $a.sign$ \\ \hline \end{tabular} \end{center} \end{small} \caption{Addition Guide Chart} \label{fig:AddChart} \end{figure} Figure~\ref{fig:AddChart} lists all of the eight possible input combinations and is sorted to show that only three specific cases need to be handled. The return code of the unsigned operations at step 1.2, 2.1.2 and 2.2.2 are forwarded to step three to check for errors. This simplifies the description of the algorithm considerably and best follows how the implementation actually was achieved. Also note how the \textbf{sign} is set before the unsigned addition or subtraction is performed. Recall from the descriptions of algorithms s\_mp\_add and s\_mp\_sub that the mp\_clamp function is used at the end to trim excess digits. The mp\_clamp algorithm will set the \textbf{sign} to \textbf{MP\_ZPOS} when the \textbf{used} digit count reaches zero. For example, consider performing $-a + a$ with algorithm mp\_add. By the description of the algorithm the sign is set to \textbf{MP\_NEG} which would produce a result of $-0$. However, since the sign is set first then the unsigned addition is performed the subsequent usage of algorithm mp\_clamp within algorithm s\_mp\_add will force $-0$ to become $0$. EXAM,bn_mp_add.c The source code follows the algorithm fairly closely. The most notable new source code addition is the usage of the $res$ integer variable which is used to pass result of the unsigned operations forward. Unlike in the algorithm, the variable $res$ is merely returned as is without explicitly checking it and returning the constant \textbf{MP\_OKAY}. The observation is this algorithm will succeed or fail only if the lower level functions do so. Returning their return code is sufficient. \subsection{High Level Subtraction} The high level signed subtraction algorithm is essentially the same as the high level signed addition algorithm. \newpage\begin{figure}[!here] \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_sub}. \\ \textbf{Input}. Two mp\_ints $a$ and $b$ \\ \textbf{Output}. The signed subtraction $c = a - b$. \\ \hline \\ 1. if $a.sign \ne b.sign$ then do \\ \hspace{3mm}1.1 $c.sign \leftarrow a.sign$ \\ \hspace{3mm}1.2 $c \leftarrow \vert a \vert + \vert b \vert$ (\textit{s\_mp\_add}) \\ 2. else do \\ \hspace{3mm}2.1 if $\vert a \vert \ge \vert b \vert$ then do (\textit{mp\_cmp\_mag}) \\ \hspace{6mm}2.1.1 $c.sign \leftarrow a.sign$ \\ \hspace{6mm}2.1.2 $c \leftarrow \vert a \vert - \vert b \vert$ (\textit{s\_mp\_sub}) \\ \hspace{3mm}2.2 else do \\ \hspace{6mm}2.2.1 $c.sign \leftarrow \left \lbrace \begin{array}{ll} MP\_ZPOS & \mbox{if }a.sign = MP\_NEG \\ MP\_NEG & \mbox{otherwise} \\ \end{array} \right .$ \\ \hspace{6mm}2.2.2 $c \leftarrow \vert b \vert - \vert a \vert$ \\ 3. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \caption{Algorithm mp\_sub} \end{figure} \textbf{Algorithm mp\_sub.} This algorithm performs the signed subtraction of two inputs. Similar to algorithm mp\_add there is no reference in either \cite{TAOCPV2} or \cite{HAC}. Also this algorithm is restricted by algorithm s\_mp\_sub. Chart \ref{fig:SubChart} lists the eight possible inputs and the operations required. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{|c|c|c|c|c|} \hline \textbf{Sign of $a$} & \textbf{Sign of $b$} & \textbf{$\vert a \vert \ge \vert b \vert $} & \textbf{Unsigned Operation} & \textbf{Result Sign Flag} \\ \hline $+$ & $-$ & Yes & $c = a + b$ & $a.sign$ \\ \hline $+$ & $-$ & No & $c = a + b$ & $a.sign$ \\ \hline $-$ & $+$ & Yes & $c = a + b$ & $a.sign$ \\ \hline $-$ & $+$ & No & $c = a + b$ & $a.sign$ \\ \hline &&&& \\ \hline $+$ & $+$ & Yes & $c = a - b$ & $a.sign$ \\ \hline $-$ & $-$ & Yes & $c = a - b$ & $a.sign$ \\ \hline &&&& \\ \hline $+$ & $+$ & No & $c = b - a$ & $\mbox{opposite of }a.sign$ \\ \hline $-$ & $-$ & No & $c = b - a$ & $\mbox{opposite of }a.sign$ \\ \hline \end{tabular} \end{center} \end{small} \caption{Subtraction Guide Chart} \label{fig:SubChart} \end{figure} Similar to the case of algorithm mp\_add the \textbf{sign} is set first before the unsigned addition or subtraction. That is to prevent the algorithm from producing $-a - -a = -0$ as a result. EXAM,bn_mp_sub.c Much like the implementation of algorithm mp\_add the variable $res$ is used to catch the return code of the unsigned addition or subtraction operations and forward it to the end of the function. On line @38, != MP_LT@ the ``not equal to'' \textbf{MP\_LT} expression is used to emulate a ``greater than or equal to'' comparison. \section{Bit and Digit Shifting} MARK,POLY It is quite common to think of a multiple precision integer as a polynomial in $x$, that is $y = f(\beta)$ where $f(x) = \sum_{i=0}^{n-1} a_i x^i$. This notation arises within discussion of Montgomery and Diminished Radix Reduction as well as Karatsuba multiplication and squaring. In order to facilitate operations on polynomials in $x$ as above a series of simple ``digit'' algorithms have to be established. That is to shift the digits left or right as well to shift individual bits of the digits left and right. It is important to note that not all ``shift'' operations are on radix-$\beta$ digits. \subsection{Multiplication by Two} In a binary system where the radix is a power of two multiplication by two not only arises often in other algorithms it is a fairly efficient operation to perform. A single precision logical shift left is sufficient to multiply a single digit by two. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_mul\_2}. \\ \textbf{Input}. One mp\_int $a$ \\ \textbf{Output}. $b = 2a$. \\ \hline \\ 1. If $b.alloc < a.used + 1$ then grow $b$ to hold $a.used + 1$ digits. (\textit{mp\_grow}) \\ 2. $oldused \leftarrow b.used$ \\ 3. $b.used \leftarrow a.used$ \\ 4. $r \leftarrow 0$ \\ 5. for $n$ from 0 to $a.used - 1$ do \\ \hspace{3mm}5.1 $rr \leftarrow a_n >> (lg(\beta) - 1)$ \\ \hspace{3mm}5.2 $b_n \leftarrow (a_n << 1) + r \mbox{ (mod }\beta\mbox{)}$ \\ \hspace{3mm}5.3 $r \leftarrow rr$ \\ 6. If $r \ne 0$ then do \\ \hspace{3mm}6.1 $b_{n + 1} \leftarrow r$ \\ \hspace{3mm}6.2 $b.used \leftarrow b.used + 1$ \\ 7. If $b.used < oldused - 1$ then do \\ \hspace{3mm}7.1 for $n$ from $b.used$ to $oldused - 1$ do \\ \hspace{6mm}7.1.1 $b_n \leftarrow 0$ \\ 8. $b.sign \leftarrow a.sign$ \\ 9. Return(\textit{MP\_OKAY}).\\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_mul\_2} \end{figure} \textbf{Algorithm mp\_mul\_2.} This algorithm will quickly multiply a mp\_int by two provided $\beta$ is a power of two. Neither \cite{TAOCPV2} nor \cite{HAC} describe such an algorithm despite the fact it arises often in other algorithms. The algorithm is setup much like the lower level algorithm s\_mp\_add since it is for all intents and purposes equivalent to the operation $b = \vert a \vert + \vert a \vert$. Step 1 and 2 grow the input as required to accomodate the maximum number of \textbf{used} digits in the result. The initial \textbf{used} count is set to $a.used$ at step 4. Only if there is a final carry will the \textbf{used} count require adjustment. Step 6 is an optimization implementation of the addition loop for this specific case. That is since the two values being added together are the same there is no need to perform two reads from the digits of $a$. Step 6.1 performs a single precision shift on the current digit $a_n$ to obtain what will be the carry for the next iteration. Step 6.2 calculates the $n$'th digit of the result as single precision shift of $a_n$ plus the previous carry. Recall from ~SHIFTS~ that $a_n << 1$ is equivalent to $a_n \cdot 2$. An iteration of the addition loop is finished with forwarding the carry to the next iteration. Step 7 takes care of any final carry by setting the $a.used$'th digit of the result to the carry and augmenting the \textbf{used} count of $b$. Step 8 clears any leading digits of $b$ in case it originally had a larger magnitude than $a$. EXAM,bn_mp_mul_2.c This implementation is essentially an optimized implementation of s\_mp\_add for the case of doubling an input. The only noteworthy difference is the use of the logical shift operator on line @52,<<@ to perform a single precision doubling. \subsection{Division by Two} A division by two can just as easily be accomplished with a logical shift right as multiplication by two can be with a logical shift left. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_div\_2}. \\ \textbf{Input}. One mp\_int $a$ \\ \textbf{Output}. $b = a/2$. \\ \hline \\ 1. If $b.alloc < a.used$ then grow $b$ to hold $a.used$ digits. (\textit{mp\_grow}) \\ 2. If the reallocation failed return(\textit{MP\_MEM}). \\ 3. $oldused \leftarrow b.used$ \\ 4. $b.used \leftarrow a.used$ \\ 5. $r \leftarrow 0$ \\ 6. for $n$ from $b.used - 1$ to $0$ do \\ \hspace{3mm}6.1 $rr \leftarrow a_n \mbox{ (mod }2\mbox{)}$\\ \hspace{3mm}6.2 $b_n \leftarrow (a_n >> 1) + (r << (lg(\beta) - 1)) \mbox{ (mod }\beta\mbox{)}$ \\ \hspace{3mm}6.3 $r \leftarrow rr$ \\ 7. If $b.used < oldused - 1$ then do \\ \hspace{3mm}7.1 for $n$ from $b.used$ to $oldused - 1$ do \\ \hspace{6mm}7.1.1 $b_n \leftarrow 0$ \\ 8. $b.sign \leftarrow a.sign$ \\ 9. Clamp excess digits of $b$. (\textit{mp\_clamp}) \\ 10. Return(\textit{MP\_OKAY}).\\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_div\_2} \end{figure} \textbf{Algorithm mp\_div\_2.} This algorithm will divide an mp\_int by two using logical shifts to the right. Like mp\_mul\_2 it uses a modified low level addition core as the basis of the algorithm. Unlike mp\_mul\_2 the shift operations work from the leading digit to the trailing digit. The algorithm could be written to work from the trailing digit to the leading digit however, it would have to stop one short of $a.used - 1$ digits to prevent reading past the end of the array of digits. Essentially the loop at step 6 is similar to that of mp\_mul\_2 except the logical shifts go in the opposite direction and the carry is at the least significant bit not the most significant bit. EXAM,bn_mp_div_2.c \section{Polynomial Basis Operations} Recall from ~POLY~ that any integer can be represented as a polynomial in $x$ as $y = f(\beta)$. Such a representation is also known as the polynomial basis \cite[pp. 48]{ROSE}. Given such a notation a multiplication or division by $x$ amounts to shifting whole digits a single place. The need for such operations arises in several other higher level algorithms such as Barrett and Montgomery reduction, integer division and Karatsuba multiplication. Converting from an array of digits to polynomial basis is very simple. Consider the integer $y \equiv (a_2, a_1, a_0)_{\beta}$ and recall that $y = \sum_{i=0}^{2} a_i \beta^i$. Simply replace $\beta$ with $x$ and the expression is in polynomial basis. For example, $f(x) = 8x + 9$ is the polynomial basis representation for $89$ using radix ten. That is, $f(10) = 8(10) + 9 = 89$. \subsection{Multiplication by $x$} Given a polynomial in $x$ such as $f(x) = a_n x^n + a_{n-1} x^{n-1} + ... + a_0$ multiplying by $x$ amounts to shifting the coefficients up one degree. In this case $f(x) \cdot x = a_n x^{n+1} + a_{n-1} x^n + ... + a_0 x$. From a scalar basis point of view multiplying by $x$ is equivalent to multiplying by the integer $\beta$. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_lshd}. \\ \textbf{Input}. One mp\_int $a$ and an integer $b$ \\ \textbf{Output}. $a \leftarrow a \cdot \beta^b$ (equivalent to multiplication by $x^b$). \\ \hline \\ 1. If $b \le 0$ then return(\textit{MP\_OKAY}). \\ 2. If $a.alloc < a.used + b$ then grow $a$ to at least $a.used + b$ digits. (\textit{mp\_grow}). \\ 3. If the reallocation failed return(\textit{MP\_MEM}). \\ 4. $a.used \leftarrow a.used + b$ \\ 5. $i \leftarrow a.used - 1$ \\ 6. $j \leftarrow a.used - 1 - b$ \\ 7. for $n$ from $a.used - 1$ to $b$ do \\ \hspace{3mm}7.1 $a_{i} \leftarrow a_{j}$ \\ \hspace{3mm}7.2 $i \leftarrow i - 1$ \\ \hspace{3mm}7.3 $j \leftarrow j - 1$ \\ 8. for $n$ from 0 to $b - 1$ do \\ \hspace{3mm}8.1 $a_n \leftarrow 0$ \\ 9. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_lshd} \end{figure} \textbf{Algorithm mp\_lshd.} This algorithm multiplies an mp\_int by the $b$'th power of $x$. This is equivalent to multiplying by $\beta^b$. The algorithm differs from the other algorithms presented so far as it performs the operation in place instead storing the result in a separate location. The motivation behind this change is due to the way this function is typically used. Algorithms such as mp\_add store the result in an optionally different third mp\_int because the original inputs are often still required. Algorithm mp\_lshd (\textit{and similarly algorithm mp\_rshd}) is typically used on values where the original value is no longer required. The algorithm will return success immediately if $b \le 0$ since the rest of algorithm is only valid when $b > 0$. First the destination $a$ is grown as required to accomodate the result. The counters $i$ and $j$ are used to form a \textit{sliding window} over the digits of $a$ of length $b$. The head of the sliding window is at $i$ (\textit{the leading digit}) and the tail at $j$ (\textit{the trailing digit}). The loop on step 7 copies the digit from the tail to the head. In each iteration the window is moved down one digit. The last loop on step 8 sets the lower $b$ digits to zero. \newpage FIGU,sliding_window,Sliding Window Movement EXAM,bn_mp_lshd.c The if statement (line @24,if@) ensures that the $b$ variable is greater than zero since we do not interpret negative shift counts properly. The \textbf{used} count is incremented by $b$ before the copy loop begins. This elminates the need for an additional variable in the for loop. The variable $top$ (line @42,top@) is an alias for the leading digit while $bottom$ (line @45,bottom@) is an alias for the trailing edge. The aliases form a window of exactly $b$ digits over the input. \subsection{Division by $x$} Division by powers of $x$ is easily achieved by shifting the digits right and removing any that will end up to the right of the zero'th digit. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_rshd}. \\ \textbf{Input}. One mp\_int $a$ and an integer $b$ \\ \textbf{Output}. $a \leftarrow a / \beta^b$ (Divide by $x^b$). \\ \hline \\ 1. If $b \le 0$ then return. \\ 2. If $a.used \le b$ then do \\ \hspace{3mm}2.1 Zero $a$. (\textit{mp\_zero}). \\ \hspace{3mm}2.2 Return. \\ 3. $i \leftarrow 0$ \\ 4. $j \leftarrow b$ \\ 5. for $n$ from 0 to $a.used - b - 1$ do \\ \hspace{3mm}5.1 $a_i \leftarrow a_j$ \\ \hspace{3mm}5.2 $i \leftarrow i + 1$ \\ \hspace{3mm}5.3 $j \leftarrow j + 1$ \\ 6. for $n$ from $a.used - b$ to $a.used - 1$ do \\ \hspace{3mm}6.1 $a_n \leftarrow 0$ \\ 7. $a.used \leftarrow a.used - b$ \\ 8. Return. \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_rshd} \end{figure} \textbf{Algorithm mp\_rshd.} This algorithm divides the input in place by the $b$'th power of $x$. It is analogous to dividing by a $\beta^b$ but much quicker since it does not require single precision division. This algorithm does not actually return an error code as it cannot fail. If the input $b$ is less than one the algorithm quickly returns without performing any work. If the \textbf{used} count is less than or equal to the shift count $b$ then it will simply zero the input and return. After the trivial cases of inputs have been handled the sliding window is setup. Much like the case of algorithm mp\_lshd a sliding window that is $b$ digits wide is used to copy the digits. Unlike mp\_lshd the window slides in the opposite direction from the trailing to the leading digit. Also the digits are copied from the leading to the trailing edge. Once the window copy is complete the upper digits must be zeroed and the \textbf{used} count decremented. EXAM,bn_mp_rshd.c The only noteworthy element of this routine is the lack of a return type since it cannot fail. Like mp\_lshd() we form a sliding window except we copy in the other direction. After the window (line @59,for (;@) we then zero the upper digits of the input to make sure the result is correct. \section{Powers of Two} Now that algorithms for moving single bits as well as whole digits exist algorithms for moving the ``in between'' distances are required. For example, to quickly multiply by $2^k$ for any $k$ without using a full multiplier algorithm would prove useful. Instead of performing single shifts $k$ times to achieve a multiplication by $2^{\pm k}$ a mixture of whole digit shifting and partial digit shifting is employed. \subsection{Multiplication by Power of Two} \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_mul\_2d}. \\ \textbf{Input}. One mp\_int $a$ and an integer $b$ \\ \textbf{Output}. $c \leftarrow a \cdot 2^b$. \\ \hline \\ 1. $c \leftarrow a$. (\textit{mp\_copy}) \\ 2. If $c.alloc < c.used + \lfloor b / lg(\beta) \rfloor + 2$ then grow $c$ accordingly. \\ 3. If the reallocation failed return(\textit{MP\_MEM}). \\ 4. If $b \ge lg(\beta)$ then \\ \hspace{3mm}4.1 $c \leftarrow c \cdot \beta^{\lfloor b / lg(\beta) \rfloor}$ (\textit{mp\_lshd}). \\ \hspace{3mm}4.2 If step 4.1 failed return(\textit{MP\_MEM}). \\ 5. $d \leftarrow b \mbox{ (mod }lg(\beta)\mbox{)}$ \\ 6. If $d \ne 0$ then do \\ \hspace{3mm}6.1 $mask \leftarrow 2^d$ \\ \hspace{3mm}6.2 $r \leftarrow 0$ \\ \hspace{3mm}6.3 for $n$ from $0$ to $c.used - 1$ do \\ \hspace{6mm}6.3.1 $rr \leftarrow c_n >> (lg(\beta) - d) \mbox{ (mod }mask\mbox{)}$ \\ \hspace{6mm}6.3.2 $c_n \leftarrow (c_n << d) + r \mbox{ (mod }\beta\mbox{)}$ \\ \hspace{6mm}6.3.3 $r \leftarrow rr$ \\ \hspace{3mm}6.4 If $r > 0$ then do \\ \hspace{6mm}6.4.1 $c_{c.used} \leftarrow r$ \\ \hspace{6mm}6.4.2 $c.used \leftarrow c.used + 1$ \\ 7. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_mul\_2d} \end{figure} \textbf{Algorithm mp\_mul\_2d.} This algorithm multiplies $a$ by $2^b$ and stores the result in $c$. The algorithm uses algorithm mp\_lshd and a derivative of algorithm mp\_mul\_2 to quickly compute the product. First the algorithm will multiply $a$ by $x^{\lfloor b / lg(\beta) \rfloor}$ which will ensure that the remainder multiplicand is less than $\beta$. For example, if $b = 37$ and $\beta = 2^{28}$ then this step will multiply by $x$ leaving a multiplication by $2^{37 - 28} = 2^{9}$ left. After the digits have been shifted appropriately at most $lg(\beta) - 1$ shifts are left to perform. Step 5 calculates the number of remaining shifts required. If it is non-zero a modified shift loop is used to calculate the remaining product. Essentially the loop is a generic version of algorith mp\_mul2 designed to handle any shift count in the range $1 \le x < lg(\beta)$. The $mask$ variable is used to extract the upper $d$ bits to form the carry for the next iteration. This algorithm is loosely measured as a $O(2n)$ algorithm which means that if the input is $n$-digits that it takes $2n$ ``time'' to complete. It is possible to optimize this algorithm down to a $O(n)$ algorithm at a cost of making the algorithm slightly harder to follow. EXAM,bn_mp_mul_2d.c The shifting is performed in--place which means the first step (line @24,a != c@) is to copy the input to the destination. We avoid calling mp\_copy() by making sure the mp\_ints are different. The destination then has to be grown (line @31,grow@) to accomodate the result. If the shift count $b$ is larger than $lg(\beta)$ then a call to mp\_lshd() is used to handle all of the multiples of $lg(\beta)$. Leaving only a remaining shift of $lg(\beta) - 1$ or fewer bits left. Inside the actual shift loop (lines @45,if@ to @76,}@) we make use of pre--computed values $shift$ and $mask$. These are used to extract the carry bit(s) to pass into the next iteration of the loop. The $r$ and $rr$ variables form a chain between consecutive iterations to propagate the carry. \subsection{Division by Power of Two} \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_div\_2d}. \\ \textbf{Input}. One mp\_int $a$ and an integer $b$ \\ \textbf{Output}. $c \leftarrow \lfloor a / 2^b \rfloor, d \leftarrow a \mbox{ (mod }2^b\mbox{)}$. \\ \hline \\ 1. If $b \le 0$ then do \\ \hspace{3mm}1.1 $c \leftarrow a$ (\textit{mp\_copy}) \\ \hspace{3mm}1.2 $d \leftarrow 0$ (\textit{mp\_zero}) \\ \hspace{3mm}1.3 Return(\textit{MP\_OKAY}). \\ 2. $c \leftarrow a$ \\ 3. $d \leftarrow a \mbox{ (mod }2^b\mbox{)}$ (\textit{mp\_mod\_2d}) \\ 4. If $b \ge lg(\beta)$ then do \\ \hspace{3mm}4.1 $c \leftarrow \lfloor c/\beta^{\lfloor b/lg(\beta) \rfloor} \rfloor$ (\textit{mp\_rshd}). \\ 5. $k \leftarrow b \mbox{ (mod }lg(\beta)\mbox{)}$ \\ 6. If $k \ne 0$ then do \\ \hspace{3mm}6.1 $mask \leftarrow 2^k$ \\ \hspace{3mm}6.2 $r \leftarrow 0$ \\ \hspace{3mm}6.3 for $n$ from $c.used - 1$ to $0$ do \\ \hspace{6mm}6.3.1 $rr \leftarrow c_n \mbox{ (mod }mask\mbox{)}$ \\ \hspace{6mm}6.3.2 $c_n \leftarrow (c_n >> k) + (r << (lg(\beta) - k))$ \\ \hspace{6mm}6.3.3 $r \leftarrow rr$ \\ 7. Clamp excess digits of $c$. (\textit{mp\_clamp}) \\ 8. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_div\_2d} \end{figure} \textbf{Algorithm mp\_div\_2d.} This algorithm will divide an input $a$ by $2^b$ and produce the quotient and remainder. The algorithm is designed much like algorithm mp\_mul\_2d by first using whole digit shifts then single precision shifts. This algorithm will also produce the remainder of the division by using algorithm mp\_mod\_2d. EXAM,bn_mp_div_2d.c The implementation of algorithm mp\_div\_2d is slightly different than the algorithm specifies. The remainder $d$ may be optionally ignored by passing \textbf{NULL} as the pointer to the mp\_int variable. The temporary mp\_int variable $t$ is used to hold the result of the remainder operation until the end. This allows $d$ and $a$ to represent the same mp\_int without modifying $a$ before the quotient is obtained. The remainder of the source code is essentially the same as the source code for mp\_mul\_2d. The only significant difference is the direction of the shifts. \subsection{Remainder of Division by Power of Two} The last algorithm in the series of polynomial basis power of two algorithms is calculating the remainder of division by $2^b$. This algorithm benefits from the fact that in twos complement arithmetic $a \mbox{ (mod }2^b\mbox{)}$ is the same as $a$ AND $2^b - 1$. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_mod\_2d}. \\ \textbf{Input}. One mp\_int $a$ and an integer $b$ \\ \textbf{Output}. $c \leftarrow a \mbox{ (mod }2^b\mbox{)}$. \\ \hline \\ 1. If $b \le 0$ then do \\ \hspace{3mm}1.1 $c \leftarrow 0$ (\textit{mp\_zero}) \\ \hspace{3mm}1.2 Return(\textit{MP\_OKAY}). \\ 2. If $b > a.used \cdot lg(\beta)$ then do \\ \hspace{3mm}2.1 $c \leftarrow a$ (\textit{mp\_copy}) \\ \hspace{3mm}2.2 Return the result of step 2.1. \\ 3. $c \leftarrow a$ \\ 4. If step 3 failed return(\textit{MP\_MEM}). \\ 5. for $n$ from $\lceil b / lg(\beta) \rceil$ to $c.used$ do \\ \hspace{3mm}5.1 $c_n \leftarrow 0$ \\ 6. $k \leftarrow b \mbox{ (mod }lg(\beta)\mbox{)}$ \\ 7. $c_{\lfloor b / lg(\beta) \rfloor} \leftarrow c_{\lfloor b / lg(\beta) \rfloor} \mbox{ (mod }2^{k}\mbox{)}$. \\ 8. Clamp excess digits of $c$. (\textit{mp\_clamp}) \\ 9. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_mod\_2d} \end{figure} \textbf{Algorithm mp\_mod\_2d.} This algorithm will quickly calculate the value of $a \mbox{ (mod }2^b\mbox{)}$. First if $b$ is less than or equal to zero the result is set to zero. If $b$ is greater than the number of bits in $a$ then it simply copies $a$ to $c$ and returns. Otherwise, $a$ is copied to $b$, leading digits are removed and the remaining leading digit is trimed to the exact bit count. EXAM,bn_mp_mod_2d.c We first avoid cases of $b \le 0$ by simply mp\_zero()'ing the destination in such cases. Next if $2^b$ is larger than the input we just mp\_copy() the input and return right away. After this point we know we must actually perform some work to produce the remainder. Recalling that reducing modulo $2^k$ and a binary ``and'' with $2^k - 1$ are numerically equivalent we can quickly reduce the number. First we zero any digits above the last digit in $2^b$ (line @41,for@). Next we reduce the leading digit of both (line @45,&=@) and then mp\_clamp(). \section*{Exercises} \begin{tabular}{cl} $\left [ 3 \right ] $ & Devise an algorithm that performs $a \cdot 2^b$ for generic values of $b$ \\ & in $O(n)$ time. \\ &\\ $\left [ 3 \right ] $ & Devise an efficient algorithm to multiply by small low hamming \\ & weight values such as $3$, $5$ and $9$. Extend it to handle all values \\ & upto $64$ with a hamming weight less than three. \\ &\\ $\left [ 2 \right ] $ & Modify the preceding algorithm to handle values of the form \\ & $2^k - 1$ as well. \\ &\\ $\left [ 3 \right ] $ & Using only algorithms mp\_mul\_2, mp\_div\_2 and mp\_add create an \\ & algorithm to multiply two integers in roughly $O(2n^2)$ time for \\ & any $n$-bit input. Note that the time of addition is ignored in the \\ & calculation. \\ & \\ $\left [ 5 \right ] $ & Improve the previous algorithm to have a working time of at most \\ & $O \left (2^{(k-1)}n + \left ({2n^2 \over k} \right ) \right )$ for an appropriate choice of $k$. Again ignore \\ & the cost of addition. \\ & \\ $\left [ 2 \right ] $ & Devise a chart to find optimal values of $k$ for the previous problem \\ & for $n = 64 \ldots 1024$ in steps of $64$. \\ & \\ $\left [ 2 \right ] $ & Using only algorithms mp\_abs and mp\_sub devise another method for \\ & calculating the result of a signed comparison. \\ & \end{tabular} \chapter{Multiplication and Squaring} \section{The Multipliers} For most number theoretic problems including certain public key cryptographic algorithms, the ``multipliers'' form the most important subset of algorithms of any multiple precision integer package. The set of multiplier algorithms include integer multiplication, squaring and modular reduction where in each of the algorithms single precision multiplication is the dominant operation performed. This chapter will discuss integer multiplication and squaring, leaving modular reductions for the subsequent chapter. The importance of the multiplier algorithms is for the most part driven by the fact that certain popular public key algorithms are based on modular exponentiation, that is computing $d \equiv a^b \mbox{ (mod }c\mbox{)}$ for some arbitrary choice of $a$, $b$, $c$ and $d$. During a modular exponentiation the majority\footnote{Roughly speaking a modular exponentiation will spend about 40\% of the time performing modular reductions, 35\% of the time performing squaring and 25\% of the time performing multiplications.} of the processor time is spent performing single precision multiplications. For centuries general purpose multiplication has required a lengthly $O(n^2)$ process, whereby each digit of one multiplicand has to be multiplied against every digit of the other multiplicand. Traditional long-hand multiplication is based on this process; while the techniques can differ the overall algorithm used is essentially the same. Only ``recently'' have faster algorithms been studied. First Karatsuba multiplication was discovered in 1962. This algorithm can multiply two numbers with considerably fewer single precision multiplications when compared to the long-hand approach. This technique led to the discovery of polynomial basis algorithms (\textit{good reference?}) and subquently Fourier Transform based solutions. \section{Multiplication} \subsection{The Baseline Multiplication} \label{sec:basemult} \index{baseline multiplication} Computing the product of two integers in software can be achieved using a trivial adaptation of the standard $O(n^2)$ long-hand multiplication algorithm that school children are taught. The algorithm is considered an $O(n^2)$ algorithm since for two $n$-digit inputs $n^2$ single precision multiplications are required. More specifically for a $m$ and $n$ digit input $m \cdot n$ single precision multiplications are required. To simplify most discussions, it will be assumed that the inputs have comparable number of digits. The ``baseline multiplication'' algorithm is designed to act as the ``catch-all'' algorithm, only to be used when the faster algorithms cannot be used. This algorithm does not use any particularly interesting optimizations and should ideally be avoided if possible. One important facet of this algorithm, is that it has been modified to only produce a certain amount of output digits as resolution. The importance of this modification will become evident during the discussion of Barrett modular reduction. Recall that for a $n$ and $m$ digit input the product will be at most $n + m$ digits. Therefore, this algorithm can be reduced to a full multiplier by having it produce $n + m$ digits of the product. Recall from ~GAMMA~ the definition of $\gamma$ as the number of bits in the type \textbf{mp\_digit}. We shall now extend the variable set to include $\alpha$ which shall represent the number of bits in the type \textbf{mp\_word}. This implies that $2^{\alpha} > 2 \cdot \beta^2$. The constant $\delta = 2^{\alpha - 2lg(\beta)}$ will represent the maximal weight of any column in a product (\textit{see ~COMBA~ for more information}). \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{s\_mp\_mul\_digs}. \\ \textbf{Input}. mp\_int $a$, mp\_int $b$ and an integer $digs$ \\ \textbf{Output}. $c \leftarrow \vert a \vert \cdot \vert b \vert \mbox{ (mod }\beta^{digs}\mbox{)}$. \\ \hline \\ 1. If min$(a.used, b.used) < \delta$ then do \\ \hspace{3mm}1.1 Calculate $c = \vert a \vert \cdot \vert b \vert$ by the Comba method (\textit{see algorithm~\ref{fig:COMBAMULT}}). \\ \hspace{3mm}1.2 Return the result of step 1.1 \\ \\ Allocate and initialize a temporary mp\_int. \\ 2. Init $t$ to be of size $digs$ \\ 3. If step 2 failed return(\textit{MP\_MEM}). \\ 4. $t.used \leftarrow digs$ \\ \\ Compute the product. \\ 5. for $ix$ from $0$ to $a.used - 1$ do \\ \hspace{3mm}5.1 $u \leftarrow 0$ \\ \hspace{3mm}5.2 $pb \leftarrow \mbox{min}(b.used, digs - ix)$ \\ \hspace{3mm}5.3 If $pb < 1$ then goto step 6. \\ \hspace{3mm}5.4 for $iy$ from $0$ to $pb - 1$ do \\ \hspace{6mm}5.4.1 $\hat r \leftarrow t_{iy + ix} + a_{ix} \cdot b_{iy} + u$ \\ \hspace{6mm}5.4.2 $t_{iy + ix} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ \hspace{6mm}5.4.3 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ \hspace{3mm}5.5 if $ix + pb < digs$ then do \\ \hspace{6mm}5.5.1 $t_{ix + pb} \leftarrow u$ \\ 6. Clamp excess digits of $t$. \\ 7. Swap $c$ with $t$ \\ 8. Clear $t$ \\ 9. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm s\_mp\_mul\_digs} \end{figure} \textbf{Algorithm s\_mp\_mul\_digs.} This algorithm computes the unsigned product of two inputs $a$ and $b$, limited to an output precision of $digs$ digits. While it may seem a bit awkward to modify the function from its simple $O(n^2)$ description, the usefulness of partial multipliers will arise in a subsequent algorithm. The algorithm is loosely based on algorithm 14.12 from \cite[pp. 595]{HAC} and is similar to Algorithm M of Knuth \cite[pp. 268]{TAOCPV2}. Algorithm s\_mp\_mul\_digs differs from these cited references since it can produce a variable output precision regardless of the precision of the inputs. The first thing this algorithm checks for is whether a Comba multiplier can be used instead. If the minimum digit count of either input is less than $\delta$, then the Comba method may be used instead. After the Comba method is ruled out, the baseline algorithm begins. A temporary mp\_int variable $t$ is used to hold the intermediate result of the product. This allows the algorithm to be used to compute products when either $a = c$ or $b = c$ without overwriting the inputs. All of step 5 is the infamous $O(n^2)$ multiplication loop slightly modified to only produce upto $digs$ digits of output. The $pb$ variable is given the count of digits to read from $b$ inside the nested loop. If $pb \le 1$ then no more output digits can be produced and the algorithm will exit the loop. The best way to think of the loops are as a series of $pb \times 1$ multiplications. That is, in each pass of the innermost loop $a_{ix}$ is multiplied against $b$ and the result is added (\textit{with an appropriate shift}) to $t$. For example, consider multiplying $576$ by $241$. That is equivalent to computing $10^0(1)(576) + 10^1(4)(576) + 10^2(2)(576)$ which is best visualized in the following table. \begin{figure}[here] \begin{center} \begin{tabular}{|c|c|c|c|c|c|l|} \hline && & 5 & 7 & 6 & \\ \hline $\times$&& & 2 & 4 & 1 & \\ \hline &&&&&&\\ && & 5 & 7 & 6 & $10^0(1)(576)$ \\ &2 & 3 & 6 & 1 & 6 & $10^1(4)(576) + 10^0(1)(576)$ \\ 1 & 3 & 8 & 8 & 1 & 6 & $10^2(2)(576) + 10^1(4)(576) + 10^0(1)(576)$ \\ \hline \end{tabular} \end{center} \caption{Long-Hand Multiplication Diagram} \end{figure} Each row of the product is added to the result after being shifted to the left (\textit{multiplied by a power of the radix}) by the appropriate count. That is in pass $ix$ of the inner loop the product is added starting at the $ix$'th digit of the reult. Step 5.4.1 introduces the hat symbol (\textit{e.g. $\hat r$}) which represents a double precision variable. The multiplication on that step is assumed to be a double wide output single precision multiplication. That is, two single precision variables are multiplied to produce a double precision result. The step is somewhat optimized from a long-hand multiplication algorithm because the carry from the addition in step 5.4.1 is propagated through the nested loop. If the carry was not propagated immediately it would overflow the single precision digit $t_{ix+iy}$ and the result would be lost. At step 5.5 the nested loop is finished and any carry that was left over should be forwarded. The carry does not have to be added to the $ix+pb$'th digit since that digit is assumed to be zero at this point. However, if $ix + pb \ge digs$ the carry is not set as it would make the result exceed the precision requested. EXAM,bn_s_mp_mul_digs.c First we determine (line @30,if@) if the Comba method can be used first since it's faster. The conditions for sing the Comba routine are that min$(a.used, b.used) < \delta$ and the number of digits of output is less than \textbf{MP\_WARRAY}. This new constant is used to control the stack usage in the Comba routines. By default it is set to $\delta$ but can be reduced when memory is at a premium. If we cannot use the Comba method we proceed to setup the baseline routine. We allocate the the destination mp\_int $t$ (line @36,init@) to the exact size of the output to avoid further re--allocations. At this point we now begin the $O(n^2)$ loop. This implementation of multiplication has the caveat that it can be trimmed to only produce a variable number of digits as output. In each iteration of the outer loop the $pb$ variable is set (line @48,MIN@) to the maximum number of inner loop iterations. Inside the inner loop we calculate $\hat r$ as the mp\_word product of the two mp\_digits and the addition of the carry from the previous iteration. A particularly important observation is that most modern optimizing C compilers (GCC for instance) can recognize that a $N \times N \rightarrow 2N$ multiplication is all that is required for the product. In x86 terms for example, this means using the MUL instruction. Each digit of the product is stored in turn (line @68,tmpt@) and the carry propagated (line @71,>>@) to the next iteration. \subsection{Faster Multiplication by the ``Comba'' Method} MARK,COMBA One of the huge drawbacks of the ``baseline'' algorithms is that at the $O(n^2)$ level the carry must be computed and propagated upwards. This makes the nested loop very sequential and hard to unroll and implement in parallel. The ``Comba'' \cite{COMBA} method is named after little known (\textit{in cryptographic venues}) Paul G. Comba who described a method of implementing fast multipliers that do not require nested carry fixup operations. As an interesting aside it seems that Paul Barrett describes a similar technique in his 1986 paper \cite{BARRETT} written five years before. At the heart of the Comba technique is once again the long-hand algorithm. Except in this case a slight twist is placed on how the columns of the result are produced. In the standard long-hand algorithm rows of products are produced then added together to form the final result. In the baseline algorithm the columns are added together after each iteration to get the result instantaneously. In the Comba algorithm the columns of the result are produced entirely independently of each other. That is at the $O(n^2)$ level a simple multiplication and addition step is performed. The carries of the columns are propagated after the nested loop to reduce the amount of work requiored. Succintly the first step of the algorithm is to compute the product vector $\vec x$ as follows. \begin{equation} \vec x_n = \sum_{i+j = n} a_ib_j, \forall n \in \lbrace 0, 1, 2, \ldots, i + j \rbrace \end{equation} Where $\vec x_n$ is the $n'th$ column of the output vector. Consider the following example which computes the vector $\vec x$ for the multiplication of $576$ and $241$. \newpage\begin{figure}[here] \begin{small} \begin{center} \begin{tabular}{|c|c|c|c|c|c|} \hline & & 5 & 7 & 6 & First Input\\ \hline $\times$ & & 2 & 4 & 1 & Second Input\\ \hline & & $1 \cdot 5 = 5$ & $1 \cdot 7 = 7$ & $1 \cdot 6 = 6$ & First pass \\ & $4 \cdot 5 = 20$ & $4 \cdot 7+5=33$ & $4 \cdot 6+7=31$ & 6 & Second pass \\ $2 \cdot 5 = 10$ & $2 \cdot 7 + 20 = 34$ & $2 \cdot 6+33=45$ & 31 & 6 & Third pass \\ \hline 10 & 34 & 45 & 31 & 6 & Final Result \\ \hline \end{tabular} \end{center} \end{small} \caption{Comba Multiplication Diagram} \end{figure} At this point the vector $x = \left < 10, 34, 45, 31, 6 \right >$ is the result of the first step of the Comba multipler. Now the columns must be fixed by propagating the carry upwards. The resultant vector will have one extra dimension over the input vector which is congruent to adding a leading zero digit. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{Comba Fixup}. \\ \textbf{Input}. Vector $\vec x$ of dimension $k$ \\ \textbf{Output}. Vector $\vec x$ such that the carries have been propagated. \\ \hline \\ 1. for $n$ from $0$ to $k - 1$ do \\ \hspace{3mm}1.1 $\vec x_{n+1} \leftarrow \vec x_{n+1} + \lfloor \vec x_{n}/\beta \rfloor$ \\ \hspace{3mm}1.2 $\vec x_{n} \leftarrow \vec x_{n} \mbox{ (mod }\beta\mbox{)}$ \\ 2. Return($\vec x$). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm Comba Fixup} \end{figure} With that algorithm and $k = 5$ and $\beta = 10$ the following vector is produced $\vec x= \left < 1, 3, 8, 8, 1, 6 \right >$. In this case $241 \cdot 576$ is in fact $138816$ and the procedure succeeded. If the algorithm is correct and as will be demonstrated shortly more efficient than the baseline algorithm why not simply always use this algorithm? \subsubsection{Column Weight.} At the nested $O(n^2)$ level the Comba method adds the product of two single precision variables to each column of the output independently. A serious obstacle is if the carry is lost, due to lack of precision before the algorithm has a chance to fix the carries. For example, in the multiplication of two three-digit numbers the third column of output will be the sum of three single precision multiplications. If the precision of the accumulator for the output digits is less then $3 \cdot (\beta - 1)^2$ then an overflow can occur and the carry information will be lost. For any $m$ and $n$ digit inputs the maximum weight of any column is min$(m, n)$ which is fairly obvious. The maximum number of terms in any column of a product is known as the ``column weight'' and strictly governs when the algorithm can be used. Recall from earlier that a double precision type has $\alpha$ bits of resolution and a single precision digit has $lg(\beta)$ bits of precision. Given these two quantities we must not violate the following \begin{equation} k \cdot \left (\beta - 1 \right )^2 < 2^{\alpha} \end{equation} Which reduces to \begin{equation} k \cdot \left ( \beta^2 - 2\beta + 1 \right ) < 2^{\alpha} \end{equation} Let $\rho = lg(\beta)$ represent the number of bits in a single precision digit. By further re-arrangement of the equation the final solution is found. \begin{equation} k < {{2^{\alpha}} \over {\left (2^{2\rho} - 2^{\rho + 1} + 1 \right )}} \end{equation} The defaults for LibTomMath are $\beta = 2^{28}$ and $\alpha = 2^{64}$ which means that $k$ is bounded by $k < 257$. In this configuration the smaller input may not have more than $256$ digits if the Comba method is to be used. This is quite satisfactory for most applications since $256$ digits would allow for numbers in the range of $0 \le x < 2^{7168}$ which, is much larger than most public key cryptographic algorithms require. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{fast\_s\_mp\_mul\_digs}. \\ \textbf{Input}. mp\_int $a$, mp\_int $b$ and an integer $digs$ \\ \textbf{Output}. $c \leftarrow \vert a \vert \cdot \vert b \vert \mbox{ (mod }\beta^{digs}\mbox{)}$. \\ \hline \\ Place an array of \textbf{MP\_WARRAY} single precision digits named $W$ on the stack. \\ 1. If $c.alloc < digs$ then grow $c$ to $digs$ digits. (\textit{mp\_grow}) \\ 2. If step 1 failed return(\textit{MP\_MEM}).\\ \\ 3. $pa \leftarrow \mbox{MIN}(digs, a.used + b.used)$ \\ \\ 4. $\_ \hat W \leftarrow 0$ \\ 5. for $ix$ from 0 to $pa - 1$ do \\ \hspace{3mm}5.1 $ty \leftarrow \mbox{MIN}(b.used - 1, ix)$ \\ \hspace{3mm}5.2 $tx \leftarrow ix - ty$ \\ \hspace{3mm}5.3 $iy \leftarrow \mbox{MIN}(a.used - tx, ty + 1)$ \\ \hspace{3mm}5.4 for $iz$ from 0 to $iy - 1$ do \\ \hspace{6mm}5.4.1 $\_ \hat W \leftarrow \_ \hat W + a_{tx+iy}b_{ty-iy}$ \\ \hspace{3mm}5.5 $W_{ix} \leftarrow \_ \hat W (\mbox{mod }\beta)$\\ \hspace{3mm}5.6 $\_ \hat W \leftarrow \lfloor \_ \hat W / \beta \rfloor$ \\ 6. $W_{pa} \leftarrow \_ \hat W (\mbox{mod }\beta)$ \\ \\ 7. $oldused \leftarrow c.used$ \\ 8. $c.used \leftarrow digs$ \\ 9. for $ix$ from $0$ to $pa$ do \\ \hspace{3mm}9.1 $c_{ix} \leftarrow W_{ix}$ \\ 10. for $ix$ from $pa + 1$ to $oldused - 1$ do \\ \hspace{3mm}10.1 $c_{ix} \leftarrow 0$ \\ \\ 11. Clamp $c$. \\ 12. Return MP\_OKAY. \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm fast\_s\_mp\_mul\_digs} \label{fig:COMBAMULT} \end{figure} \textbf{Algorithm fast\_s\_mp\_mul\_digs.} This algorithm performs the unsigned multiplication of $a$ and $b$ using the Comba method limited to $digs$ digits of precision. The outer loop of this algorithm is more complicated than that of the baseline multiplier. This is because on the inside of the loop we want to produce one column per pass. This allows the accumulator $\_ \hat W$ to be placed in CPU registers and reduce the memory bandwidth to two \textbf{mp\_digit} reads per iteration. The $ty$ variable is set to the minimum count of $ix$ or the number of digits in $b$. That way if $a$ has more digits than $b$ this will be limited to $b.used - 1$. The $tx$ variable is set to the to the distance past $b.used$ the variable $ix$ is. This is used for the immediately subsequent statement where we find $iy$. The variable $iy$ is the minimum digits we can read from either $a$ or $b$ before running out. Computing one column at a time means we have to scan one integer upwards and the other downwards. $a$ starts at $tx$ and $b$ starts at $ty$. In each pass we are producing the $ix$'th output column and we note that $tx + ty = ix$. As we move $tx$ upwards we have to move $ty$ downards so the equality remains valid. The $iy$ variable is the number of iterations until $tx \ge a.used$ or $ty < 0$ occurs. After every inner pass we store the lower half of the accumulator into $W_{ix}$ and then propagate the carry of the accumulator into the next round by dividing $\_ \hat W$ by $\beta$. To measure the benefits of the Comba method over the baseline method consider the number of operations that are required. If the cost in terms of time of a multiply and addition is $p$ and the cost of a carry propagation is $q$ then a baseline multiplication would require $O \left ((p + q)n^2 \right )$ time to multiply two $n$-digit numbers. The Comba method requires only $O(pn^2 + qn)$ time, however in practice, the speed increase is actually much more. With $O(n)$ space the algorithm can be reduced to $O(pn + qn)$ time by implementing the $n$ multiply and addition operations in the nested loop in parallel. EXAM,bn_fast_s_mp_mul_digs.c As per the pseudo--code we first calculate $pa$ (line @47,MIN@) as the number of digits to output. Next we begin the outer loop to produce the individual columns of the product. We use the two aliases $tmpx$ and $tmpy$ (lines @61,tmpx@, @62,tmpy@) to point inside the two multiplicands quickly. The inner loop (lines @70,for@ to @72,}@) of this implementation is where the tradeoff come into play. Originally this comba implementation was ``row--major'' which means it adds to each of the columns in each pass. After the outer loop it would then fix the carries. This was very fast except it had an annoying drawback. You had to read a mp\_word and two mp\_digits and write one mp\_word per iteration. On processors such as the Athlon XP and P4 this did not matter much since the cache bandwidth is very high and it can keep the ALU fed with data. It did, however, matter on older and embedded cpus where cache is often slower and also often doesn't exist. This new algorithm only performs two reads per iteration under the assumption that the compiler has aliased $\_ \hat W$ to a CPU register. After the inner loop we store the current accumulator in $W$ and shift $\_ \hat W$ (lines @75,W[ix]@, @78,>>@) to forward it as a carry for the next pass. After the outer loop we use the final carry (line @82,W[ix]@) as the last digit of the product. \subsection{Polynomial Basis Multiplication} To break the $O(n^2)$ barrier in multiplication requires a completely different look at integer multiplication. In the following algorithms the use of polynomial basis representation for two integers $a$ and $b$ as $f(x) = \sum_{i=0}^{n} a_i x^i$ and $g(x) = \sum_{i=0}^{n} b_i x^i$ respectively, is required. In this system both $f(x)$ and $g(x)$ have $n + 1$ terms and are of the $n$'th degree. The product $a \cdot b \equiv f(x)g(x)$ is the polynomial $W(x) = \sum_{i=0}^{2n} w_i x^i$. The coefficients $w_i$ will directly yield the desired product when $\beta$ is substituted for $x$. The direct solution to solve for the $2n + 1$ coefficients requires $O(n^2)$ time and would in practice be slower than the Comba technique. However, numerical analysis theory indicates that only $2n + 1$ distinct points in $W(x)$ are required to determine the values of the $2n + 1$ unknown coefficients. This means by finding $\zeta_y = W(y)$ for $2n + 1$ small values of $y$ the coefficients of $W(x)$ can be found with Gaussian elimination. This technique is also occasionally refered to as the \textit{interpolation technique} (\textit{references please...}) since in effect an interpolation based on $2n + 1$ points will yield a polynomial equivalent to $W(x)$. The coefficients of the polynomial $W(x)$ are unknown which makes finding $W(y)$ for any value of $y$ impossible. However, since $W(x) = f(x)g(x)$ the equivalent $\zeta_y = f(y) g(y)$ can be used in its place. The benefit of this technique stems from the fact that $f(y)$ and $g(y)$ are much smaller than either $a$ or $b$ respectively. As a result finding the $2n + 1$ relations required by multiplying $f(y)g(y)$ involves multiplying integers that are much smaller than either of the inputs. When picking points to gather relations there are always three obvious points to choose, $y = 0, 1$ and $ \infty$. The $\zeta_0$ term is simply the product $W(0) = w_0 = a_0 \cdot b_0$. The $\zeta_1$ term is the product $W(1) = \left (\sum_{i = 0}^{n} a_i \right ) \left (\sum_{i = 0}^{n} b_i \right )$. The third point $\zeta_{\infty}$ is less obvious but rather simple to explain. The $2n + 1$'th coefficient of $W(x)$ is numerically equivalent to the most significant column in an integer multiplication. The point at $\infty$ is used symbolically to represent the most significant column, that is $W(\infty) = w_{2n} = a_nb_n$. Note that the points at $y = 0$ and $\infty$ yield the coefficients $w_0$ and $w_{2n}$ directly. If more points are required they should be of small values and powers of two such as $2^q$ and the related \textit{mirror points} $\left (2^q \right )^{2n} \cdot \zeta_{2^{-q}}$ for small values of $q$. The term ``mirror point'' stems from the fact that $\left (2^q \right )^{2n} \cdot \zeta_{2^{-q}}$ can be calculated in the exact opposite fashion as $\zeta_{2^q}$. For example, when $n = 2$ and $q = 1$ then following two equations are equivalent to the point $\zeta_{2}$ and its mirror. \begin{eqnarray} \zeta_{2} = f(2)g(2) = (4a_2 + 2a_1 + a_0)(4b_2 + 2b_1 + b_0) \nonumber \\ 16 \cdot \zeta_{1 \over 2} = 4f({1\over 2}) \cdot 4g({1 \over 2}) = (a_2 + 2a_1 + 4a_0)(b_2 + 2b_1 + 4b_0) \end{eqnarray} Using such points will allow the values of $f(y)$ and $g(y)$ to be independently calculated using only left shifts. For example, when $n = 2$ the polynomial $f(2^q)$ is equal to $2^q((2^qa_2) + a_1) + a_0$. This technique of polynomial representation is known as Horner's method. As a general rule of the algorithm when the inputs are split into $n$ parts each there are $2n - 1$ multiplications. Each multiplication is of multiplicands that have $n$ times fewer digits than the inputs. The asymptotic running time of this algorithm is $O \left ( k^{lg_n(2n - 1)} \right )$ for $k$ digit inputs (\textit{assuming they have the same number of digits}). Figure~\ref{fig:exponent} summarizes the exponents for various values of $n$. \begin{figure} \begin{center} \begin{tabular}{|c|c|c|} \hline \textbf{Split into $n$ Parts} & \textbf{Exponent} & \textbf{Notes}\\ \hline $2$ & $1.584962501$ & This is Karatsuba Multiplication. \\ \hline $3$ & $1.464973520$ & This is Toom-Cook Multiplication. \\ \hline $4$ & $1.403677461$ &\\ \hline $5$ & $1.365212389$ &\\ \hline $10$ & $1.278753601$ &\\ \hline $100$ & $1.149426538$ &\\ \hline $1000$ & $1.100270931$ &\\ \hline $10000$ & $1.075252070$ &\\ \hline \end{tabular} \end{center} \caption{Asymptotic Running Time of Polynomial Basis Multiplication} \label{fig:exponent} \end{figure} At first it may seem like a good idea to choose $n = 1000$ since the exponent is approximately $1.1$. However, the overhead of solving for the 2001 terms of $W(x)$ will certainly consume any savings the algorithm could offer for all but exceedingly large numbers. \subsubsection{Cutoff Point} The polynomial basis multiplication algorithms all require fewer single precision multiplications than a straight Comba approach. However, the algorithms incur an overhead (\textit{at the $O(n)$ work level}) since they require a system of equations to be solved. This makes the polynomial basis approach more costly to use with small inputs. Let $m$ represent the number of digits in the multiplicands (\textit{assume both multiplicands have the same number of digits}). There exists a point $y$ such that when $m < y$ the polynomial basis algorithms are more costly than Comba, when $m = y$ they are roughly the same cost and when $m > y$ the Comba methods are slower than the polynomial basis algorithms. The exact location of $y$ depends on several key architectural elements of the computer platform in question. \begin{enumerate} \item The ratio of clock cycles for single precision multiplication versus other simpler operations such as addition, shifting, etc. For example on the AMD Athlon the ratio is roughly $17 : 1$ while on the Intel P4 it is $29 : 1$. The higher the ratio in favour of multiplication the lower the cutoff point $y$ will be. \item The complexity of the linear system of equations (\textit{for the coefficients of $W(x)$}) is. Generally speaking as the number of splits grows the complexity grows substantially. Ideally solving the system will only involve addition, subtraction and shifting of integers. This directly reflects on the ratio previous mentioned. \item To a lesser extent memory bandwidth and function call overheads. Provided the values are in the processor cache this is less of an influence over the cutoff point. \end{enumerate} A clean cutoff point separation occurs when a point $y$ is found such that all of the cutoff point conditions are met. For example, if the point is too low then there will be values of $m$ such that $m > y$ and the Comba method is still faster. Finding the cutoff points is fairly simple when a high resolution timer is available. \subsection{Karatsuba Multiplication} Karatsuba \cite{KARA} multiplication when originally proposed in 1962 was among the first set of algorithms to break the $O(n^2)$ barrier for general purpose multiplication. Given two polynomial basis representations $f(x) = ax + b$ and $g(x) = cx + d$, Karatsuba proved with light algebra \cite{KARAP} that the following polynomial is equivalent to multiplication of the two integers the polynomials represent. \begin{equation} f(x) \cdot g(x) = acx^2 + ((a + b)(c + d) - (ac + bd))x + bd \end{equation} Using the observation that $ac$ and $bd$ could be re-used only three half sized multiplications would be required to produce the product. Applying this algorithm recursively, the work factor becomes $O(n^{lg(3)})$ which is substantially better than the work factor $O(n^2)$ of the Comba technique. It turns out what Karatsuba did not know or at least did not publish was that this is simply polynomial basis multiplication with the points $\zeta_0$, $\zeta_{\infty}$ and $\zeta_{1}$. Consider the resultant system of equations. \begin{center} \begin{tabular}{rcrcrcrc} $\zeta_{0}$ & $=$ & & & & & $w_0$ \\ $\zeta_{1}$ & $=$ & $w_2$ & $+$ & $w_1$ & $+$ & $w_0$ \\ $\zeta_{\infty}$ & $=$ & $w_2$ & & & & \\ \end{tabular} \end{center} By adding the first and last equation to the equation in the middle the term $w_1$ can be isolated and all three coefficients solved for. The simplicity of this system of equations has made Karatsuba fairly popular. In fact the cutoff point is often fairly low\footnote{With LibTomMath 0.18 it is 70 and 109 digits for the Intel P4 and AMD Athlon respectively.} making it an ideal algorithm to speed up certain public key cryptosystems such as RSA and Diffie-Hellman. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_karatsuba\_mul}. \\ \textbf{Input}. mp\_int $a$ and mp\_int $b$ \\ \textbf{Output}. $c \leftarrow \vert a \vert \cdot \vert b \vert$ \\ \hline \\ 1. Init the following mp\_int variables: $x0$, $x1$, $y0$, $y1$, $t1$, $x0y0$, $x1y1$.\\ 2. If step 2 failed then return(\textit{MP\_MEM}). \\ \\ Split the input. e.g. $a = x1 \cdot \beta^B + x0$ \\ 3. $B \leftarrow \mbox{min}(a.used, b.used)/2$ \\ 4. $x0 \leftarrow a \mbox{ (mod }\beta^B\mbox{)}$ (\textit{mp\_mod\_2d}) \\ 5. $y0 \leftarrow b \mbox{ (mod }\beta^B\mbox{)}$ \\ 6. $x1 \leftarrow \lfloor a / \beta^B \rfloor$ (\textit{mp\_rshd}) \\ 7. $y1 \leftarrow \lfloor b / \beta^B \rfloor$ \\ \\ Calculate the three products. \\ 8. $x0y0 \leftarrow x0 \cdot y0$ (\textit{mp\_mul}) \\ 9. $x1y1 \leftarrow x1 \cdot y1$ \\ 10. $t1 \leftarrow x1 + x0$ (\textit{mp\_add}) \\ 11. $x0 \leftarrow y1 + y0$ \\ 12. $t1 \leftarrow t1 \cdot x0$ \\ \\ Calculate the middle term. \\ 13. $x0 \leftarrow x0y0 + x1y1$ \\ 14. $t1 \leftarrow t1 - x0$ (\textit{s\_mp\_sub}) \\ \\ Calculate the final product. \\ 15. $t1 \leftarrow t1 \cdot \beta^B$ (\textit{mp\_lshd}) \\ 16. $x1y1 \leftarrow x1y1 \cdot \beta^{2B}$ \\ 17. $t1 \leftarrow x0y0 + t1$ \\ 18. $c \leftarrow t1 + x1y1$ \\ 19. Clear all of the temporary variables. \\ 20. Return(\textit{MP\_OKAY}).\\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_karatsuba\_mul} \end{figure} \textbf{Algorithm mp\_karatsuba\_mul.} This algorithm computes the unsigned product of two inputs using the Karatsuba multiplication algorithm. It is loosely based on the description from Knuth \cite[pp. 294-295]{TAOCPV2}. \index{radix point} In order to split the two inputs into their respective halves, a suitable \textit{radix point} must be chosen. The radix point chosen must be used for both of the inputs meaning that it must be smaller than the smallest input. Step 3 chooses the radix point $B$ as half of the smallest input \textbf{used} count. After the radix point is chosen the inputs are split into lower and upper halves. Step 4 and 5 compute the lower halves. Step 6 and 7 computer the upper halves. After the halves have been computed the three intermediate half-size products must be computed. Step 8 and 9 compute the trivial products $x0 \cdot y0$ and $x1 \cdot y1$. The mp\_int $x0$ is used as a temporary variable after $x1 + x0$ has been computed. By using $x0$ instead of an additional temporary variable, the algorithm can avoid an addition memory allocation operation. The remaining steps 13 through 18 compute the Karatsuba polynomial through a variety of digit shifting and addition operations. EXAM,bn_mp_karatsuba_mul.c The new coding element in this routine, not seen in previous routines, is the usage of goto statements. The conventional wisdom is that goto statements should be avoided. This is generally true, however when every single function call can fail, it makes sense to handle error recovery with a single piece of code. Lines @61,if@ to @75,if@ handle initializing all of the temporary variables required. Note how each of the if statements goes to a different label in case of failure. This allows the routine to correctly free only the temporaries that have been successfully allocated so far. The temporary variables are all initialized using the mp\_init\_size routine since they are expected to be large. This saves the additional reallocation that would have been necessary. Also $x0$, $x1$, $y0$ and $y1$ have to be able to hold at least their respective number of digits for the next section of code. The first algebraic portion of the algorithm is to split the two inputs into their halves. However, instead of using mp\_mod\_2d and mp\_rshd to extract the halves, the respective code has been placed inline within the body of the function. To initialize the halves, the \textbf{used} and \textbf{sign} members are copied first. The first for loop on line @98,for@ copies the lower halves. Since they are both the same magnitude it is simpler to calculate both lower halves in a single loop. The for loop on lines @104,for@ and @109,for@ calculate the upper halves $x1$ and $y1$ respectively. By inlining the calculation of the halves, the Karatsuba multiplier has a slightly lower overhead and can be used for smaller magnitude inputs. When line @152,err@ is reached, the algorithm has completed succesfully. The ``error status'' variable $err$ is set to \textbf{MP\_OKAY} so that the same code that handles errors can be used to clear the temporary variables and return. \subsection{Toom-Cook $3$-Way Multiplication} Toom-Cook $3$-Way \cite{TOOM} multiplication is essentially the polynomial basis algorithm for $n = 2$ except that the points are chosen such that $\zeta$ is easy to compute and the resulting system of equations easy to reduce. Here, the points $\zeta_{0}$, $16 \cdot \zeta_{1 \over 2}$, $\zeta_1$, $\zeta_2$ and $\zeta_{\infty}$ make up the five required points to solve for the coefficients of the $W(x)$. With the five relations that Toom-Cook specifies, the following system of equations is formed. \begin{center} \begin{tabular}{rcrcrcrcrcr} $\zeta_0$ & $=$ & $0w_4$ & $+$ & $0w_3$ & $+$ & $0w_2$ & $+$ & $0w_1$ & $+$ & $1w_0$ \\ $16 \cdot \zeta_{1 \over 2}$ & $=$ & $1w_4$ & $+$ & $2w_3$ & $+$ & $4w_2$ & $+$ & $8w_1$ & $+$ & $16w_0$ \\ $\zeta_1$ & $=$ & $1w_4$ & $+$ & $1w_3$ & $+$ & $1w_2$ & $+$ & $1w_1$ & $+$ & $1w_0$ \\ $\zeta_2$ & $=$ & $16w_4$ & $+$ & $8w_3$ & $+$ & $4w_2$ & $+$ & $2w_1$ & $+$ & $1w_0$ \\ $\zeta_{\infty}$ & $=$ & $1w_4$ & $+$ & $0w_3$ & $+$ & $0w_2$ & $+$ & $0w_1$ & $+$ & $0w_0$ \\ \end{tabular} \end{center} A trivial solution to this matrix requires $12$ subtractions, two multiplications by a small power of two, two divisions by a small power of two, two divisions by three and one multiplication by three. All of these $19$ sub-operations require less than quadratic time, meaning that the algorithm can be faster than a baseline multiplication. However, the greater complexity of this algorithm places the cutoff point (\textbf{TOOM\_MUL\_CUTOFF}) where Toom-Cook becomes more efficient much higher than the Karatsuba cutoff point. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_toom\_mul}. \\ \textbf{Input}. mp\_int $a$ and mp\_int $b$ \\ \textbf{Output}. $c \leftarrow a \cdot b $ \\ \hline \\ Split $a$ and $b$ into three pieces. E.g. $a = a_2 \beta^{2k} + a_1 \beta^{k} + a_0$ \\ 1. $k \leftarrow \lfloor \mbox{min}(a.used, b.used) / 3 \rfloor$ \\ 2. $a_0 \leftarrow a \mbox{ (mod }\beta^{k}\mbox{)}$ \\ 3. $a_1 \leftarrow \lfloor a / \beta^k \rfloor$, $a_1 \leftarrow a_1 \mbox{ (mod }\beta^{k}\mbox{)}$ \\ 4. $a_2 \leftarrow \lfloor a / \beta^{2k} \rfloor$, $a_2 \leftarrow a_2 \mbox{ (mod }\beta^{k}\mbox{)}$ \\ 5. $b_0 \leftarrow a \mbox{ (mod }\beta^{k}\mbox{)}$ \\ 6. $b_1 \leftarrow \lfloor a / \beta^k \rfloor$, $b_1 \leftarrow b_1 \mbox{ (mod }\beta^{k}\mbox{)}$ \\ 7. $b_2 \leftarrow \lfloor a / \beta^{2k} \rfloor$, $b_2 \leftarrow b_2 \mbox{ (mod }\beta^{k}\mbox{)}$ \\ \\ Find the five equations for $w_0, w_1, ..., w_4$. \\ 8. $w_0 \leftarrow a_0 \cdot b_0$ \\ 9. $w_4 \leftarrow a_2 \cdot b_2$ \\ 10. $tmp_1 \leftarrow 2 \cdot a_0$, $tmp_1 \leftarrow a_1 + tmp_1$, $tmp_1 \leftarrow 2 \cdot tmp_1$, $tmp_1 \leftarrow tmp_1 + a_2$ \\ 11. $tmp_2 \leftarrow 2 \cdot b_0$, $tmp_2 \leftarrow b_1 + tmp_2$, $tmp_2 \leftarrow 2 \cdot tmp_2$, $tmp_2 \leftarrow tmp_2 + b_2$ \\ 12. $w_1 \leftarrow tmp_1 \cdot tmp_2$ \\ 13. $tmp_1 \leftarrow 2 \cdot a_2$, $tmp_1 \leftarrow a_1 + tmp_1$, $tmp_1 \leftarrow 2 \cdot tmp_1$, $tmp_1 \leftarrow tmp_1 + a_0$ \\ 14. $tmp_2 \leftarrow 2 \cdot b_2$, $tmp_2 \leftarrow b_1 + tmp_2$, $tmp_2 \leftarrow 2 \cdot tmp_2$, $tmp_2 \leftarrow tmp_2 + b_0$ \\ 15. $w_3 \leftarrow tmp_1 \cdot tmp_2$ \\ 16. $tmp_1 \leftarrow a_0 + a_1$, $tmp_1 \leftarrow tmp_1 + a_2$, $tmp_2 \leftarrow b_0 + b_1$, $tmp_2 \leftarrow tmp_2 + b_2$ \\ 17. $w_2 \leftarrow tmp_1 \cdot tmp_2$ \\ \\ Continued on the next page.\\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_toom\_mul} \end{figure} \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_toom\_mul} (continued). \\ \textbf{Input}. mp\_int $a$ and mp\_int $b$ \\ \textbf{Output}. $c \leftarrow a \cdot b $ \\ \hline \\ Now solve the system of equations. \\ 18. $w_1 \leftarrow w_4 - w_1$, $w_3 \leftarrow w_3 - w_0$ \\ 19. $w_1 \leftarrow \lfloor w_1 / 2 \rfloor$, $w_3 \leftarrow \lfloor w_3 / 2 \rfloor$ \\ 20. $w_2 \leftarrow w_2 - w_0$, $w_2 \leftarrow w_2 - w_4$ \\ 21. $w_1 \leftarrow w_1 - w_2$, $w_3 \leftarrow w_3 - w_2$ \\ 22. $tmp_1 \leftarrow 8 \cdot w_0$, $w_1 \leftarrow w_1 - tmp_1$, $tmp_1 \leftarrow 8 \cdot w_4$, $w_3 \leftarrow w_3 - tmp_1$ \\ 23. $w_2 \leftarrow 3 \cdot w_2$, $w_2 \leftarrow w_2 - w_1$, $w_2 \leftarrow w_2 - w_3$ \\ 24. $w_1 \leftarrow w_1 - w_2$, $w_3 \leftarrow w_3 - w_2$ \\ 25. $w_1 \leftarrow \lfloor w_1 / 3 \rfloor, w_3 \leftarrow \lfloor w_3 / 3 \rfloor$ \\ \\ Now substitute $\beta^k$ for $x$ by shifting $w_0, w_1, ..., w_4$. \\ 26. for $n$ from $1$ to $4$ do \\ \hspace{3mm}26.1 $w_n \leftarrow w_n \cdot \beta^{nk}$ \\ 27. $c \leftarrow w_0 + w_1$, $c \leftarrow c + w_2$, $c \leftarrow c + w_3$, $c \leftarrow c + w_4$ \\ 28. Return(\textit{MP\_OKAY}) \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_toom\_mul (continued)} \end{figure} \textbf{Algorithm mp\_toom\_mul.} This algorithm computes the product of two mp\_int variables $a$ and $b$ using the Toom-Cook approach. Compared to the Karatsuba multiplication, this algorithm has a lower asymptotic running time of approximately $O(n^{1.464})$ but at an obvious cost in overhead. In this description, several statements have been compounded to save space. The intention is that the statements are executed from left to right across any given step. The two inputs $a$ and $b$ are first split into three $k$-digit integers $a_0, a_1, a_2$ and $b_0, b_1, b_2$ respectively. From these smaller integers the coefficients of the polynomial basis representations $f(x)$ and $g(x)$ are known and can be used to find the relations required. The first two relations $w_0$ and $w_4$ are the points $\zeta_{0}$ and $\zeta_{\infty}$ respectively. The relation $w_1, w_2$ and $w_3$ correspond to the points $16 \cdot \zeta_{1 \over 2}, \zeta_{2}$ and $\zeta_{1}$ respectively. These are found using logical shifts to independently find $f(y)$ and $g(y)$ which significantly speeds up the algorithm. After the five relations $w_0, w_1, \ldots, w_4$ have been computed, the system they represent must be solved in order for the unknown coefficients $w_1, w_2$ and $w_3$ to be isolated. The steps 18 through 25 perform the system reduction required as previously described. Each step of the reduction represents the comparable matrix operation that would be performed had this been performed by pencil. For example, step 18 indicates that row $1$ must be subtracted from row $4$ and simultaneously row $0$ subtracted from row $3$. Once the coeffients have been isolated, the polynomial $W(x) = \sum_{i=0}^{2n} w_i x^i$ is known. By substituting $\beta^{k}$ for $x$, the integer result $a \cdot b$ is produced. EXAM,bn_mp_toom_mul.c The first obvious thing to note is that this algorithm is complicated. The complexity is worth it if you are multiplying very large numbers. For example, a 10,000 digit multiplication takes approximaly 99,282,205 fewer single precision multiplications with Toom--Cook than a Comba or baseline approach (this is a savings of more than 99$\%$). For most ``crypto'' sized numbers this algorithm is not practical as Karatsuba has a much lower cutoff point. First we split $a$ and $b$ into three roughly equal portions. This has been accomplished (lines @40,mod@ to @69,rshd@) with combinations of mp\_rshd() and mp\_mod\_2d() function calls. At this point $a = a2 \cdot \beta^2 + a1 \cdot \beta + a0$ and similiarly for $b$. Next we compute the five points $w0, w1, w2, w3$ and $w4$. Recall that $w0$ and $w4$ can be computed directly from the portions so we get those out of the way first (lines @72,mul@ and @77,mul@). Next we compute $w1, w2$ and $w3$ using Horners method. After this point we solve for the actual values of $w1, w2$ and $w3$ by reducing the $5 \times 5$ system which is relatively straight forward. \subsection{Signed Multiplication} Now that algorithms to handle multiplications of every useful dimensions have been developed, a rather simple finishing touch is required. So far all of the multiplication algorithms have been unsigned multiplications which leaves only a signed multiplication algorithm to be established. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_mul}. \\ \textbf{Input}. mp\_int $a$ and mp\_int $b$ \\ \textbf{Output}. $c \leftarrow a \cdot b$ \\ \hline \\ 1. If $a.sign = b.sign$ then \\ \hspace{3mm}1.1 $sign = MP\_ZPOS$ \\ 2. else \\ \hspace{3mm}2.1 $sign = MP\_ZNEG$ \\ 3. If min$(a.used, b.used) \ge TOOM\_MUL\_CUTOFF$ then \\ \hspace{3mm}3.1 $c \leftarrow a \cdot b$ using algorithm mp\_toom\_mul \\ 4. else if min$(a.used, b.used) \ge KARATSUBA\_MUL\_CUTOFF$ then \\ \hspace{3mm}4.1 $c \leftarrow a \cdot b$ using algorithm mp\_karatsuba\_mul \\ 5. else \\ \hspace{3mm}5.1 $digs \leftarrow a.used + b.used + 1$ \\ \hspace{3mm}5.2 If $digs < MP\_ARRAY$ and min$(a.used, b.used) \le \delta$ then \\ \hspace{6mm}5.2.1 $c \leftarrow a \cdot b \mbox{ (mod }\beta^{digs}\mbox{)}$ using algorithm fast\_s\_mp\_mul\_digs. \\ \hspace{3mm}5.3 else \\ \hspace{6mm}5.3.1 $c \leftarrow a \cdot b \mbox{ (mod }\beta^{digs}\mbox{)}$ using algorithm s\_mp\_mul\_digs. \\ 6. $c.sign \leftarrow sign$ \\ 7. Return the result of the unsigned multiplication performed. \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_mul} \end{figure} \textbf{Algorithm mp\_mul.} This algorithm performs the signed multiplication of two inputs. It will make use of any of the three unsigned multiplication algorithms available when the input is of appropriate size. The \textbf{sign} of the result is not set until the end of the algorithm since algorithm s\_mp\_mul\_digs will clear it. EXAM,bn_mp_mul.c The implementation is rather simplistic and is not particularly noteworthy. Line @22,?@ computes the sign of the result using the ``?'' operator from the C programming language. Line @37,<<@ computes $\delta$ using the fact that $1 << k$ is equal to $2^k$. \section{Squaring} \label{sec:basesquare} Squaring is a special case of multiplication where both multiplicands are equal. At first it may seem like there is no significant optimization available but in fact there is. Consider the multiplication of $576$ against $241$. In total there will be nine single precision multiplications performed which are $1\cdot 6$, $1 \cdot 7$, $1 \cdot 5$, $4 \cdot 6$, $4 \cdot 7$, $4 \cdot 5$, $2 \cdot 6$, $2 \cdot 7$ and $2 \cdot 5$. Now consider the multiplication of $123$ against $123$. The nine products are $3 \cdot 3$, $3 \cdot 2$, $3 \cdot 1$, $2 \cdot 3$, $2 \cdot 2$, $2 \cdot 1$, $1 \cdot 3$, $1 \cdot 2$ and $1 \cdot 1$. On closer inspection some of the products are equivalent. For example, $3 \cdot 2 = 2 \cdot 3$ and $3 \cdot 1 = 1 \cdot 3$. For any $n$-digit input, there are ${{\left (n^2 + n \right)}\over 2}$ possible unique single precision multiplications required compared to the $n^2$ required for multiplication. The following diagram gives an example of the operations required. \begin{figure}[here] \begin{center} \begin{tabular}{ccccc|c} &&1&2&3&\\ $\times$ &&1&2&3&\\ \hline && $3 \cdot 1$ & $3 \cdot 2$ & $3 \cdot 3$ & Row 0\\ & $2 \cdot 1$ & $2 \cdot 2$ & $2 \cdot 3$ && Row 1 \\ $1 \cdot 1$ & $1 \cdot 2$ & $1 \cdot 3$ &&& Row 2 \\ \end{tabular} \end{center} \caption{Squaring Optimization Diagram} \end{figure} MARK,SQUARE Starting from zero and numbering the columns from right to left a very simple pattern becomes obvious. For the purposes of this discussion let $x$ represent the number being squared. The first observation is that in row $k$ the $2k$'th column of the product has a $\left (x_k \right)^2$ term in it. The second observation is that every column $j$ in row $k$ where $j \ne 2k$ is part of a double product. Every non-square term of a column will appear twice hence the name ``double product''. Every odd column is made up entirely of double products. In fact every column is made up of double products and at most one square (\textit{see the exercise section}). The third and final observation is that for row $k$ the first unique non-square term, that is, one that hasn't already appeared in an earlier row, occurs at column $2k + 1$. For example, on row $1$ of the previous squaring, column one is part of the double product with column one from row zero. Column two of row one is a square and column three is the first unique column. \subsection{The Baseline Squaring Algorithm} The baseline squaring algorithm is meant to be a catch-all squaring algorithm. It will handle any of the input sizes that the faster routines will not handle. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{s\_mp\_sqr}. \\ \textbf{Input}. mp\_int $a$ \\ \textbf{Output}. $b \leftarrow a^2$ \\ \hline \\ 1. Init a temporary mp\_int of at least $2 \cdot a.used +1$ digits. (\textit{mp\_init\_size}) \\ 2. If step 1 failed return(\textit{MP\_MEM}) \\ 3. $t.used \leftarrow 2 \cdot a.used + 1$ \\ 4. For $ix$ from 0 to $a.used - 1$ do \\ \hspace{3mm}Calculate the square. \\ \hspace{3mm}4.1 $\hat r \leftarrow t_{2ix} + \left (a_{ix} \right )^2$ \\ \hspace{3mm}4.2 $t_{2ix} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ \hspace{3mm}Calculate the double products after the square. \\ \hspace{3mm}4.3 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ \hspace{3mm}4.4 For $iy$ from $ix + 1$ to $a.used - 1$ do \\ \hspace{6mm}4.4.1 $\hat r \leftarrow 2 \cdot a_{ix}a_{iy} + t_{ix + iy} + u$ \\ \hspace{6mm}4.4.2 $t_{ix + iy} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ \hspace{6mm}4.4.3 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ \hspace{3mm}Set the last carry. \\ \hspace{3mm}4.5 While $u > 0$ do \\ \hspace{6mm}4.5.1 $iy \leftarrow iy + 1$ \\ \hspace{6mm}4.5.2 $\hat r \leftarrow t_{ix + iy} + u$ \\ \hspace{6mm}4.5.3 $t_{ix + iy} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ \hspace{6mm}4.5.4 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ 5. Clamp excess digits of $t$. (\textit{mp\_clamp}) \\ 6. Exchange $b$ and $t$. \\ 7. Clear $t$ (\textit{mp\_clear}) \\ 8. Return(\textit{MP\_OKAY}) \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm s\_mp\_sqr} \end{figure} \textbf{Algorithm s\_mp\_sqr.} This algorithm computes the square of an input using the three observations on squaring. It is based fairly faithfully on algorithm 14.16 of HAC \cite[pp.596-597]{HAC}. Similar to algorithm s\_mp\_mul\_digs, a temporary mp\_int is allocated to hold the result of the squaring. This allows the destination mp\_int to be the same as the source mp\_int. The outer loop of this algorithm begins on step 4. It is best to think of the outer loop as walking down the rows of the partial results, while the inner loop computes the columns of the partial result. Step 4.1 and 4.2 compute the square term for each row, and step 4.3 and 4.4 propagate the carry and compute the double products. The requirement that a mp\_word be able to represent the range $0 \le x < 2 \beta^2$ arises from this very algorithm. The product $a_{ix}a_{iy}$ will lie in the range $0 \le x \le \beta^2 - 2\beta + 1$ which is obviously less than $\beta^2$ meaning that when it is multiplied by two, it can be properly represented by a mp\_word. Similar to algorithm s\_mp\_mul\_digs, after every pass of the inner loop, the destination is correctly set to the sum of all of the partial results calculated so far. This involves expensive carry propagation which will be eliminated in the next algorithm. EXAM,bn_s_mp_sqr.c Inside the outer loop (line @32,for@) the square term is calculated on line @35,r =@. The carry (line @42,>>@) has been extracted from the mp\_word accumulator using a right shift. Aliases for $a_{ix}$ and $t_{ix+iy}$ are initialized (lines @45,tmpx@ and @48,tmpt@) to simplify the inner loop. The doubling is performed using two additions (line @57,r + r@) since it is usually faster than shifting, if not at least as fast. The important observation is that the inner loop does not begin at $iy = 0$ like for multiplication. As such the inner loops get progressively shorter as the algorithm proceeds. This is what leads to the savings compared to using a multiplication to square a number. \subsection{Faster Squaring by the ``Comba'' Method} A major drawback to the baseline method is the requirement for single precision shifting inside the $O(n^2)$ nested loop. Squaring has an additional drawback that it must double the product inside the inner loop as well. As for multiplication, the Comba technique can be used to eliminate these performance hazards. The first obvious solution is to make an array of mp\_words which will hold all of the columns. This will indeed eliminate all of the carry propagation operations from the inner loop. However, the inner product must still be doubled $O(n^2)$ times. The solution stems from the simple fact that $2a + 2b + 2c = 2(a + b + c)$. That is the sum of all of the double products is equal to double the sum of all the products. For example, $ab + ba + ac + ca = 2ab + 2ac = 2(ab + ac)$. However, we cannot simply double all of the columns, since the squares appear only once per row. The most practical solution is to have two mp\_word arrays. One array will hold the squares and the other array will hold the double products. With both arrays the doubling and carry propagation can be moved to a $O(n)$ work level outside the $O(n^2)$ level. In this case, we have an even simpler solution in mind. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{fast\_s\_mp\_sqr}. \\ \textbf{Input}. mp\_int $a$ \\ \textbf{Output}. $b \leftarrow a^2$ \\ \hline \\ Place an array of \textbf{MP\_WARRAY} mp\_digits named $W$ on the stack. \\ 1. If $b.alloc < 2a.used + 1$ then grow $b$ to $2a.used + 1$ digits. (\textit{mp\_grow}). \\ 2. If step 1 failed return(\textit{MP\_MEM}). \\ \\ 3. $pa \leftarrow 2 \cdot a.used$ \\ 4. $\hat W1 \leftarrow 0$ \\ 5. for $ix$ from $0$ to $pa - 1$ do \\ \hspace{3mm}5.1 $\_ \hat W \leftarrow 0$ \\ \hspace{3mm}5.2 $ty \leftarrow \mbox{MIN}(a.used - 1, ix)$ \\ \hspace{3mm}5.3 $tx \leftarrow ix - ty$ \\ \hspace{3mm}5.4 $iy \leftarrow \mbox{MIN}(a.used - tx, ty + 1)$ \\ \hspace{3mm}5.5 $iy \leftarrow \mbox{MIN}(iy, \lfloor \left (ty - tx + 1 \right )/2 \rfloor)$ \\ \hspace{3mm}5.6 for $iz$ from $0$ to $iz - 1$ do \\ \hspace{6mm}5.6.1 $\_ \hat W \leftarrow \_ \hat W + a_{tx + iz}a_{ty - iz}$ \\ \hspace{3mm}5.7 $\_ \hat W \leftarrow 2 \cdot \_ \hat W + \hat W1$ \\ \hspace{3mm}5.8 if $ix$ is even then \\ \hspace{6mm}5.8.1 $\_ \hat W \leftarrow \_ \hat W + \left ( a_{\lfloor ix/2 \rfloor}\right )^2$ \\ \hspace{3mm}5.9 $W_{ix} \leftarrow \_ \hat W (\mbox{mod }\beta)$ \\ \hspace{3mm}5.10 $\hat W1 \leftarrow \lfloor \_ \hat W / \beta \rfloor$ \\ \\ 6. $oldused \leftarrow b.used$ \\ 7. $b.used \leftarrow 2 \cdot a.used$ \\ 8. for $ix$ from $0$ to $pa - 1$ do \\ \hspace{3mm}8.1 $b_{ix} \leftarrow W_{ix}$ \\ 9. for $ix$ from $pa$ to $oldused - 1$ do \\ \hspace{3mm}9.1 $b_{ix} \leftarrow 0$ \\ 10. Clamp excess digits from $b$. (\textit{mp\_clamp}) \\ 11. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm fast\_s\_mp\_sqr} \end{figure} \textbf{Algorithm fast\_s\_mp\_sqr.} This algorithm computes the square of an input using the Comba technique. It is designed to be a replacement for algorithm s\_mp\_sqr when the number of input digits is less than \textbf{MP\_WARRAY} and less than $\delta \over 2$. This algorithm is very similar to the Comba multiplier except with a few key differences we shall make note of. First, we have an accumulator and carry variables $\_ \hat W$ and $\hat W1$ respectively. This is because the inner loop products are to be doubled. If we had added the previous carry in we would be doubling too much. Next we perform an addition MIN condition on $iy$ (step 5.5) to prevent overlapping digits. For example, $a_3 \cdot a_5$ is equal $a_5 \cdot a_3$. Whereas in the multiplication case we would have $5 < a.used$ and $3 \ge 0$ is maintained since we double the sum of the products just outside the inner loop we have to avoid doing this. This is also a good thing since we perform fewer multiplications and the routine ends up being faster. Finally the last difference is the addition of the ``square'' term outside the inner loop (step 5.8). We add in the square only to even outputs and it is the square of the term at the $\lfloor ix / 2 \rfloor$ position. EXAM,bn_fast_s_mp_sqr.c This implementation is essentially a copy of Comba multiplication with the appropriate changes added to make it faster for the special case of squaring. \subsection{Polynomial Basis Squaring} The same algorithm that performs optimal polynomial basis multiplication can be used to perform polynomial basis squaring. The minor exception is that $\zeta_y = f(y)g(y)$ is actually equivalent to $\zeta_y = f(y)^2$ since $f(y) = g(y)$. Instead of performing $2n + 1$ multiplications to find the $\zeta$ relations, squaring operations are performed instead. \subsection{Karatsuba Squaring} Let $f(x) = ax + b$ represent the polynomial basis representation of a number to square. Let $h(x) = \left ( f(x) \right )^2$ represent the square of the polynomial. The Karatsuba equation can be modified to square a number with the following equation. \begin{equation} h(x) = a^2x^2 + \left ((a + b)^2 - (a^2 + b^2) \right )x + b^2 \end{equation} Upon closer inspection this equation only requires the calculation of three half-sized squares: $a^2$, $b^2$ and $(a + b)^2$. As in Karatsuba multiplication, this algorithm can be applied recursively on the input and will achieve an asymptotic running time of $O \left ( n^{lg(3)} \right )$. If the asymptotic times of Karatsuba squaring and multiplication are the same, why not simply use the multiplication algorithm instead? The answer to this arises from the cutoff point for squaring. As in multiplication there exists a cutoff point, at which the time required for a Comba based squaring and a Karatsuba based squaring meet. Due to the overhead inherent in the Karatsuba method, the cutoff point is fairly high. For example, on an AMD Athlon XP processor with $\beta = 2^{28}$, the cutoff point is around 127 digits. Consider squaring a 200 digit number with this technique. It will be split into two 100 digit halves which are subsequently squared. The 100 digit halves will not be squared using Karatsuba, but instead using the faster Comba based squaring algorithm. If Karatsuba multiplication were used instead, the 100 digit numbers would be squared with a slower Comba based multiplication. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_karatsuba\_sqr}. \\ \textbf{Input}. mp\_int $a$ \\ \textbf{Output}. $b \leftarrow a^2$ \\ \hline \\ 1. Initialize the following temporary mp\_ints: $x0$, $x1$, $t1$, $t2$, $x0x0$ and $x1x1$. \\ 2. If any of the initializations on step 1 failed return(\textit{MP\_MEM}). \\ \\ Split the input. e.g. $a = x1\beta^B + x0$ \\ 3. $B \leftarrow \lfloor a.used / 2 \rfloor$ \\ 4. $x0 \leftarrow a \mbox{ (mod }\beta^B\mbox{)}$ (\textit{mp\_mod\_2d}) \\ 5. $x1 \leftarrow \lfloor a / \beta^B \rfloor$ (\textit{mp\_lshd}) \\ \\ Calculate the three squares. \\ 6. $x0x0 \leftarrow x0^2$ (\textit{mp\_sqr}) \\ 7. $x1x1 \leftarrow x1^2$ \\ 8. $t1 \leftarrow x1 + x0$ (\textit{s\_mp\_add}) \\ 9. $t1 \leftarrow t1^2$ \\ \\ Compute the middle term. \\ 10. $t2 \leftarrow x0x0 + x1x1$ (\textit{s\_mp\_add}) \\ 11. $t1 \leftarrow t1 - t2$ \\ \\ Compute final product. \\ 12. $t1 \leftarrow t1\beta^B$ (\textit{mp\_lshd}) \\ 13. $x1x1 \leftarrow x1x1\beta^{2B}$ \\ 14. $t1 \leftarrow t1 + x0x0$ \\ 15. $b \leftarrow t1 + x1x1$ \\ 16. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_karatsuba\_sqr} \end{figure} \textbf{Algorithm mp\_karatsuba\_sqr.} This algorithm computes the square of an input $a$ using the Karatsuba technique. This algorithm is very similar to the Karatsuba based multiplication algorithm with the exception that the three half-size multiplications have been replaced with three half-size squarings. The radix point for squaring is simply placed exactly in the middle of the digits when the input has an odd number of digits, otherwise it is placed just below the middle. Step 3, 4 and 5 compute the two halves required using $B$ as the radix point. The first two squares in steps 6 and 7 are rather straightforward while the last square is of a more compact form. By expanding $\left (x1 + x0 \right )^2$, the $x1^2$ and $x0^2$ terms in the middle disappear, that is $(x0 - x1)^2 - (x1^2 + x0^2) = 2 \cdot x0 \cdot x1$. Now if $5n$ single precision additions and a squaring of $n$-digits is faster than multiplying two $n$-digit numbers and doubling then this method is faster. Assuming no further recursions occur, the difference can be estimated with the following inequality. Let $p$ represent the cost of a single precision addition and $q$ the cost of a single precision multiplication both in terms of time\footnote{Or machine clock cycles.}. \begin{equation} 5pn +{{q(n^2 + n)} \over 2} \le pn + qn^2 \end{equation} For example, on an AMD Athlon XP processor $p = {1 \over 3}$ and $q = 6$. This implies that the following inequality should hold. \begin{center} \begin{tabular}{rcl} ${5n \over 3} + 3n^2 + 3n$ & $<$ & ${n \over 3} + 6n^2$ \\ ${5 \over 3} + 3n + 3$ & $<$ & ${1 \over 3} + 6n$ \\ ${13 \over 9}$ & $<$ & $n$ \\ \end{tabular} \end{center} This results in a cutoff point around $n = 2$. As a consequence it is actually faster to compute the middle term the ``long way'' on processors where multiplication is substantially slower\footnote{On the Athlon there is a 1:17 ratio between clock cycles for addition and multiplication. On the Intel P4 processor this ratio is 1:29 making this method even more beneficial. The only common exception is the ARMv4 processor which has a ratio of 1:7. } than simpler operations such as addition. EXAM,bn_mp_karatsuba_sqr.c This implementation is largely based on the implementation of algorithm mp\_karatsuba\_mul. It uses the same inline style to copy and shift the input into the two halves. The loop from line @54,{@ to line @70,}@ has been modified since only one input exists. The \textbf{used} count of both $x0$ and $x1$ is fixed up and $x0$ is clamped before the calculations begin. At this point $x1$ and $x0$ are valid equivalents to the respective halves as if mp\_rshd and mp\_mod\_2d had been used. By inlining the copy and shift operations the cutoff point for Karatsuba multiplication can be lowered. On the Athlon the cutoff point is exactly at the point where Comba squaring can no longer be used (\textit{128 digits}). On slower processors such as the Intel P4 it is actually below the Comba limit (\textit{at 110 digits}). This routine uses the same error trap coding style as mp\_karatsuba\_sqr. As the temporary variables are initialized errors are redirected to the error trap higher up. If the algorithm completes without error the error code is set to \textbf{MP\_OKAY} and mp\_clears are executed normally. \subsection{Toom-Cook Squaring} The Toom-Cook squaring algorithm mp\_toom\_sqr is heavily based on the algorithm mp\_toom\_mul with the exception that squarings are used instead of multiplication to find the five relations. The reader is encouraged to read the description of the latter algorithm and try to derive their own Toom-Cook squaring algorithm. \subsection{High Level Squaring} \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_sqr}. \\ \textbf{Input}. mp\_int $a$ \\ \textbf{Output}. $b \leftarrow a^2$ \\ \hline \\ 1. If $a.used \ge TOOM\_SQR\_CUTOFF$ then \\ \hspace{3mm}1.1 $b \leftarrow a^2$ using algorithm mp\_toom\_sqr \\ 2. else if $a.used \ge KARATSUBA\_SQR\_CUTOFF$ then \\ \hspace{3mm}2.1 $b \leftarrow a^2$ using algorithm mp\_karatsuba\_sqr \\ 3. else \\ \hspace{3mm}3.1 $digs \leftarrow a.used + b.used + 1$ \\ \hspace{3mm}3.2 If $digs < MP\_ARRAY$ and $a.used \le \delta$ then \\ \hspace{6mm}3.2.1 $b \leftarrow a^2$ using algorithm fast\_s\_mp\_sqr. \\ \hspace{3mm}3.3 else \\ \hspace{6mm}3.3.1 $b \leftarrow a^2$ using algorithm s\_mp\_sqr. \\ 4. $b.sign \leftarrow MP\_ZPOS$ \\ 5. Return the result of the unsigned squaring performed. \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_sqr} \end{figure} \textbf{Algorithm mp\_sqr.} This algorithm computes the square of the input using one of four different algorithms. If the input is very large and has at least \textbf{TOOM\_SQR\_CUTOFF} or \textbf{KARATSUBA\_SQR\_CUTOFF} digits then either the Toom-Cook or the Karatsuba Squaring algorithm is used. If neither of the polynomial basis algorithms should be used then either the Comba or baseline algorithm is used. EXAM,bn_mp_sqr.c \section*{Exercises} \begin{tabular}{cl} $\left [ 3 \right ] $ & Devise an efficient algorithm for selection of the radix point to handle inputs \\ & that have different number of digits in Karatsuba multiplication. \\ & \\ $\left [ 2 \right ] $ & In ~SQUARE~ the fact that every column of a squaring is made up \\ & of double products and at most one square is stated. Prove this statement. \\ & \\ $\left [ 3 \right ] $ & Prove the equation for Karatsuba squaring. \\ & \\ $\left [ 1 \right ] $ & Prove that Karatsuba squaring requires $O \left (n^{lg(3)} \right )$ time. \\ & \\ $\left [ 2 \right ] $ & Determine the minimal ratio between addition and multiplication clock cycles \\ & required for equation $6.7$ to be true. \\ & \\ $\left [ 3 \right ] $ & Implement a threaded version of Comba multiplication (and squaring) where you \\ & compute subsets of the columns in each thread. Determine a cutoff point where \\ & it is effective and add the logic to mp\_mul() and mp\_sqr(). \\ &\\ $\left [ 4 \right ] $ & Same as the previous but also modify the Karatsuba and Toom-Cook. You must \\ & increase the throughput of mp\_exptmod() for random odd moduli in the range \\ & $512 \ldots 4096$ bits significantly ($> 2x$) to complete this challenge. \\ & \\ \end{tabular} \chapter{Modular Reduction} MARK,REDUCTION \section{Basics of Modular Reduction} \index{modular residue} Modular reduction is an operation that arises quite often within public key cryptography algorithms and various number theoretic algorithms, such as factoring. Modular reduction algorithms are the third class of algorithms of the ``multipliers'' set. A number $a$ is said to be \textit{reduced} modulo another number $b$ by finding the remainder of the division $a/b$. Full integer division with remainder is a topic to be covered in~\ref{sec:division}. Modular reduction is equivalent to solving for $r$ in the following equation. $a = bq + r$ where $q = \lfloor a/b \rfloor$. The result $r$ is said to be ``congruent to $a$ modulo $b$'' which is also written as $r \equiv a \mbox{ (mod }b\mbox{)}$. In other vernacular $r$ is known as the ``modular residue'' which leads to ``quadratic residue''\footnote{That's fancy talk for $b \equiv a^2 \mbox{ (mod }p\mbox{)}$.} and other forms of residues. Modular reductions are normally used to create either finite groups, rings or fields. The most common usage for performance driven modular reductions is in modular exponentiation algorithms. That is to compute $d = a^b \mbox{ (mod }c\mbox{)}$ as fast as possible. This operation is used in the RSA and Diffie-Hellman public key algorithms, for example. Modular multiplication and squaring also appears as a fundamental operation in elliptic curve cryptographic algorithms. As will be discussed in the subsequent chapter there exist fast algorithms for computing modular exponentiations without having to perform (\textit{in this example}) $b - 1$ multiplications. These algorithms will produce partial results in the range $0 \le x < c^2$ which can be taken advantage of to create several efficient algorithms. They have also been used to create redundancy check algorithms known as CRCs, error correction codes such as Reed-Solomon and solve a variety of number theoeretic problems. \section{The Barrett Reduction} The Barrett reduction algorithm \cite{BARRETT} was inspired by fast division algorithms which multiply by the reciprocal to emulate division. Barretts observation was that the residue $c$ of $a$ modulo $b$ is equal to \begin{equation} c = a - b \cdot \lfloor a/b \rfloor \end{equation} Since algorithms such as modular exponentiation would be using the same modulus extensively, typical DSP\footnote{It is worth noting that Barrett's paper targeted the DSP56K processor.} intuition would indicate the next step would be to replace $a/b$ by a multiplication by the reciprocal. However, DSP intuition on its own will not work as these numbers are considerably larger than the precision of common DSP floating point data types. It would take another common optimization to optimize the algorithm. \subsection{Fixed Point Arithmetic} The trick used to optimize the above equation is based on a technique of emulating floating point data types with fixed precision integers. Fixed point arithmetic would become very popular as it greatly optimize the ``3d-shooter'' genre of games in the mid 1990s when floating point units were fairly slow if not unavailable. The idea behind fixed point arithmetic is to take a normal $k$-bit integer data type and break it into $p$-bit integer and a $q$-bit fraction part (\textit{where $p+q = k$}). In this system a $k$-bit integer $n$ would actually represent $n/2^q$. For example, with $q = 4$ the integer $n = 37$ would actually represent the value $2.3125$. To multiply two fixed point numbers the integers are multiplied using traditional arithmetic and subsequently normalized by moving the implied decimal point back to where it should be. For example, with $q = 4$ to multiply the integers $9$ and $5$ they must be converted to fixed point first by multiplying by $2^q$. Let $a = 9(2^q)$ represent the fixed point representation of $9$ and $b = 5(2^q)$ represent the fixed point representation of $5$. The product $ab$ is equal to $45(2^{2q})$ which when normalized by dividing by $2^q$ produces $45(2^q)$. This technique became popular since a normal integer multiplication and logical shift right are the only required operations to perform a multiplication of two fixed point numbers. Using fixed point arithmetic, division can be easily approximated by multiplying by the reciprocal. If $2^q$ is equivalent to one than $2^q/b$ is equivalent to the fixed point approximation of $1/b$ using real arithmetic. Using this fact dividing an integer $a$ by another integer $b$ can be achieved with the following expression. \begin{equation} \lfloor a / b \rfloor \mbox{ }\approx\mbox{ } \lfloor (a \cdot \lfloor 2^q / b \rfloor)/2^q \rfloor \end{equation} The precision of the division is proportional to the value of $q$. If the divisor $b$ is used frequently as is the case with modular exponentiation pre-computing $2^q/b$ will allow a division to be performed with a multiplication and a right shift. Both operations are considerably faster than division on most processors. Consider dividing $19$ by $5$. The correct result is $\lfloor 19/5 \rfloor = 3$. With $q = 3$ the reciprocal is $\lfloor 2^q/5 \rfloor = 1$ which leads to a product of $19$ which when divided by $2^q$ produces $2$. However, with $q = 4$ the reciprocal is $\lfloor 2^q/5 \rfloor = 3$ and the result of the emulated division is $\lfloor 3 \cdot 19 / 2^q \rfloor = 3$ which is correct. The value of $2^q$ must be close to or ideally larger than the dividend. In effect if $a$ is the dividend then $q$ should allow $0 \le \lfloor a/2^q \rfloor \le 1$ in order for this approach to work correctly. Plugging this form of divison into the original equation the following modular residue equation arises. \begin{equation} c = a - b \cdot \lfloor (a \cdot \lfloor 2^q / b \rfloor)/2^q \rfloor \end{equation} Using the notation from \cite{BARRETT} the value of $\lfloor 2^q / b \rfloor$ will be represented by the $\mu$ symbol. Using the $\mu$ variable also helps re-inforce the idea that it is meant to be computed once and re-used. \begin{equation} c = a - b \cdot \lfloor (a \cdot \mu)/2^q \rfloor \end{equation} Provided that $2^q \ge a$ this algorithm will produce a quotient that is either exactly correct or off by a value of one. In the context of Barrett reduction the value of $a$ is bound by $0 \le a \le (b - 1)^2$ meaning that $2^q \ge b^2$ is sufficient to ensure the reciprocal will have enough precision. Let $n$ represent the number of digits in $b$. This algorithm requires approximately $2n^2$ single precision multiplications to produce the quotient and another $n^2$ single precision multiplications to find the residue. In total $3n^2$ single precision multiplications are required to reduce the number. For example, if $b = 1179677$ and $q = 41$ ($2^q > b^2$), then the reciprocal $\mu$ is equal to $\lfloor 2^q / b \rfloor = 1864089$. Consider reducing $a = 180388626447$ modulo $b$ using the above reduction equation. The quotient using the new formula is $\lfloor (a \cdot \mu) / 2^q \rfloor = 152913$. By subtracting $152913b$ from $a$ the correct residue $a \equiv 677346 \mbox{ (mod }b\mbox{)}$ is found. \subsection{Choosing a Radix Point} Using the fixed point representation a modular reduction can be performed with $3n^2$ single precision multiplications. If that were the best that could be achieved a full division\footnote{A division requires approximately $O(2cn^2)$ single precision multiplications for a small value of $c$. See~\ref{sec:division} for further details.} might as well be used in its place. The key to optimizing the reduction is to reduce the precision of the initial multiplication that finds the quotient. Let $a$ represent the number of which the residue is sought. Let $b$ represent the modulus used to find the residue. Let $m$ represent the number of digits in $b$. For the purposes of this discussion we will assume that the number of digits in $a$ is $2m$, which is generally true if two $m$-digit numbers have been multiplied. Dividing $a$ by $b$ is the same as dividing a $2m$ digit integer by a $m$ digit integer. Digits below the $m - 1$'th digit of $a$ will contribute at most a value of $1$ to the quotient because $\beta^k < b$ for any $0 \le k \le m - 1$. Another way to express this is by re-writing $a$ as two parts. If $a' \equiv a \mbox{ (mod }b^m\mbox{)}$ and $a'' = a - a'$ then ${a \over b} \equiv {{a' + a''} \over b}$ which is equivalent to ${a' \over b} + {a'' \over b}$. Since $a'$ is bound to be less than $b$ the quotient is bound by $0 \le {a' \over b} < 1$. Since the digits of $a'$ do not contribute much to the quotient the observation is that they might as well be zero. However, if the digits ``might as well be zero'' they might as well not be there in the first place. Let $q_0 = \lfloor a/\beta^{m-1} \rfloor$ represent the input with the irrelevant digits trimmed. Now the modular reduction is trimmed to the almost equivalent equation \begin{equation} c = a - b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor \end{equation} Note that the original divisor $2^q$ has been replaced with $\beta^{m+1}$ where in this case $q$ is a multiple of $lg(\beta)$. Also note that the exponent on the divisor when added to the amount $q_0$ was shifted by equals $2m$. If the optimization had not been performed the divisor would have the exponent $2m$ so in the end the exponents do ``add up''. Using the above equation the quotient $\lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor$ can be off from the true quotient by at most two. The original fixed point quotient can be off by as much as one (\textit{provided the radix point is chosen suitably}) and now that the lower irrelevent digits have been trimmed the quotient can be off by an additional value of one for a total of at most two. This implies that $0 \le a - b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor < 3b$. By first subtracting $b$ times the quotient and then conditionally subtracting $b$ once or twice the residue is found. The quotient is now found using $(m + 1)(m) = m^2 + m$ single precision multiplications and the residue with an additional $m^2$ single precision multiplications, ignoring the subtractions required. In total $2m^2 + m$ single precision multiplications are required to find the residue. This is considerably faster than the original attempt. For example, let $\beta = 10$ represent the radix of the digits. Let $b = 9999$ represent the modulus which implies $m = 4$. Let $a = 99929878$ represent the value of which the residue is desired. In this case $q = 8$ since $10^7 < 9999^2$ meaning that $\mu = \lfloor \beta^{q}/b \rfloor = 10001$. With the new observation the multiplicand for the quotient is equal to $q_0 = \lfloor a / \beta^{m - 1} \rfloor = 99929$. The quotient is then $\lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor = 9993$. Subtracting $9993b$ from $a$ and the correct residue $a \equiv 9871 \mbox{ (mod }b\mbox{)}$ is found. \subsection{Trimming the Quotient} So far the reduction algorithm has been optimized from $3m^2$ single precision multiplications down to $2m^2 + m$ single precision multiplications. As it stands now the algorithm is already fairly fast compared to a full integer division algorithm. However, there is still room for optimization. After the first multiplication inside the quotient ($q_0 \cdot \mu$) the value is shifted right by $m + 1$ places effectively nullifying the lower half of the product. It would be nice to be able to remove those digits from the product to effectively cut down the number of single precision multiplications. If the number of digits in the modulus $m$ is far less than $\beta$ a full product is not required for the algorithm to work properly. In fact the lower $m - 2$ digits will not affect the upper half of the product at all and do not need to be computed. The value of $\mu$ is a $m$-digit number and $q_0$ is a $m + 1$ digit number. Using a full multiplier $(m + 1)(m) = m^2 + m$ single precision multiplications would be required. Using a multiplier that will only produce digits at and above the $m - 1$'th digit reduces the number of single precision multiplications to ${m^2 + m} \over 2$ single precision multiplications. \subsection{Trimming the Residue} After the quotient has been calculated it is used to reduce the input. As previously noted the algorithm is not exact and it can be off by a small multiple of the modulus, that is $0 \le a - b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor < 3b$. If $b$ is $m$ digits than the result of reduction equation is a value of at most $m + 1$ digits (\textit{provided $3 < \beta$}) implying that the upper $m - 1$ digits are implicitly zero. The next optimization arises from this very fact. Instead of computing $b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor$ using a full $O(m^2)$ multiplication algorithm only the lower $m+1$ digits of the product have to be computed. Similarly the value of $a$ can be reduced modulo $\beta^{m+1}$ before the multiple of $b$ is subtracted which simplifes the subtraction as well. A multiplication that produces only the lower $m+1$ digits requires ${m^2 + 3m - 2} \over 2$ single precision multiplications. With both optimizations in place the algorithm is the algorithm Barrett proposed. It requires $m^2 + 2m - 1$ single precision multiplications which is considerably faster than the straightforward $3m^2$ method. \subsection{The Barrett Algorithm} \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_reduce}. \\ \textbf{Input}. mp\_int $a$, mp\_int $b$ and $\mu = \lfloor \beta^{2m}/b \rfloor, m = \lceil lg_{\beta}(b) \rceil, (0 \le a < b^2, b > 1)$ \\ \textbf{Output}. $a \mbox{ (mod }b\mbox{)}$ \\ \hline \\ Let $m$ represent the number of digits in $b$. \\ 1. Make a copy of $a$ and store it in $q$. (\textit{mp\_init\_copy}) \\ 2. $q \leftarrow \lfloor q / \beta^{m - 1} \rfloor$ (\textit{mp\_rshd}) \\ \\ Produce the quotient. \\ 3. $q \leftarrow q \cdot \mu$ (\textit{note: only produce digits at or above $m-1$}) \\ 4. $q \leftarrow \lfloor q / \beta^{m + 1} \rfloor$ \\ \\ Subtract the multiple of modulus from the input. \\ 5. $a \leftarrow a \mbox{ (mod }\beta^{m+1}\mbox{)}$ (\textit{mp\_mod\_2d}) \\ 6. $q \leftarrow q \cdot b \mbox{ (mod }\beta^{m+1}\mbox{)}$ (\textit{s\_mp\_mul\_digs}) \\ 7. $a \leftarrow a - q$ (\textit{mp\_sub}) \\ \\ Add $\beta^{m+1}$ if a carry occured. \\ 8. If $a < 0$ then (\textit{mp\_cmp\_d}) \\ \hspace{3mm}8.1 $q \leftarrow 1$ (\textit{mp\_set}) \\ \hspace{3mm}8.2 $q \leftarrow q \cdot \beta^{m+1}$ (\textit{mp\_lshd}) \\ \hspace{3mm}8.3 $a \leftarrow a + q$ \\ \\ Now subtract the modulus if the residue is too large (e.g. quotient too small). \\ 9. While $a \ge b$ do (\textit{mp\_cmp}) \\ \hspace{3mm}9.1 $c \leftarrow a - b$ \\ 10. Clear $q$. \\ 11. Return(\textit{MP\_OKAY}) \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_reduce} \end{figure} \textbf{Algorithm mp\_reduce.} This algorithm will reduce the input $a$ modulo $b$ in place using the Barrett algorithm. It is loosely based on algorithm 14.42 of HAC \cite[pp. 602]{HAC} which is based on the paper from Paul Barrett \cite{BARRETT}. The algorithm has several restrictions and assumptions which must be adhered to for the algorithm to work. First the modulus $b$ is assumed to be positive and greater than one. If the modulus were less than or equal to one than subtracting a multiple of it would either accomplish nothing or actually enlarge the input. The input $a$ must be in the range $0 \le a < b^2$ in order for the quotient to have enough precision. If $a$ is the product of two numbers that were already reduced modulo $b$, this will not be a problem. Technically the algorithm will still work if $a \ge b^2$ but it will take much longer to finish. The value of $\mu$ is passed as an argument to this algorithm and is assumed to be calculated and stored before the algorithm is used. Recall that the multiplication for the quotient on step 3 must only produce digits at or above the $m-1$'th position. An algorithm called $s\_mp\_mul\_high\_digs$ which has not been presented is used to accomplish this task. The algorithm is based on $s\_mp\_mul\_digs$ except that instead of stopping at a given level of precision it starts at a given level of precision. This optimal algorithm can only be used if the number of digits in $b$ is very much smaller than $\beta$. While it is known that $a \ge b \cdot \lfloor (q_0 \cdot \mu) / \beta^{m+1} \rfloor$ only the lower $m+1$ digits are being used to compute the residue, so an implied ``borrow'' from the higher digits might leave a negative result. After the multiple of the modulus has been subtracted from $a$ the residue must be fixed up in case it is negative. The invariant $\beta^{m+1}$ must be added to the residue to make it positive again. The while loop at step 9 will subtract $b$ until the residue is less than $b$. If the algorithm is performed correctly this step is performed at most twice, and on average once. However, if $a \ge b^2$ than it will iterate substantially more times than it should. EXAM,bn_mp_reduce.c The first multiplication that determines the quotient can be performed by only producing the digits from $m - 1$ and up. This essentially halves the number of single precision multiplications required. However, the optimization is only safe if $\beta$ is much larger than the number of digits in the modulus. In the source code this is evaluated on lines @36,if@ to @44,}@ where algorithm s\_mp\_mul\_high\_digs is used when it is safe to do so. \subsection{The Barrett Setup Algorithm} In order to use algorithm mp\_reduce the value of $\mu$ must be calculated in advance. Ideally this value should be computed once and stored for future use so that the Barrett algorithm can be used without delay. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_reduce\_setup}. \\ \textbf{Input}. mp\_int $a$ ($a > 1$) \\ \textbf{Output}. $\mu \leftarrow \lfloor \beta^{2m}/a \rfloor$ \\ \hline \\ 1. $\mu \leftarrow 2^{2 \cdot lg(\beta) \cdot m}$ (\textit{mp\_2expt}) \\ 2. $\mu \leftarrow \lfloor \mu / b \rfloor$ (\textit{mp\_div}) \\ 3. Return(\textit{MP\_OKAY}) \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_reduce\_setup} \end{figure} \textbf{Algorithm mp\_reduce\_setup.} This algorithm computes the reciprocal $\mu$ required for Barrett reduction. First $\beta^{2m}$ is calculated as $2^{2 \cdot lg(\beta) \cdot m}$ which is equivalent and much faster. The final value is computed by taking the integer quotient of $\lfloor \mu / b \rfloor$. EXAM,bn_mp_reduce_setup.c This simple routine calculates the reciprocal $\mu$ required by Barrett reduction. Note the extended usage of algorithm mp\_div where the variable which would received the remainder is passed as NULL. As will be discussed in~\ref{sec:division} the division routine allows both the quotient and the remainder to be passed as NULL meaning to ignore the value. \section{The Montgomery Reduction} Montgomery reduction\footnote{Thanks to Niels Ferguson for his insightful explanation of the algorithm.} \cite{MONT} is by far the most interesting form of reduction in common use. It computes a modular residue which is not actually equal to the residue of the input yet instead equal to a residue times a constant. However, as perplexing as this may sound the algorithm is relatively simple and very efficient. Throughout this entire section the variable $n$ will represent the modulus used to form the residue. As will be discussed shortly the value of $n$ must be odd. The variable $x$ will represent the quantity of which the residue is sought. Similar to the Barrett algorithm the input is restricted to $0 \le x < n^2$. To begin the description some simple number theory facts must be established. \textbf{Fact 1.} Adding $n$ to $x$ does not change the residue since in effect it adds one to the quotient $\lfloor x / n \rfloor$. Another way to explain this is that $n$ is (\textit{or multiples of $n$ are}) congruent to zero modulo $n$. Adding zero will not change the value of the residue. \textbf{Fact 2.} If $x$ is even then performing a division by two in $\Z$ is congruent to $x \cdot 2^{-1} \mbox{ (mod }n\mbox{)}$. Actually this is an application of the fact that if $x$ is evenly divisible by any $k \in \Z$ then division in $\Z$ will be congruent to multiplication by $k^{-1}$ modulo $n$. From these two simple facts the following simple algorithm can be derived. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{Montgomery Reduction}. \\ \textbf{Input}. Integer $x$, $n$ and $k$ \\ \textbf{Output}. $2^{-k}x \mbox{ (mod }n\mbox{)}$ \\ \hline \\ 1. for $t$ from $1$ to $k$ do \\ \hspace{3mm}1.1 If $x$ is odd then \\ \hspace{6mm}1.1.1 $x \leftarrow x + n$ \\ \hspace{3mm}1.2 $x \leftarrow x/2$ \\ 2. Return $x$. \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm Montgomery Reduction} \end{figure} The algorithm reduces the input one bit at a time using the two congruencies stated previously. Inside the loop $n$, which is odd, is added to $x$ if $x$ is odd. This forces $x$ to be even which allows the division by two in $\Z$ to be congruent to a modular division by two. Since $x$ is assumed to be initially much larger than $n$ the addition of $n$ will contribute an insignificant magnitude to $x$. Let $r$ represent the final result of the Montgomery algorithm. If $k > lg(n)$ and $0 \le x < n^2$ then the final result is limited to $0 \le r < \lfloor x/2^k \rfloor + n$. As a result at most a single subtraction is required to get the residue desired. \begin{figure}[here] \begin{small} \begin{center} \begin{tabular}{|c|l|} \hline \textbf{Step number ($t$)} & \textbf{Result ($x$)} \\ \hline $1$ & $x + n = 5812$, $x/2 = 2906$ \\ \hline $2$ & $x/2 = 1453$ \\ \hline $3$ & $x + n = 1710$, $x/2 = 855$ \\ \hline $4$ & $x + n = 1112$, $x/2 = 556$ \\ \hline $5$ & $x/2 = 278$ \\ \hline $6$ & $x/2 = 139$ \\ \hline $7$ & $x + n = 396$, $x/2 = 198$ \\ \hline $8$ & $x/2 = 99$ \\ \hline \end{tabular} \end{center} \end{small} \caption{Example of Montgomery Reduction (I)} \label{fig:MONT1} \end{figure} Consider the example in figure~\ref{fig:MONT1} which reduces $x = 5555$ modulo $n = 257$ when $k = 8$. The result of the algorithm $r = 99$ is congruent to the value of $2^{-8} \cdot 5555 \mbox{ (mod }257\mbox{)}$. When $r$ is multiplied by $2^8$ modulo $257$ the correct residue $r \equiv 158$ is produced. Let $k = \lfloor lg(n) \rfloor + 1$ represent the number of bits in $n$. The current algorithm requires $2k^2$ single precision shifts and $k^2$ single precision additions. At this rate the algorithm is most certainly slower than Barrett reduction and not terribly useful. Fortunately there exists an alternative representation of the algorithm. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{Montgomery Reduction} (modified I). \\ \textbf{Input}. Integer $x$, $n$ and $k$ \\ \textbf{Output}. $2^{-k}x \mbox{ (mod }n\mbox{)}$ \\ \hline \\ 1. for $t$ from $0$ to $k - 1$ do \\ \hspace{3mm}1.1 If the $t$'th bit of $x$ is one then \\ \hspace{6mm}1.1.1 $x \leftarrow x + 2^tn$ \\ 2. Return $x/2^k$. \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm Montgomery Reduction (modified I)} \end{figure} This algorithm is equivalent since $2^tn$ is a multiple of $n$ and the lower $k$ bits of $x$ are zero by step 2. The number of single precision shifts has now been reduced from $2k^2$ to $k^2 + k$ which is only a small improvement. \begin{figure}[here] \begin{small} \begin{center} \begin{tabular}{|c|l|r|} \hline \textbf{Step number ($t$)} & \textbf{Result ($x$)} & \textbf{Result ($x$) in Binary} \\ \hline -- & $5555$ & $1010110110011$ \\ \hline $1$ & $x + 2^{0}n = 5812$ & $1011010110100$ \\ \hline $2$ & $5812$ & $1011010110100$ \\ \hline $3$ & $x + 2^{2}n = 6840$ & $1101010111000$ \\ \hline $4$ & $x + 2^{3}n = 8896$ & $10001011000000$ \\ \hline $5$ & $8896$ & $10001011000000$ \\ \hline $6$ & $8896$ & $10001011000000$ \\ \hline $7$ & $x + 2^{6}n = 25344$ & $110001100000000$ \\ \hline $8$ & $25344$ & $110001100000000$ \\ \hline -- & $x/2^k = 99$ & \\ \hline \end{tabular} \end{center} \end{small} \caption{Example of Montgomery Reduction (II)} \label{fig:MONT2} \end{figure} Figure~\ref{fig:MONT2} demonstrates the modified algorithm reducing $x = 5555$ modulo $n = 257$ with $k = 8$. With this algorithm a single shift right at the end is the only right shift required to reduce the input instead of $k$ right shifts inside the loop. Note that for the iterations $t = 2, 5, 6$ and $8$ where the result $x$ is not changed. In those iterations the $t$'th bit of $x$ is zero and the appropriate multiple of $n$ does not need to be added to force the $t$'th bit of the result to zero. \subsection{Digit Based Montgomery Reduction} Instead of computing the reduction on a bit-by-bit basis it is actually much faster to compute it on digit-by-digit basis. Consider the previous algorithm re-written to compute the Montgomery reduction in this new fashion. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{Montgomery Reduction} (modified II). \\ \textbf{Input}. Integer $x$, $n$ and $k$ \\ \textbf{Output}. $\beta^{-k}x \mbox{ (mod }n\mbox{)}$ \\ \hline \\ 1. for $t$ from $0$ to $k - 1$ do \\ \hspace{3mm}1.1 $x \leftarrow x + \mu n \beta^t$ \\ 2. Return $x/\beta^k$. \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm Montgomery Reduction (modified II)} \end{figure} The value $\mu n \beta^t$ is a multiple of the modulus $n$ meaning that it will not change the residue. If the first digit of the value $\mu n \beta^t$ equals the negative (modulo $\beta$) of the $t$'th digit of $x$ then the addition will result in a zero digit. This problem breaks down to solving the following congruency. \begin{center} \begin{tabular}{rcl} $x_t + \mu n_0$ & $\equiv$ & $0 \mbox{ (mod }\beta\mbox{)}$ \\ $\mu n_0$ & $\equiv$ & $-x_t \mbox{ (mod }\beta\mbox{)}$ \\ $\mu$ & $\equiv$ & $-x_t/n_0 \mbox{ (mod }\beta\mbox{)}$ \\ \end{tabular} \end{center} In each iteration of the loop on step 1 a new value of $\mu$ must be calculated. The value of $-1/n_0 \mbox{ (mod }\beta\mbox{)}$ is used extensively in this algorithm and should be precomputed. Let $\rho$ represent the negative of the modular inverse of $n_0$ modulo $\beta$. For example, let $\beta = 10$ represent the radix. Let $n = 17$ represent the modulus which implies $k = 2$ and $\rho \equiv 7$. Let $x = 33$ represent the value to reduce. \newpage\begin{figure} \begin{center} \begin{tabular}{|c|c|c|} \hline \textbf{Step ($t$)} & \textbf{Value of $x$} & \textbf{Value of $\mu$} \\ \hline -- & $33$ & --\\ \hline $0$ & $33 + \mu n = 50$ & $1$ \\ \hline $1$ & $50 + \mu n \beta = 900$ & $5$ \\ \hline \end{tabular} \end{center} \caption{Example of Montgomery Reduction} \end{figure} The final result $900$ is then divided by $\beta^k$ to produce the final result $9$. The first observation is that $9 \nequiv x \mbox{ (mod }n\mbox{)}$ which implies the result is not the modular residue of $x$ modulo $n$. However, recall that the residue is actually multiplied by $\beta^{-k}$ in the algorithm. To get the true residue the value must be multiplied by $\beta^k$. In this case $\beta^k \equiv 15 \mbox{ (mod }n\mbox{)}$ and the correct residue is $9 \cdot 15 \equiv 16 \mbox{ (mod }n\mbox{)}$. \subsection{Baseline Montgomery Reduction} The baseline Montgomery reduction algorithm will produce the residue for any size input. It is designed to be a catch-all algororithm for Montgomery reductions. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_montgomery\_reduce}. \\ \textbf{Input}. mp\_int $x$, mp\_int $n$ and a digit $\rho \equiv -1/n_0 \mbox{ (mod }n\mbox{)}$. \\ \hspace{11.5mm}($0 \le x < n^2, n > 1, (n, \beta) = 1, \beta^k > n$) \\ \textbf{Output}. $\beta^{-k}x \mbox{ (mod }n\mbox{)}$ \\ \hline \\ 1. $digs \leftarrow 2n.used + 1$ \\ 2. If $digs < MP\_ARRAY$ and $m.used < \delta$ then \\ \hspace{3mm}2.1 Use algorithm fast\_mp\_montgomery\_reduce instead. \\ \\ Setup $x$ for the reduction. \\ 3. If $x.alloc < digs$ then grow $x$ to $digs$ digits. \\ 4. $x.used \leftarrow digs$ \\ \\ Eliminate the lower $k$ digits. \\ 5. For $ix$ from $0$ to $k - 1$ do \\ \hspace{3mm}5.1 $\mu \leftarrow x_{ix} \cdot \rho \mbox{ (mod }\beta\mbox{)}$ \\ \hspace{3mm}5.2 $u \leftarrow 0$ \\ \hspace{3mm}5.3 For $iy$ from $0$ to $k - 1$ do \\ \hspace{6mm}5.3.1 $\hat r \leftarrow \mu n_{iy} + x_{ix + iy} + u$ \\ \hspace{6mm}5.3.2 $x_{ix + iy} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ \hspace{6mm}5.3.3 $u \leftarrow \lfloor \hat r / \beta \rfloor$ \\ \hspace{3mm}5.4 While $u > 0$ do \\ \hspace{6mm}5.4.1 $iy \leftarrow iy + 1$ \\ \hspace{6mm}5.4.2 $x_{ix + iy} \leftarrow x_{ix + iy} + u$ \\ \hspace{6mm}5.4.3 $u \leftarrow \lfloor x_{ix+iy} / \beta \rfloor$ \\ \hspace{6mm}5.4.4 $x_{ix + iy} \leftarrow x_{ix+iy} \mbox{ (mod }\beta\mbox{)}$ \\ \\ Divide by $\beta^k$ and fix up as required. \\ 6. $x \leftarrow \lfloor x / \beta^k \rfloor$ \\ 7. If $x \ge n$ then \\ \hspace{3mm}7.1 $x \leftarrow x - n$ \\ 8. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_montgomery\_reduce} \end{figure} \textbf{Algorithm mp\_montgomery\_reduce.} This algorithm reduces the input $x$ modulo $n$ in place using the Montgomery reduction algorithm. The algorithm is loosely based on algorithm 14.32 of \cite[pp.601]{HAC} except it merges the multiplication of $\mu n \beta^t$ with the addition in the inner loop. The restrictions on this algorithm are fairly easy to adapt to. First $0 \le x < n^2$ bounds the input to numbers in the same range as for the Barrett algorithm. Additionally if $n > 1$ and $n$ is odd there will exist a modular inverse $\rho$. $\rho$ must be calculated in advance of this algorithm. Finally the variable $k$ is fixed and a pseudonym for $n.used$. Step 2 decides whether a faster Montgomery algorithm can be used. It is based on the Comba technique meaning that there are limits on the size of the input. This algorithm is discussed in ~COMBARED~. Step 5 is the main reduction loop of the algorithm. The value of $\mu$ is calculated once per iteration in the outer loop. The inner loop calculates $x + \mu n \beta^{ix}$ by multiplying $\mu n$ and adding the result to $x$ shifted by $ix$ digits. Both the addition and multiplication are performed in the same loop to save time and memory. Step 5.4 will handle any additional carries that escape the inner loop. Using a quick inspection this algorithm requires $n$ single precision multiplications for the outer loop and $n^2$ single precision multiplications in the inner loop. In total $n^2 + n$ single precision multiplications which compares favourably to Barrett at $n^2 + 2n - 1$ single precision multiplications. EXAM,bn_mp_montgomery_reduce.c This is the baseline implementation of the Montgomery reduction algorithm. Lines @30,digs@ to @35,}@ determine if the Comba based routine can be used instead. Line @47,mu@ computes the value of $\mu$ for that particular iteration of the outer loop. The multiplication $\mu n \beta^{ix}$ is performed in one step in the inner loop. The alias $tmpx$ refers to the $ix$'th digit of $x$ and the alias $tmpn$ refers to the modulus $n$. \subsection{Faster ``Comba'' Montgomery Reduction} MARK,COMBARED The Montgomery reduction requires fewer single precision multiplications than a Barrett reduction, however it is much slower due to the serial nature of the inner loop. The Barrett reduction algorithm requires two slightly modified multipliers which can be implemented with the Comba technique. The Montgomery reduction algorithm cannot directly use the Comba technique to any significant advantage since the inner loop calculates a $k \times 1$ product $k$ times. The biggest obstacle is that at the $ix$'th iteration of the outer loop the value of $x_{ix}$ is required to calculate $\mu$. This means the carries from $0$ to $ix - 1$ must have been propagated upwards to form a valid $ix$'th digit. The solution as it turns out is very simple. Perform a Comba like multiplier and inside the outer loop just after the inner loop fix up the $ix + 1$'th digit by forwarding the carry. With this change in place the Montgomery reduction algorithm can be performed with a Comba style multiplication loop which substantially increases the speed of the algorithm. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{fast\_mp\_montgomery\_reduce}. \\ \textbf{Input}. mp\_int $x$, mp\_int $n$ and a digit $\rho \equiv -1/n_0 \mbox{ (mod }n\mbox{)}$. \\ \hspace{11.5mm}($0 \le x < n^2, n > 1, (n, \beta) = 1, \beta^k > n$) \\ \textbf{Output}. $\beta^{-k}x \mbox{ (mod }n\mbox{)}$ \\ \hline \\ Place an array of \textbf{MP\_WARRAY} mp\_word variables called $\hat W$ on the stack. \\ 1. if $x.alloc < n.used + 1$ then grow $x$ to $n.used + 1$ digits. \\ Copy the digits of $x$ into the array $\hat W$ \\ 2. For $ix$ from $0$ to $x.used - 1$ do \\ \hspace{3mm}2.1 $\hat W_{ix} \leftarrow x_{ix}$ \\ 3. For $ix$ from $x.used$ to $2n.used - 1$ do \\ \hspace{3mm}3.1 $\hat W_{ix} \leftarrow 0$ \\ Elimiate the lower $k$ digits. \\ 4. for $ix$ from $0$ to $n.used - 1$ do \\ \hspace{3mm}4.1 $\mu \leftarrow \hat W_{ix} \cdot \rho \mbox{ (mod }\beta\mbox{)}$ \\ \hspace{3mm}4.2 For $iy$ from $0$ to $n.used - 1$ do \\ \hspace{6mm}4.2.1 $\hat W_{iy + ix} \leftarrow \hat W_{iy + ix} + \mu \cdot n_{iy}$ \\ \hspace{3mm}4.3 $\hat W_{ix + 1} \leftarrow \hat W_{ix + 1} + \lfloor \hat W_{ix} / \beta \rfloor$ \\ Propagate carries upwards. \\ 5. for $ix$ from $n.used$ to $2n.used + 1$ do \\ \hspace{3mm}5.1 $\hat W_{ix + 1} \leftarrow \hat W_{ix + 1} + \lfloor \hat W_{ix} / \beta \rfloor$ \\ Shift right and reduce modulo $\beta$ simultaneously. \\ 6. for $ix$ from $0$ to $n.used + 1$ do \\ \hspace{3mm}6.1 $x_{ix} \leftarrow \hat W_{ix + n.used} \mbox{ (mod }\beta\mbox{)}$ \\ Zero excess digits and fixup $x$. \\ 7. if $x.used > n.used + 1$ then do \\ \hspace{3mm}7.1 for $ix$ from $n.used + 1$ to $x.used - 1$ do \\ \hspace{6mm}7.1.1 $x_{ix} \leftarrow 0$ \\ 8. $x.used \leftarrow n.used + 1$ \\ 9. Clamp excessive digits of $x$. \\ 10. If $x \ge n$ then \\ \hspace{3mm}10.1 $x \leftarrow x - n$ \\ 11. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm fast\_mp\_montgomery\_reduce} \end{figure} \textbf{Algorithm fast\_mp\_montgomery\_reduce.} This algorithm will compute the Montgomery reduction of $x$ modulo $n$ using the Comba technique. It is on most computer platforms significantly faster than algorithm mp\_montgomery\_reduce and algorithm mp\_reduce (\textit{Barrett reduction}). The algorithm has the same restrictions on the input as the baseline reduction algorithm. An additional two restrictions are imposed on this algorithm. The number of digits $k$ in the the modulus $n$ must not violate $MP\_WARRAY > 2k +1$ and $n < \delta$. When $\beta = 2^{28}$ this algorithm can be used to reduce modulo a modulus of at most $3,556$ bits in length. As in the other Comba reduction algorithms there is a $\hat W$ array which stores the columns of the product. It is initially filled with the contents of $x$ with the excess digits zeroed. The reduction loop is very similar the to the baseline loop at heart. The multiplication on step 4.1 can be single precision only since $ab \mbox{ (mod }\beta\mbox{)} \equiv (a \mbox{ mod }\beta)(b \mbox{ mod }\beta)$. Some multipliers such as those on the ARM processors take a variable length time to complete depending on the number of bytes of result it must produce. By performing a single precision multiplication instead half the amount of time is spent. Also note that digit $\hat W_{ix}$ must have the carry from the $ix - 1$'th digit propagated upwards in order for this to work. That is what step 4.3 will do. In effect over the $n.used$ iterations of the outer loop the $n.used$'th lower columns all have the their carries propagated forwards. Note how the upper bits of those same words are not reduced modulo $\beta$. This is because those values will be discarded shortly and there is no point. Step 5 will propagate the remainder of the carries upwards. On step 6 the columns are reduced modulo $\beta$ and shifted simultaneously as they are stored in the destination $x$. EXAM,bn_fast_mp_montgomery_reduce.c The $\hat W$ array is first filled with digits of $x$ on line @49,for@ then the rest of the digits are zeroed on line @54,for@. Both loops share the same alias variables to make the code easier to read. The value of $\mu$ is calculated in an interesting fashion. First the value $\hat W_{ix}$ is reduced modulo $\beta$ and cast to a mp\_digit. This forces the compiler to use a single precision multiplication and prevents any concerns about loss of precision. Line @101,>>@ fixes the carry for the next iteration of the loop by propagating the carry from $\hat W_{ix}$ to $\hat W_{ix+1}$. The for loop on line @113,for@ propagates the rest of the carries upwards through the columns. The for loop on line @126,for@ reduces the columns modulo $\beta$ and shifts them $k$ places at the same time. The alias $\_ \hat W$ actually refers to the array $\hat W$ starting at the $n.used$'th digit, that is $\_ \hat W_{t} = \hat W_{n.used + t}$. \subsection{Montgomery Setup} To calculate the variable $\rho$ a relatively simple algorithm will be required. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_montgomery\_setup}. \\ \textbf{Input}. mp\_int $n$ ($n > 1$ and $(n, 2) = 1$) \\ \textbf{Output}. $\rho \equiv -1/n_0 \mbox{ (mod }\beta\mbox{)}$ \\ \hline \\ 1. $b \leftarrow n_0$ \\ 2. If $b$ is even return(\textit{MP\_VAL}) \\ 3. $x \leftarrow (((b + 2) \mbox{ AND } 4) << 1) + b$ \\ 4. for $k$ from 0 to $\lceil lg(lg(\beta)) \rceil - 2$ do \\ \hspace{3mm}4.1 $x \leftarrow x \cdot (2 - bx)$ \\ 5. $\rho \leftarrow \beta - x \mbox{ (mod }\beta\mbox{)}$ \\ 6. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_montgomery\_setup} \end{figure} \textbf{Algorithm mp\_montgomery\_setup.} This algorithm will calculate the value of $\rho$ required within the Montgomery reduction algorithms. It uses a very interesting trick to calculate $1/n_0$ when $\beta$ is a power of two. EXAM,bn_mp_montgomery_setup.c This source code computes the value of $\rho$ required to perform Montgomery reduction. It has been modified to avoid performing excess multiplications when $\beta$ is not the default 28-bits. \section{The Diminished Radix Algorithm} The Diminished Radix method of modular reduction \cite{DRMET} is a fairly clever technique which can be more efficient than either the Barrett or Montgomery methods for certain forms of moduli. The technique is based on the following simple congruence. \begin{equation} (x \mbox{ mod } n) + k \lfloor x / n \rfloor \equiv x \mbox{ (mod }(n - k)\mbox{)} \end{equation} This observation was used in the MMB \cite{MMB} block cipher to create a diffusion primitive. It used the fact that if $n = 2^{31}$ and $k=1$ that then a x86 multiplier could produce the 62-bit product and use the ``shrd'' instruction to perform a double-precision right shift. The proof of the above equation is very simple. First write $x$ in the product form. \begin{equation} x = qn + r \end{equation} Now reduce both sides modulo $(n - k)$. \begin{equation} x \equiv qk + r \mbox{ (mod }(n-k)\mbox{)} \end{equation} The variable $n$ reduces modulo $n - k$ to $k$. By putting $q = \lfloor x/n \rfloor$ and $r = x \mbox{ mod } n$ into the equation the original congruence is reproduced, thus concluding the proof. The following algorithm is based on this observation. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{Diminished Radix Reduction}. \\ \textbf{Input}. Integer $x$, $n$, $k$ \\ \textbf{Output}. $x \mbox{ mod } (n - k)$ \\ \hline \\ 1. $q \leftarrow \lfloor x / n \rfloor$ \\ 2. $q \leftarrow k \cdot q$ \\ 3. $x \leftarrow x \mbox{ (mod }n\mbox{)}$ \\ 4. $x \leftarrow x + q$ \\ 5. If $x \ge (n - k)$ then \\ \hspace{3mm}5.1 $x \leftarrow x - (n - k)$ \\ \hspace{3mm}5.2 Goto step 1. \\ 6. Return $x$ \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm Diminished Radix Reduction} \label{fig:DR} \end{figure} This algorithm will reduce $x$ modulo $n - k$ and return the residue. If $0 \le x < (n - k)^2$ then the algorithm will loop almost always once or twice and occasionally three times. For simplicity sake the value of $x$ is bounded by the following simple polynomial. \begin{equation} 0 \le x < n^2 + k^2 - 2nk \end{equation} The true bound is $0 \le x < (n - k - 1)^2$ but this has quite a few more terms. The value of $q$ after step 1 is bounded by the following. \begin{equation} q < n - 2k - k^2/n \end{equation} Since $k^2$ is going to be considerably smaller than $n$ that term will always be zero. The value of $x$ after step 3 is bounded trivially as $0 \le x < n$. By step four the sum $x + q$ is bounded by \begin{equation} 0 \le q + x < (k + 1)n - 2k^2 - 1 \end{equation} With a second pass $q$ will be loosely bounded by $0 \le q < k^2$ after step 2 while $x$ will still be loosely bounded by $0 \le x < n$ after step 3. After the second pass it is highly unlike that the sum in step 4 will exceed $n - k$. In practice fewer than three passes of the algorithm are required to reduce virtually every input in the range $0 \le x < (n - k - 1)^2$. \begin{figure} \begin{small} \begin{center} \begin{tabular}{|l|} \hline $x = 123456789, n = 256, k = 3$ \\ \hline $q \leftarrow \lfloor x/n \rfloor = 482253$ \\ $q \leftarrow q*k = 1446759$ \\ $x \leftarrow x \mbox{ mod } n = 21$ \\ $x \leftarrow x + q = 1446780$ \\ $x \leftarrow x - (n - k) = 1446527$ \\ \hline $q \leftarrow \lfloor x/n \rfloor = 5650$ \\ $q \leftarrow q*k = 16950$ \\ $x \leftarrow x \mbox{ mod } n = 127$ \\ $x \leftarrow x + q = 17077$ \\ $x \leftarrow x - (n - k) = 16824$ \\ \hline $q \leftarrow \lfloor x/n \rfloor = 65$ \\ $q \leftarrow q*k = 195$ \\ $x \leftarrow x \mbox{ mod } n = 184$ \\ $x \leftarrow x + q = 379$ \\ $x \leftarrow x - (n - k) = 126$ \\ \hline \end{tabular} \end{center} \end{small} \caption{Example Diminished Radix Reduction} \label{fig:EXDR} \end{figure} Figure~\ref{fig:EXDR} demonstrates the reduction of $x = 123456789$ modulo $n - k = 253$ when $n = 256$ and $k = 3$. Note that even while $x$ is considerably larger than $(n - k - 1)^2 = 63504$ the algorithm still converges on the modular residue exceedingly fast. In this case only three passes were required to find the residue $x \equiv 126$. \subsection{Choice of Moduli} On the surface this algorithm looks like a very expensive algorithm. It requires a couple of subtractions followed by multiplication and other modular reductions. The usefulness of this algorithm becomes exceedingly clear when an appropriate modulus is chosen. Division in general is a very expensive operation to perform. The one exception is when the division is by a power of the radix of representation used. Division by ten for example is simple for pencil and paper mathematics since it amounts to shifting the decimal place to the right. Similarly division by two (\textit{or powers of two}) is very simple for binary computers to perform. It would therefore seem logical to choose $n$ of the form $2^p$ which would imply that $\lfloor x / n \rfloor$ is a simple shift of $x$ right $p$ bits. However, there is one operation related to division of power of twos that is even faster than this. If $n = \beta^p$ then the division may be performed by moving whole digits to the right $p$ places. In practice division by $\beta^p$ is much faster than division by $2^p$ for any $p$. Also with the choice of $n = \beta^p$ reducing $x$ modulo $n$ merely requires zeroing the digits above the $p-1$'th digit of $x$. Throughout the next section the term ``restricted modulus'' will refer to a modulus of the form $\beta^p - k$ whereas the term ``unrestricted modulus'' will refer to a modulus of the form $2^p - k$. The word ``restricted'' in this case refers to the fact that it is based on the $2^p$ logic except $p$ must be a multiple of $lg(\beta)$. \subsection{Choice of $k$} Now that division and reduction (\textit{step 1 and 3 of figure~\ref{fig:DR}}) have been optimized to simple digit operations the multiplication by $k$ in step 2 is the most expensive operation. Fortunately the choice of $k$ is not terribly limited. For all intents and purposes it might as well be a single digit. The smaller the value of $k$ is the faster the algorithm will be. \subsection{Restricted Diminished Radix Reduction} The restricted Diminished Radix algorithm can quickly reduce an input modulo a modulus of the form $n = \beta^p - k$. This algorithm can reduce an input $x$ within the range $0 \le x < n^2$ using only a couple passes of the algorithm demonstrated in figure~\ref{fig:DR}. The implementation of this algorithm has been optimized to avoid additional overhead associated with a division by $\beta^p$, the multiplication by $k$ or the addition of $x$ and $q$. The resulting algorithm is very efficient and can lead to substantial improvements over Barrett and Montgomery reduction when modular exponentiations are performed. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_dr\_reduce}. \\ \textbf{Input}. mp\_int $x$, $n$ and a mp\_digit $k = \beta - n_0$ \\ \hspace{11.5mm}($0 \le x < n^2$, $n > 1$, $0 < k < \beta$) \\ \textbf{Output}. $x \mbox{ mod } n$ \\ \hline \\ 1. $m \leftarrow n.used$ \\ 2. If $x.alloc < 2m$ then grow $x$ to $2m$ digits. \\ 3. $\mu \leftarrow 0$ \\ 4. for $i$ from $0$ to $m - 1$ do \\ \hspace{3mm}4.1 $\hat r \leftarrow k \cdot x_{m+i} + x_{i} + \mu$ \\ \hspace{3mm}4.2 $x_{i} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ \hspace{3mm}4.3 $\mu \leftarrow \lfloor \hat r / \beta \rfloor$ \\ 5. $x_{m} \leftarrow \mu$ \\ 6. for $i$ from $m + 1$ to $x.used - 1$ do \\ \hspace{3mm}6.1 $x_{i} \leftarrow 0$ \\ 7. Clamp excess digits of $x$. \\ 8. If $x \ge n$ then \\ \hspace{3mm}8.1 $x \leftarrow x - n$ \\ \hspace{3mm}8.2 Goto step 3. \\ 9. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_dr\_reduce} \end{figure} \textbf{Algorithm mp\_dr\_reduce.} This algorithm will perform the Dimished Radix reduction of $x$ modulo $n$. It has similar restrictions to that of the Barrett reduction with the addition that $n$ must be of the form $n = \beta^m - k$ where $0 < k <\beta$. This algorithm essentially implements the pseudo-code in figure~\ref{fig:DR} except with a slight optimization. The division by $\beta^m$, multiplication by $k$ and addition of $x \mbox{ mod }\beta^m$ are all performed simultaneously inside the loop on step 4. The division by $\beta^m$ is emulated by accessing the term at the $m+i$'th position which is subsequently multiplied by $k$ and added to the term at the $i$'th position. After the loop the $m$'th digit is set to the carry and the upper digits are zeroed. Steps 5 and 6 emulate the reduction modulo $\beta^m$ that should have happend to $x$ before the addition of the multiple of the upper half. At step 8 if $x$ is still larger than $n$ another pass of the algorithm is required. First $n$ is subtracted from $x$ and then the algorithm resumes at step 3. EXAM,bn_mp_dr_reduce.c The first step is to grow $x$ as required to $2m$ digits since the reduction is performed in place on $x$. The label on line @49,top:@ is where the algorithm will resume if further reduction passes are required. In theory it could be placed at the top of the function however, the size of the modulus and question of whether $x$ is large enough are invariant after the first pass meaning that it would be a waste of time. The aliases $tmpx1$ and $tmpx2$ refer to the digits of $x$ where the latter is offset by $m$ digits. By reading digits from $x$ offset by $m$ digits a division by $\beta^m$ can be simulated virtually for free. The loop on line @61,for@ performs the bulk of the work (\textit{corresponds to step 4 of algorithm 7.11}) in this algorithm. By line @68,mu@ the pointer $tmpx1$ points to the $m$'th digit of $x$ which is where the final carry will be placed. Similarly by line @71,for@ the same pointer will point to the $m+1$'th digit where the zeroes will be placed. Since the algorithm is only valid if both $x$ and $n$ are greater than zero an unsigned comparison suffices to determine if another pass is required. With the same logic at line @82,sub@ the value of $x$ is known to be greater than or equal to $n$ meaning that an unsigned subtraction can be used as well. Since the destination of the subtraction is the larger of the inputs the call to algorithm s\_mp\_sub cannot fail and the return code does not need to be checked. \subsubsection{Setup} To setup the restricted Diminished Radix algorithm the value $k = \beta - n_0$ is required. This algorithm is not really complicated but provided for completeness. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_dr\_setup}. \\ \textbf{Input}. mp\_int $n$ \\ \textbf{Output}. $k = \beta - n_0$ \\ \hline \\ 1. $k \leftarrow \beta - n_0$ \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_dr\_setup} \end{figure} EXAM,bn_mp_dr_setup.c \subsubsection{Modulus Detection} Another algorithm which will be useful is the ability to detect a restricted Diminished Radix modulus. An integer is said to be of restricted Diminished Radix form if all of the digits are equal to $\beta - 1$ except the trailing digit which may be any value. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_dr\_is\_modulus}. \\ \textbf{Input}. mp\_int $n$ \\ \textbf{Output}. $1$ if $n$ is in D.R form, $0$ otherwise \\ \hline 1. If $n.used < 2$ then return($0$). \\ 2. for $ix$ from $1$ to $n.used - 1$ do \\ \hspace{3mm}2.1 If $n_{ix} \ne \beta - 1$ return($0$). \\ 3. Return($1$). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_dr\_is\_modulus} \end{figure} \textbf{Algorithm mp\_dr\_is\_modulus.} This algorithm determines if a value is in Diminished Radix form. Step 1 rejects obvious cases where fewer than two digits are in the mp\_int. Step 2 tests all but the first digit to see if they are equal to $\beta - 1$. If the algorithm manages to get to step 3 then $n$ must be of Diminished Radix form. EXAM,bn_mp_dr_is_modulus.c \subsection{Unrestricted Diminished Radix Reduction} The unrestricted Diminished Radix algorithm allows modular reductions to be performed when the modulus is of the form $2^p - k$. This algorithm is a straightforward adaptation of algorithm~\ref{fig:DR}. In general the restricted Diminished Radix reduction algorithm is much faster since it has considerably lower overhead. However, this new algorithm is much faster than either Montgomery or Barrett reduction when the moduli are of the appropriate form. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_reduce\_2k}. \\ \textbf{Input}. mp\_int $a$ and $n$. mp\_digit $k$ \\ \hspace{11.5mm}($a \ge 0$, $n > 1$, $0 < k < \beta$, $n + k$ is a power of two) \\ \textbf{Output}. $a \mbox{ (mod }n\mbox{)}$ \\ \hline 1. $p \leftarrow \lceil lg(n) \rceil$ (\textit{mp\_count\_bits}) \\ 2. While $a \ge n$ do \\ \hspace{3mm}2.1 $q \leftarrow \lfloor a / 2^p \rfloor$ (\textit{mp\_div\_2d}) \\ \hspace{3mm}2.2 $a \leftarrow a \mbox{ (mod }2^p\mbox{)}$ (\textit{mp\_mod\_2d}) \\ \hspace{3mm}2.3 $q \leftarrow q \cdot k$ (\textit{mp\_mul\_d}) \\ \hspace{3mm}2.4 $a \leftarrow a - q$ (\textit{s\_mp\_sub}) \\ \hspace{3mm}2.5 If $a \ge n$ then do \\ \hspace{6mm}2.5.1 $a \leftarrow a - n$ \\ 3. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_reduce\_2k} \end{figure} \textbf{Algorithm mp\_reduce\_2k.} This algorithm quickly reduces an input $a$ modulo an unrestricted Diminished Radix modulus $n$. Division by $2^p$ is emulated with a right shift which makes the algorithm fairly inexpensive to use. EXAM,bn_mp_reduce_2k.c The algorithm mp\_count\_bits calculates the number of bits in an mp\_int which is used to find the initial value of $p$. The call to mp\_div\_2d on line @31,mp_div_2d@ calculates both the quotient $q$ and the remainder $a$ required. By doing both in a single function call the code size is kept fairly small. The multiplication by $k$ is only performed if $k > 1$. This allows reductions modulo $2^p - 1$ to be performed without any multiplications. The unsigned s\_mp\_add, mp\_cmp\_mag and s\_mp\_sub are used in place of their full sign counterparts since the inputs are only valid if they are positive. By using the unsigned versions the overhead is kept to a minimum. \subsubsection{Unrestricted Setup} To setup this reduction algorithm the value of $k = 2^p - n$ is required. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_reduce\_2k\_setup}. \\ \textbf{Input}. mp\_int $n$ \\ \textbf{Output}. $k = 2^p - n$ \\ \hline 1. $p \leftarrow \lceil lg(n) \rceil$ (\textit{mp\_count\_bits}) \\ 2. $x \leftarrow 2^p$ (\textit{mp\_2expt}) \\ 3. $x \leftarrow x - n$ (\textit{mp\_sub}) \\ 4. $k \leftarrow x_0$ \\ 5. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_reduce\_2k\_setup} \end{figure} \textbf{Algorithm mp\_reduce\_2k\_setup.} This algorithm computes the value of $k$ required for the algorithm mp\_reduce\_2k. By making a temporary variable $x$ equal to $2^p$ a subtraction is sufficient to solve for $k$. Alternatively if $n$ has more than one digit the value of $k$ is simply $\beta - n_0$. EXAM,bn_mp_reduce_2k_setup.c \subsubsection{Unrestricted Detection} An integer $n$ is a valid unrestricted Diminished Radix modulus if either of the following are true. \begin{enumerate} \item The number has only one digit. \item The number has more than one digit and every bit from the $\beta$'th to the most significant is one. \end{enumerate} If either condition is true than there is a power of two $2^p$ such that $0 < 2^p - n < \beta$. If the input is only one digit than it will always be of the correct form. Otherwise all of the bits above the first digit must be one. This arises from the fact that there will be value of $k$ that when added to the modulus causes a carry in the first digit which propagates all the way to the most significant bit. The resulting sum will be a power of two. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_reduce\_is\_2k}. \\ \textbf{Input}. mp\_int $n$ \\ \textbf{Output}. $1$ if of proper form, $0$ otherwise \\ \hline 1. If $n.used = 0$ then return($0$). \\ 2. If $n.used = 1$ then return($1$). \\ 3. $p \leftarrow \lceil lg(n) \rceil$ (\textit{mp\_count\_bits}) \\ 4. for $x$ from $lg(\beta)$ to $p$ do \\ \hspace{3mm}4.1 If the ($x \mbox{ mod }lg(\beta)$)'th bit of the $\lfloor x / lg(\beta) \rfloor$ of $n$ is zero then return($0$). \\ 5. Return($1$). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_reduce\_is\_2k} \end{figure} \textbf{Algorithm mp\_reduce\_is\_2k.} This algorithm quickly determines if a modulus is of the form required for algorithm mp\_reduce\_2k to function properly. EXAM,bn_mp_reduce_is_2k.c \section{Algorithm Comparison} So far three very different algorithms for modular reduction have been discussed. Each of the algorithms have their own strengths and weaknesses that makes having such a selection very useful. The following table sumarizes the three algorithms along with comparisons of work factors. Since all three algorithms have the restriction that $0 \le x < n^2$ and $n > 1$ those limitations are not included in the table. \begin{center} \begin{small} \begin{tabular}{|c|c|c|c|c|c|} \hline \textbf{Method} & \textbf{Work Required} & \textbf{Limitations} & \textbf{$m = 8$} & \textbf{$m = 32$} & \textbf{$m = 64$} \\ \hline Barrett & $m^2 + 2m - 1$ & None & $79$ & $1087$ & $4223$ \\ \hline Montgomery & $m^2 + m$ & $n$ must be odd & $72$ & $1056$ & $4160$ \\ \hline D.R. & $2m$ & $n = \beta^m - k$ & $16$ & $64$ & $128$ \\ \hline \end{tabular} \end{small} \end{center} In theory Montgomery and Barrett reductions would require roughly the same amount of time to complete. However, in practice since Montgomery reduction can be written as a single function with the Comba technique it is much faster. Barrett reduction suffers from the overhead of calling the half precision multipliers, addition and division by $\beta$ algorithms. For almost every cryptographic algorithm Montgomery reduction is the algorithm of choice. The one set of algorithms where Diminished Radix reduction truly shines are based on the discrete logarithm problem such as Diffie-Hellman \cite{DH} and ElGamal \cite{ELGAMAL}. In these algorithms primes of the form $\beta^m - k$ can be found and shared amongst users. These primes will allow the Diminished Radix algorithm to be used in modular exponentiation to greatly speed up the operation. \section*{Exercises} \begin{tabular}{cl} $\left [ 3 \right ]$ & Prove that the ``trick'' in algorithm mp\_montgomery\_setup actually \\ & calculates the correct value of $\rho$. \\ & \\ $\left [ 2 \right ]$ & Devise an algorithm to reduce modulo $n + k$ for small $k$ quickly. \\ & \\ $\left [ 4 \right ]$ & Prove that the pseudo-code algorithm ``Diminished Radix Reduction'' \\ & (\textit{figure~\ref{fig:DR}}) terminates. Also prove the probability that it will \\ & terminate within $1 \le k \le 10$ iterations. \\ & \\ \end{tabular} \chapter{Exponentiation} Exponentiation is the operation of raising one variable to the power of another, for example, $a^b$. A variant of exponentiation, computed in a finite field or ring, is called modular exponentiation. This latter style of operation is typically used in public key cryptosystems such as RSA and Diffie-Hellman. The ability to quickly compute modular exponentiations is of great benefit to any such cryptosystem and many methods have been sought to speed it up. \section{Exponentiation Basics} A trivial algorithm would simply multiply $a$ against itself $b - 1$ times to compute the exponentiation desired. However, as $b$ grows in size the number of multiplications becomes prohibitive. Imagine what would happen if $b$ $\approx$ $2^{1024}$ as is the case when computing an RSA signature with a $1024$-bit key. Such a calculation could never be completed as it would take simply far too long. Fortunately there is a very simple algorithm based on the laws of exponents. Recall that $lg_a(a^b) = b$ and that $lg_a(a^ba^c) = b + c$ which are two trivial relationships between the base and the exponent. Let $b_i$ represent the $i$'th bit of $b$ starting from the least significant bit. If $b$ is a $k$-bit integer than the following equation is true. \begin{equation} a^b = \prod_{i=0}^{k-1} a^{2^i \cdot b_i} \end{equation} By taking the base $a$ logarithm of both sides of the equation the following equation is the result. \begin{equation} b = \sum_{i=0}^{k-1}2^i \cdot b_i \end{equation} The term $a^{2^i}$ can be found from the $i - 1$'th term by squaring the term since $\left ( a^{2^i} \right )^2$ is equal to $a^{2^{i+1}}$. This observation forms the basis of essentially all fast exponentiation algorithms. It requires $k$ squarings and on average $k \over 2$ multiplications to compute the result. This is indeed quite an improvement over simply multiplying by $a$ a total of $b-1$ times. While this current method is a considerable speed up there are further improvements to be made. For example, the $a^{2^i}$ term does not need to be computed in an auxilary variable. Consider the following equivalent algorithm. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{Left to Right Exponentiation}. \\ \textbf{Input}. Integer $a$, $b$ and $k$ \\ \textbf{Output}. $c = a^b$ \\ \hline \\ 1. $c \leftarrow 1$ \\ 2. for $i$ from $k - 1$ to $0$ do \\ \hspace{3mm}2.1 $c \leftarrow c^2$ \\ \hspace{3mm}2.2 $c \leftarrow c \cdot a^{b_i}$ \\ 3. Return $c$. \\ \hline \end{tabular} \end{center} \end{small} \caption{Left to Right Exponentiation} \label{fig:LTOR} \end{figure} This algorithm starts from the most significant bit and works towards the least significant bit. When the $i$'th bit of $b$ is set $a$ is multiplied against the current product. In each iteration the product is squared which doubles the exponent of the individual terms of the product. For example, let $b = 101100_2 \equiv 44_{10}$. The following chart demonstrates the actions of the algorithm. \newpage\begin{figure} \begin{center} \begin{tabular}{|c|c|} \hline \textbf{Value of $i$} & \textbf{Value of $c$} \\ \hline - & $1$ \\ \hline $5$ & $a$ \\ \hline $4$ & $a^2$ \\ \hline $3$ & $a^4 \cdot a$ \\ \hline $2$ & $a^8 \cdot a^2 \cdot a$ \\ \hline $1$ & $a^{16} \cdot a^4 \cdot a^2$ \\ \hline $0$ & $a^{32} \cdot a^8 \cdot a^4$ \\ \hline \end{tabular} \end{center} \caption{Example of Left to Right Exponentiation} \end{figure} When the product $a^{32} \cdot a^8 \cdot a^4$ is simplified it is equal $a^{44}$ which is the desired exponentiation. This particular algorithm is called ``Left to Right'' because it reads the exponent in that order. All of the exponentiation algorithms that will be presented are of this nature. \subsection{Single Digit Exponentiation} The first algorithm in the series of exponentiation algorithms will be an unbounded algorithm where the exponent is a single digit. It is intended to be used when a small power of an input is required (\textit{e.g. $a^5$}). It is faster than simply multiplying $b - 1$ times for all values of $b$ that are greater than three. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_expt\_d}. \\ \textbf{Input}. mp\_int $a$ and mp\_digit $b$ \\ \textbf{Output}. $c = a^b$ \\ \hline \\ 1. $g \leftarrow a$ (\textit{mp\_init\_copy}) \\ 2. $c \leftarrow 1$ (\textit{mp\_set}) \\ 3. for $x$ from 1 to $lg(\beta)$ do \\ \hspace{3mm}3.1 $c \leftarrow c^2$ (\textit{mp\_sqr}) \\ \hspace{3mm}3.2 If $b$ AND $2^{lg(\beta) - 1} \ne 0$ then \\ \hspace{6mm}3.2.1 $c \leftarrow c \cdot g$ (\textit{mp\_mul}) \\ \hspace{3mm}3.3 $b \leftarrow b << 1$ \\ 4. Clear $g$. \\ 5. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_expt\_d} \end{figure} \textbf{Algorithm mp\_expt\_d.} This algorithm computes the value of $a$ raised to the power of a single digit $b$. It uses the left to right exponentiation algorithm to quickly compute the exponentiation. It is loosely based on algorithm 14.79 of HAC \cite[pp. 615]{HAC} with the difference that the exponent is a fixed width. A copy of $a$ is made first to allow destination variable $c$ be the same as the source variable $a$. The result is set to the initial value of $1$ in the subsequent step. Inside the loop the exponent is read from the most significant bit first down to the least significant bit. First $c$ is invariably squared on step 3.1. In the following step if the most significant bit of $b$ is one the copy of $a$ is multiplied against $c$. The value of $b$ is shifted left one bit to make the next bit down from the most signficant bit the new most significant bit. In effect each iteration of the loop moves the bits of the exponent $b$ upwards to the most significant location. EXAM,bn_mp_expt_d.c Line @29,mp_set@ sets the initial value of the result to $1$. Next the loop on line @31,for@ steps through each bit of the exponent starting from the most significant down towards the least significant. The invariant squaring operation placed on line @333,mp_sqr@ is performed first. After the squaring the result $c$ is multiplied by the base $g$ if and only if the most significant bit of the exponent is set. The shift on line @47,<<@ moves all of the bits of the exponent upwards towards the most significant location. \section{$k$-ary Exponentiation} When calculating an exponentiation the most time consuming bottleneck is the multiplications which are in general a small factor slower than squaring. Recall from the previous algorithm that $b_{i}$ refers to the $i$'th bit of the exponent $b$. Suppose instead it referred to the $i$'th $k$-bit digit of the exponent of $b$. For $k = 1$ the definitions are synonymous and for $k > 1$ algorithm~\ref{fig:KARY} computes the same exponentiation. A group of $k$ bits from the exponent is called a \textit{window}. That is it is a small window on only a portion of the entire exponent. Consider the following modification to the basic left to right exponentiation algorithm. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{$k$-ary Exponentiation}. \\ \textbf{Input}. Integer $a$, $b$, $k$ and $t$ \\ \textbf{Output}. $c = a^b$ \\ \hline \\ 1. $c \leftarrow 1$ \\ 2. for $i$ from $t - 1$ to $0$ do \\ \hspace{3mm}2.1 $c \leftarrow c^{2^k} $ \\ \hspace{3mm}2.2 Extract the $i$'th $k$-bit word from $b$ and store it in $g$. \\ \hspace{3mm}2.3 $c \leftarrow c \cdot a^g$ \\ 3. Return $c$. \\ \hline \end{tabular} \end{center} \end{small} \caption{$k$-ary Exponentiation} \label{fig:KARY} \end{figure} The squaring on step 2.1 can be calculated by squaring the value $c$ successively $k$ times. If the values of $a^g$ for $0 < g < 2^k$ have been precomputed this algorithm requires only $t$ multiplications and $tk$ squarings. The table can be generated with $2^{k - 1} - 1$ squarings and $2^{k - 1} + 1$ multiplications. This algorithm assumes that the number of bits in the exponent is evenly divisible by $k$. However, when it is not the remaining $0 < x \le k - 1$ bits can be handled with algorithm~\ref{fig:LTOR}. Suppose $k = 4$ and $t = 100$. This modified algorithm will require $109$ multiplications and $408$ squarings to compute the exponentiation. The original algorithm would on average have required $200$ multiplications and $400$ squrings to compute the same value. The total number of squarings has increased slightly but the number of multiplications has nearly halved. \subsection{Optimal Values of $k$} An optimal value of $k$ will minimize $2^{k} + \lceil n / k \rceil + n - 1$ for a fixed number of bits in the exponent $n$. The simplest approach is to brute force search amongst the values $k = 2, 3, \ldots, 8$ for the lowest result. Table~\ref{fig:OPTK} lists optimal values of $k$ for various exponent sizes and compares the number of multiplication and squarings required against algorithm~\ref{fig:LTOR}. \begin{figure}[here] \begin{center} \begin{small} \begin{tabular}{|c|c|c|c|c|c|} \hline \textbf{Exponent (bits)} & \textbf{Optimal $k$} & \textbf{Work at $k$} & \textbf{Work with ~\ref{fig:LTOR}} \\ \hline $16$ & $2$ & $27$ & $24$ \\ \hline $32$ & $3$ & $49$ & $48$ \\ \hline $64$ & $3$ & $92$ & $96$ \\ \hline $128$ & $4$ & $175$ & $192$ \\ \hline $256$ & $4$ & $335$ & $384$ \\ \hline $512$ & $5$ & $645$ & $768$ \\ \hline $1024$ & $6$ & $1257$ & $1536$ \\ \hline $2048$ & $6$ & $2452$ & $3072$ \\ \hline $4096$ & $7$ & $4808$ & $6144$ \\ \hline \end{tabular} \end{small} \end{center} \caption{Optimal Values of $k$ for $k$-ary Exponentiation} \label{fig:OPTK} \end{figure} \subsection{Sliding-Window Exponentiation} A simple modification to the previous algorithm is only generate the upper half of the table in the range $2^{k-1} \le g < 2^k$. Essentially this is a table for all values of $g$ where the most significant bit of $g$ is a one. However, in order for this to be allowed in the algorithm values of $g$ in the range $0 \le g < 2^{k-1}$ must be avoided. Table~\ref{fig:OPTK2} lists optimal values of $k$ for various exponent sizes and compares the work required against algorithm~\ref{fig:KARY}. \begin{figure}[here] \begin{center} \begin{small} \begin{tabular}{|c|c|c|c|c|c|} \hline \textbf{Exponent (bits)} & \textbf{Optimal $k$} & \textbf{Work at $k$} & \textbf{Work with ~\ref{fig:KARY}} \\ \hline $16$ & $3$ & $24$ & $27$ \\ \hline $32$ & $3$ & $45$ & $49$ \\ \hline $64$ & $4$ & $87$ & $92$ \\ \hline $128$ & $4$ & $167$ & $175$ \\ \hline $256$ & $5$ & $322$ & $335$ \\ \hline $512$ & $6$ & $628$ & $645$ \\ \hline $1024$ & $6$ & $1225$ & $1257$ \\ \hline $2048$ & $7$ & $2403$ & $2452$ \\ \hline $4096$ & $8$ & $4735$ & $4808$ \\ \hline \end{tabular} \end{small} \end{center} \caption{Optimal Values of $k$ for Sliding Window Exponentiation} \label{fig:OPTK2} \end{figure} \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{Sliding Window $k$-ary Exponentiation}. \\ \textbf{Input}. Integer $a$, $b$, $k$ and $t$ \\ \textbf{Output}. $c = a^b$ \\ \hline \\ 1. $c \leftarrow 1$ \\ 2. for $i$ from $t - 1$ to $0$ do \\ \hspace{3mm}2.1 If the $i$'th bit of $b$ is a zero then \\ \hspace{6mm}2.1.1 $c \leftarrow c^2$ \\ \hspace{3mm}2.2 else do \\ \hspace{6mm}2.2.1 $c \leftarrow c^{2^k}$ \\ \hspace{6mm}2.2.2 Extract the $k$ bits from $(b_{i}b_{i-1}\ldots b_{i-(k-1)})$ and store it in $g$. \\ \hspace{6mm}2.2.3 $c \leftarrow c \cdot a^g$ \\ \hspace{6mm}2.2.4 $i \leftarrow i - k$ \\ 3. Return $c$. \\ \hline \end{tabular} \end{center} \end{small} \caption{Sliding Window $k$-ary Exponentiation} \end{figure} Similar to the previous algorithm this algorithm must have a special handler when fewer than $k$ bits are left in the exponent. While this algorithm requires the same number of squarings it can potentially have fewer multiplications. The pre-computed table $a^g$ is also half the size as the previous table. Consider the exponent $b = 111101011001000_2 \equiv 31432_{10}$ with $k = 3$ using both algorithms. The first algorithm will divide the exponent up as the following five $3$-bit words $b \equiv \left ( 111, 101, 011, 001, 000 \right )_{2}$. The second algorithm will break the exponent as $b \equiv \left ( 111, 101, 0, 110, 0, 100, 0 \right )_{2}$. The single digit $0$ in the second representation are where a single squaring took place instead of a squaring and multiplication. In total the first method requires $10$ multiplications and $18$ squarings. The second method requires $8$ multiplications and $18$ squarings. In general the sliding window method is never slower than the generic $k$-ary method and often it is slightly faster. \section{Modular Exponentiation} Modular exponentiation is essentially computing the power of a base within a finite field or ring. For example, computing $d \equiv a^b \mbox{ (mod }c\mbox{)}$ is a modular exponentiation. Instead of first computing $a^b$ and then reducing it modulo $c$ the intermediate result is reduced modulo $c$ after every squaring or multiplication operation. This guarantees that any intermediate result is bounded by $0 \le d \le c^2 - 2c + 1$ and can be reduced modulo $c$ quickly using one of the algorithms presented in ~REDUCTION~. Before the actual modular exponentiation algorithm can be written a wrapper algorithm must be written first. This algorithm will allow the exponent $b$ to be negative which is computed as $c \equiv \left (1 / a \right )^{\vert b \vert} \mbox{(mod }d\mbox{)}$. The value of $(1/a) \mbox{ mod }c$ is computed using the modular inverse (\textit{see \ref{sec;modinv}}). If no inverse exists the algorithm terminates with an error. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_exptmod}. \\ \textbf{Input}. mp\_int $a$, $b$ and $c$ \\ \textbf{Output}. $y \equiv g^x \mbox{ (mod }p\mbox{)}$ \\ \hline \\ 1. If $c.sign = MP\_NEG$ return(\textit{MP\_VAL}). \\ 2. If $b.sign = MP\_NEG$ then \\ \hspace{3mm}2.1 $g' \leftarrow g^{-1} \mbox{ (mod }c\mbox{)}$ \\ \hspace{3mm}2.2 $x' \leftarrow \vert x \vert$ \\ \hspace{3mm}2.3 Compute $d \equiv g'^{x'} \mbox{ (mod }c\mbox{)}$ via recursion. \\ 3. if $p$ is odd \textbf{OR} $p$ is a D.R. modulus then \\ \hspace{3mm}3.1 Compute $y \equiv g^{x} \mbox{ (mod }p\mbox{)}$ via algorithm mp\_exptmod\_fast. \\ 4. else \\ \hspace{3mm}4.1 Compute $y \equiv g^{x} \mbox{ (mod }p\mbox{)}$ via algorithm s\_mp\_exptmod. \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_exptmod} \end{figure} \textbf{Algorithm mp\_exptmod.} The first algorithm which actually performs modular exponentiation is algorithm s\_mp\_exptmod. It is a sliding window $k$-ary algorithm which uses Barrett reduction to reduce the product modulo $p$. The second algorithm mp\_exptmod\_fast performs the same operation except it uses either Montgomery or Diminished Radix reduction. The two latter reduction algorithms are clumped in the same exponentiation algorithm since their arguments are essentially the same (\textit{two mp\_ints and one mp\_digit}). EXAM,bn_mp_exptmod.c In order to keep the algorithms in a known state the first step on line @29,if@ is to reject any negative modulus as input. If the exponent is negative the algorithm tries to perform a modular exponentiation with the modular inverse of the base $G$. The temporary variable $tmpG$ is assigned the modular inverse of $G$ and $tmpX$ is assigned the absolute value of $X$. The algorithm will recuse with these new values with a positive exponent. If the exponent is positive the algorithm resumes the exponentiation. Line @63,dr_@ determines if the modulus is of the restricted Diminished Radix form. If it is not line @65,reduce@ attempts to determine if it is of a unrestricted Diminished Radix form. The integer $dr$ will take on one of three values. \begin{enumerate} \item $dr = 0$ means that the modulus is not of either restricted or unrestricted Diminished Radix form. \item $dr = 1$ means that the modulus is of restricted Diminished Radix form. \item $dr = 2$ means that the modulus is of unrestricted Diminished Radix form. \end{enumerate} Line @69,if@ determines if the fast modular exponentiation algorithm can be used. It is allowed if $dr \ne 0$ or if the modulus is odd. Otherwise, the slower s\_mp\_exptmod algorithm is used which uses Barrett reduction. \subsection{Barrett Modular Exponentiation} \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{s\_mp\_exptmod}. \\ \textbf{Input}. mp\_int $a$, $b$ and $c$ \\ \textbf{Output}. $y \equiv g^x \mbox{ (mod }p\mbox{)}$ \\ \hline \\ 1. $k \leftarrow lg(x)$ \\ 2. $winsize \leftarrow \left \lbrace \begin{array}{ll} 2 & \mbox{if }k \le 7 \\ 3 & \mbox{if }7 < k \le 36 \\ 4 & \mbox{if }36 < k \le 140 \\ 5 & \mbox{if }140 < k \le 450 \\ 6 & \mbox{if }450 < k \le 1303 \\ 7 & \mbox{if }1303 < k \le 3529 \\ 8 & \mbox{if }3529 < k \\ \end{array} \right .$ \\ 3. Initialize $2^{winsize}$ mp\_ints in an array named $M$ and one mp\_int named $\mu$ \\ 4. Calculate the $\mu$ required for Barrett Reduction (\textit{mp\_reduce\_setup}). \\ 5. $M_1 \leftarrow g \mbox{ (mod }p\mbox{)}$ \\ \\ Setup the table of small powers of $g$. First find $g^{2^{winsize}}$ and then all multiples of it. \\ 6. $k \leftarrow 2^{winsize - 1}$ \\ 7. $M_{k} \leftarrow M_1$ \\ 8. for $ix$ from 0 to $winsize - 2$ do \\ \hspace{3mm}8.1 $M_k \leftarrow \left ( M_k \right )^2$ (\textit{mp\_sqr}) \\ \hspace{3mm}8.2 $M_k \leftarrow M_k \mbox{ (mod }p\mbox{)}$ (\textit{mp\_reduce}) \\ 9. for $ix$ from $2^{winsize - 1} + 1$ to $2^{winsize} - 1$ do \\ \hspace{3mm}9.1 $M_{ix} \leftarrow M_{ix - 1} \cdot M_{1}$ (\textit{mp\_mul}) \\ \hspace{3mm}9.2 $M_{ix} \leftarrow M_{ix} \mbox{ (mod }p\mbox{)}$ (\textit{mp\_reduce}) \\ 10. $res \leftarrow 1$ \\ \\ Start Sliding Window. \\ 11. $mode \leftarrow 0, bitcnt \leftarrow 1, buf \leftarrow 0, digidx \leftarrow x.used - 1, bitcpy \leftarrow 0, bitbuf \leftarrow 0$ \\ 12. Loop \\ \hspace{3mm}12.1 $bitcnt \leftarrow bitcnt - 1$ \\ \hspace{3mm}12.2 If $bitcnt = 0$ then do \\ \hspace{6mm}12.2.1 If $digidx = -1$ goto step 13. \\ \hspace{6mm}12.2.2 $buf \leftarrow x_{digidx}$ \\ \hspace{6mm}12.2.3 $digidx \leftarrow digidx - 1$ \\ \hspace{6mm}12.2.4 $bitcnt \leftarrow lg(\beta)$ \\ Continued on next page. \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm s\_mp\_exptmod} \end{figure} \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{s\_mp\_exptmod} (\textit{continued}). \\ \textbf{Input}. mp\_int $a$, $b$ and $c$ \\ \textbf{Output}. $y \equiv g^x \mbox{ (mod }p\mbox{)}$ \\ \hline \\ \hspace{3mm}12.3 $y \leftarrow (buf >> (lg(\beta) - 1))$ AND $1$ \\ \hspace{3mm}12.4 $buf \leftarrow buf << 1$ \\ \hspace{3mm}12.5 if $mode = 0$ and $y = 0$ then goto step 12. \\ \hspace{3mm}12.6 if $mode = 1$ and $y = 0$ then do \\ \hspace{6mm}12.6.1 $res \leftarrow res^2$ \\ \hspace{6mm}12.6.2 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ \hspace{6mm}12.6.3 Goto step 12. \\ \hspace{3mm}12.7 $bitcpy \leftarrow bitcpy + 1$ \\ \hspace{3mm}12.8 $bitbuf \leftarrow bitbuf + (y << (winsize - bitcpy))$ \\ \hspace{3mm}12.9 $mode \leftarrow 2$ \\ \hspace{3mm}12.10 If $bitcpy = winsize$ then do \\ \hspace{6mm}Window is full so perform the squarings and single multiplication. \\ \hspace{6mm}12.10.1 for $ix$ from $0$ to $winsize -1$ do \\ \hspace{9mm}12.10.1.1 $res \leftarrow res^2$ \\ \hspace{9mm}12.10.1.2 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ \hspace{6mm}12.10.2 $res \leftarrow res \cdot M_{bitbuf}$ \\ \hspace{6mm}12.10.3 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ \hspace{6mm}Reset the window. \\ \hspace{6mm}12.10.4 $bitcpy \leftarrow 0, bitbuf \leftarrow 0, mode \leftarrow 1$ \\ \\ No more windows left. Check for residual bits of exponent. \\ 13. If $mode = 2$ and $bitcpy > 0$ then do \\ \hspace{3mm}13.1 for $ix$ form $0$ to $bitcpy - 1$ do \\ \hspace{6mm}13.1.1 $res \leftarrow res^2$ \\ \hspace{6mm}13.1.2 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ \hspace{6mm}13.1.3 $bitbuf \leftarrow bitbuf << 1$ \\ \hspace{6mm}13.1.4 If $bitbuf$ AND $2^{winsize} \ne 0$ then do \\ \hspace{9mm}13.1.4.1 $res \leftarrow res \cdot M_{1}$ \\ \hspace{9mm}13.1.4.2 $res \leftarrow res \mbox{ (mod }p\mbox{)}$ \\ 14. $y \leftarrow res$ \\ 15. Clear $res$, $mu$ and the $M$ array. \\ 16. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm s\_mp\_exptmod (continued)} \end{figure} \textbf{Algorithm s\_mp\_exptmod.} This algorithm computes the $x$'th power of $g$ modulo $p$ and stores the result in $y$. It takes advantage of the Barrett reduction algorithm to keep the product small throughout the algorithm. The first two steps determine the optimal window size based on the number of bits in the exponent. The larger the exponent the larger the window size becomes. After a window size $winsize$ has been chosen an array of $2^{winsize}$ mp\_int variables is allocated. This table will hold the values of $g^x \mbox{ (mod }p\mbox{)}$ for $2^{winsize - 1} \le x < 2^{winsize}$. After the table is allocated the first power of $g$ is found. Since $g \ge p$ is allowed it must be first reduced modulo $p$ to make the rest of the algorithm more efficient. The first element of the table at $2^{winsize - 1}$ is found by squaring $M_1$ successively $winsize - 2$ times. The rest of the table elements are found by multiplying the previous element by $M_1$ modulo $p$. Now that the table is available the sliding window may begin. The following list describes the functions of all the variables in the window. \begin{enumerate} \item The variable $mode$ dictates how the bits of the exponent are interpreted. \begin{enumerate} \item When $mode = 0$ the bits are ignored since no non-zero bit of the exponent has been seen yet. For example, if the exponent were simply $1$ then there would be $lg(\beta) - 1$ zero bits before the first non-zero bit. In this case bits are ignored until a non-zero bit is found. \item When $mode = 1$ a non-zero bit has been seen before and a new $winsize$-bit window has not been formed yet. In this mode leading $0$ bits are read and a single squaring is performed. If a non-zero bit is read a new window is created. \item When $mode = 2$ the algorithm is in the middle of forming a window and new bits are appended to the window from the most significant bit downwards. \end{enumerate} \item The variable $bitcnt$ indicates how many bits are left in the current digit of the exponent left to be read. When it reaches zero a new digit is fetched from the exponent. \item The variable $buf$ holds the currently read digit of the exponent. \item The variable $digidx$ is an index into the exponents digits. It starts at the leading digit $x.used - 1$ and moves towards the trailing digit. \item The variable $bitcpy$ indicates how many bits are in the currently formed window. When it reaches $winsize$ the window is flushed and the appropriate operations performed. \item The variable $bitbuf$ holds the current bits of the window being formed. \end{enumerate} All of step 12 is the window processing loop. It will iterate while there are digits available form the exponent to read. The first step inside this loop is to extract a new digit if no more bits are available in the current digit. If there are no bits left a new digit is read and if there are no digits left than the loop terminates. After a digit is made available step 12.3 will extract the most significant bit of the current digit and move all other bits in the digit upwards. In effect the digit is read from most significant bit to least significant bit and since the digits are read from leading to trailing edges the entire exponent is read from most significant bit to least significant bit. At step 12.5 if the $mode$ and currently extracted bit $y$ are both zero the bit is ignored and the next bit is read. This prevents the algorithm from having to perform trivial squaring and reduction operations before the first non-zero bit is read. Step 12.6 and 12.7-10 handle the two cases of $mode = 1$ and $mode = 2$ respectively. FIGU,expt_state,Sliding Window State Diagram By step 13 there are no more digits left in the exponent. However, there may be partial bits in the window left. If $mode = 2$ then a Left-to-Right algorithm is used to process the remaining few bits. EXAM,bn_s_mp_exptmod.c Lines @26,if@ through @40,}@ determine the optimal window size based on the length of the exponent in bits. The window divisions are sorted from smallest to greatest so that in each \textbf{if} statement only one condition must be tested. For example, by the \textbf{if} statement on line @32,if@ the value of $x$ is already known to be greater than $140$. The conditional piece of code beginning on line @42,ifdef@ allows the window size to be restricted to five bits. This logic is used to ensure the table of precomputed powers of $G$ remains relatively small. The for loop on line @49,for@ initializes the $M$ array while lines @59,mp_init@ and @62,mp_reduce@ compute the value of $\mu$ required for Barrett reduction. -- More later. \section{Quick Power of Two} Calculating $b = 2^a$ can be performed much quicker than with any of the previous algorithms. Recall that a logical shift left $m << k$ is equivalent to $m \cdot 2^k$. By this logic when $m = 1$ a quick power of two can be achieved. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_2expt}. \\ \textbf{Input}. integer $b$ \\ \textbf{Output}. $a \leftarrow 2^b$ \\ \hline \\ 1. $a \leftarrow 0$ \\ 2. If $a.alloc < \lfloor b / lg(\beta) \rfloor + 1$ then grow $a$ appropriately. \\ 3. $a.used \leftarrow \lfloor b / lg(\beta) \rfloor + 1$ \\ 4. $a_{\lfloor b / lg(\beta) \rfloor} \leftarrow 1 << (b \mbox{ mod } lg(\beta))$ \\ 5. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_2expt} \end{figure} \textbf{Algorithm mp\_2expt.} EXAM,bn_mp_2expt.c \chapter{Higher Level Algorithms} This chapter discusses the various higher level algorithms that are required to complete a well rounded multiple precision integer package. These routines are less performance oriented than the algorithms of chapters five, six and seven but are no less important. The first section describes a method of integer division with remainder that is universally well known. It provides the signed division logic for the package. The subsequent section discusses a set of algorithms which allow a single digit to be the 2nd operand for a variety of operations. These algorithms serve mostly to simplify other algorithms where small constants are required. The last two sections discuss how to manipulate various representations of integers. For example, converting from an mp\_int to a string of character. \section{Integer Division with Remainder} \label{sec:division} Integer division aside from modular exponentiation is the most intensive algorithm to compute. Like addition, subtraction and multiplication the basis of this algorithm is the long-hand division algorithm taught to school children. Throughout this discussion several common variables will be used. Let $x$ represent the divisor and $y$ represent the dividend. Let $q$ represent the integer quotient $\lfloor y / x \rfloor$ and let $r$ represent the remainder $r = y - x \lfloor y / x \rfloor$. The following simple algorithm will be used to start the discussion. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{Radix-$\beta$ Integer Division}. \\ \textbf{Input}. integer $x$ and $y$ \\ \textbf{Output}. $q = \lfloor y/x\rfloor, r = y - xq$ \\ \hline \\ 1. $q \leftarrow 0$ \\ 2. $n \leftarrow \vert \vert y \vert \vert - \vert \vert x \vert \vert$ \\ 3. for $t$ from $n$ down to $0$ do \\ \hspace{3mm}3.1 Maximize $k$ such that $kx\beta^t$ is less than or equal to $y$ and $(k + 1)x\beta^t$ is greater. \\ \hspace{3mm}3.2 $q \leftarrow q + k\beta^t$ \\ \hspace{3mm}3.3 $y \leftarrow y - kx\beta^t$ \\ 4. $r \leftarrow y$ \\ 5. Return($q, r$) \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm Radix-$\beta$ Integer Division} \label{fig:raddiv} \end{figure} As children we are taught this very simple algorithm for the case of $\beta = 10$. Almost instinctively several optimizations are taught for which their reason of existing are never explained. For this example let $y = 5471$ represent the dividend and $x = 23$ represent the divisor. To find the first digit of the quotient the value of $k$ must be maximized such that $kx\beta^t$ is less than or equal to $y$ and simultaneously $(k + 1)x\beta^t$ is greater than $y$. Implicitly $k$ is the maximum value the $t$'th digit of the quotient may have. The habitual method used to find the maximum is to ``eyeball'' the two numbers, typically only the leading digits and quickly estimate a quotient. By only using leading digits a much simpler division may be used to form an educated guess at what the value must be. In this case $k = \lfloor 54/23\rfloor = 2$ quickly arises as a possible solution. Indeed $2x\beta^2 = 4600$ is less than $y = 5471$ and simultaneously $(k + 1)x\beta^2 = 6900$ is larger than $y$. As a result $k\beta^2$ is added to the quotient which now equals $q = 200$ and $4600$ is subtracted from $y$ to give a remainder of $y = 841$. Again this process is repeated to produce the quotient digit $k = 3$ which makes the quotient $q = 200 + 3\beta = 230$ and the remainder $y = 841 - 3x\beta = 181$. Finally the last iteration of the loop produces $k = 7$ which leads to the quotient $q = 230 + 7 = 237$ and the remainder $y = 181 - 7x = 20$. The final quotient and remainder found are $q = 237$ and $r = y = 20$ which are indeed correct since $237 \cdot 23 + 20 = 5471$ is true. \subsection{Quotient Estimation} \label{sec:divest} As alluded to earlier the quotient digit $k$ can be estimated from only the leading digits of both the divisor and dividend. When $p$ leading digits are used from both the divisor and dividend to form an estimation the accuracy of the estimation rises as $p$ grows. Technically speaking the estimation is based on assuming the lower $\vert \vert y \vert \vert - p$ and $\vert \vert x \vert \vert - p$ lower digits of the dividend and divisor are zero. The value of the estimation may off by a few values in either direction and in general is fairly correct. A simplification \cite[pp. 271]{TAOCPV2} of the estimation technique is to use $t + 1$ digits of the dividend and $t$ digits of the divisor, in particularly when $t = 1$. The estimate using this technique is never too small. For the following proof let $t = \vert \vert y \vert \vert - 1$ and $s = \vert \vert x \vert \vert - 1$ represent the most significant digits of the dividend and divisor respectively. \textbf{Proof.}\textit{ The quotient $\hat k = \lfloor (y_t\beta + y_{t-1}) / x_s \rfloor$ is greater than or equal to $k = \lfloor y / (x \cdot \beta^{\vert \vert y \vert \vert - \vert \vert x \vert \vert - 1}) \rfloor$. } The first obvious case is when $\hat k = \beta - 1$ in which case the proof is concluded since the real quotient cannot be larger. For all other cases $\hat k = \lfloor (y_t\beta + y_{t-1}) / x_s \rfloor$ and $\hat k x_s \ge y_t\beta + y_{t-1} - x_s + 1$. The latter portion of the inequalility $-x_s + 1$ arises from the fact that a truncated integer division will give the same quotient for at most $x_s - 1$ values. Next a series of inequalities will prove the hypothesis. \begin{equation} y - \hat k x \le y - \hat k x_s\beta^s \end{equation} This is trivially true since $x \ge x_s\beta^s$. Next we replace $\hat kx_s\beta^s$ by the previous inequality for $\hat kx_s$. \begin{equation} y - \hat k x \le y_t\beta^t + \ldots + y_0 - (y_t\beta^t + y_{t-1}\beta^{t-1} - x_s\beta^t + \beta^s) \end{equation} By simplifying the previous inequality the following inequality is formed. \begin{equation} y - \hat k x \le y_{t-2}\beta^{t-2} + \ldots + y_0 + x_s\beta^s - \beta^s \end{equation} Subsequently, \begin{equation} y_{t-2}\beta^{t-2} + \ldots + y_0 + x_s\beta^s - \beta^s < x_s\beta^s \le x \end{equation} Which proves that $y - \hat kx \le x$ and by consequence $\hat k \ge k$ which concludes the proof. \textbf{QED} \subsection{Normalized Integers} For the purposes of division a normalized input is when the divisors leading digit $x_n$ is greater than or equal to $\beta / 2$. By multiplying both $x$ and $y$ by $j = \lfloor (\beta / 2) / x_n \rfloor$ the quotient remains unchanged and the remainder is simply $j$ times the original remainder. The purpose of normalization is to ensure the leading digit of the divisor is sufficiently large such that the estimated quotient will lie in the domain of a single digit. Consider the maximum dividend $(\beta - 1) \cdot \beta + (\beta - 1)$ and the minimum divisor $\beta / 2$. \begin{equation} {{\beta^2 - 1} \over { \beta / 2}} \le 2\beta - {2 \over \beta} \end{equation} At most the quotient approaches $2\beta$, however, in practice this will not occur since that would imply the previous quotient digit was too small. \subsection{Radix-$\beta$ Division with Remainder} \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_div}. \\ \textbf{Input}. mp\_int $a, b$ \\ \textbf{Output}. $c = \lfloor a/b \rfloor$, $d = a - bc$ \\ \hline \\ 1. If $b = 0$ return(\textit{MP\_VAL}). \\ 2. If $\vert a \vert < \vert b \vert$ then do \\ \hspace{3mm}2.1 $d \leftarrow a$ \\ \hspace{3mm}2.2 $c \leftarrow 0$ \\ \hspace{3mm}2.3 Return(\textit{MP\_OKAY}). \\ \\ Setup the quotient to receive the digits. \\ 3. Grow $q$ to $a.used + 2$ digits. \\ 4. $q \leftarrow 0$ \\ 5. $x \leftarrow \vert a \vert , y \leftarrow \vert b \vert$ \\ 6. $sign \leftarrow \left \lbrace \begin{array}{ll} MP\_ZPOS & \mbox{if }a.sign = b.sign \\ MP\_NEG & \mbox{otherwise} \\ \end{array} \right .$ \\ \\ Normalize the inputs such that the leading digit of $y$ is greater than or equal to $\beta / 2$. \\ 7. $norm \leftarrow (lg(\beta) - 1) - (\lceil lg(y) \rceil \mbox{ (mod }lg(\beta)\mbox{)})$ \\ 8. $x \leftarrow x \cdot 2^{norm}, y \leftarrow y \cdot 2^{norm}$ \\ \\ Find the leading digit of the quotient. \\ 9. $n \leftarrow x.used - 1, t \leftarrow y.used - 1$ \\ 10. $y \leftarrow y \cdot \beta^{n - t}$ \\ 11. While ($x \ge y$) do \\ \hspace{3mm}11.1 $q_{n - t} \leftarrow q_{n - t} + 1$ \\ \hspace{3mm}11.2 $x \leftarrow x - y$ \\ 12. $y \leftarrow \lfloor y / \beta^{n-t} \rfloor$ \\ \\ Continued on the next page. \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_div} \end{figure} \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_div} (continued). \\ \textbf{Input}. mp\_int $a, b$ \\ \textbf{Output}. $c = \lfloor a/b \rfloor$, $d = a - bc$ \\ \hline \\ Now find the remainder fo the digits. \\ 13. for $i$ from $n$ down to $(t + 1)$ do \\ \hspace{3mm}13.1 If $i > x.used$ then jump to the next iteration of this loop. \\ \hspace{3mm}13.2 If $x_{i} = y_{t}$ then \\ \hspace{6mm}13.2.1 $q_{i - t - 1} \leftarrow \beta - 1$ \\ \hspace{3mm}13.3 else \\ \hspace{6mm}13.3.1 $\hat r \leftarrow x_{i} \cdot \beta + x_{i - 1}$ \\ \hspace{6mm}13.3.2 $\hat r \leftarrow \lfloor \hat r / y_{t} \rfloor$ \\ \hspace{6mm}13.3.3 $q_{i - t - 1} \leftarrow \hat r$ \\ \hspace{3mm}13.4 $q_{i - t - 1} \leftarrow q_{i - t - 1} + 1$ \\ \\ Fixup quotient estimation. \\ \hspace{3mm}13.5 Loop \\ \hspace{6mm}13.5.1 $q_{i - t - 1} \leftarrow q_{i - t - 1} - 1$ \\ \hspace{6mm}13.5.2 t$1 \leftarrow 0$ \\ \hspace{6mm}13.5.3 t$1_0 \leftarrow y_{t - 1}, $ t$1_1 \leftarrow y_t,$ t$1.used \leftarrow 2$ \\ \hspace{6mm}13.5.4 $t1 \leftarrow t1 \cdot q_{i - t - 1}$ \\ \hspace{6mm}13.5.5 t$2_0 \leftarrow x_{i - 2}, $ t$2_1 \leftarrow x_{i - 1}, $ t$2_2 \leftarrow x_i, $ t$2.used \leftarrow 3$ \\ \hspace{6mm}13.5.6 If $\vert t1 \vert > \vert t2 \vert$ then goto step 13.5. \\ \hspace{3mm}13.6 t$1 \leftarrow y \cdot q_{i - t - 1}$ \\ \hspace{3mm}13.7 t$1 \leftarrow $ t$1 \cdot \beta^{i - t - 1}$ \\ \hspace{3mm}13.8 $x \leftarrow x - $ t$1$ \\ \hspace{3mm}13.9 If $x.sign = MP\_NEG$ then \\ \hspace{6mm}13.10 t$1 \leftarrow y$ \\ \hspace{6mm}13.11 t$1 \leftarrow $ t$1 \cdot \beta^{i - t - 1}$ \\ \hspace{6mm}13.12 $x \leftarrow x + $ t$1$ \\ \hspace{6mm}13.13 $q_{i - t - 1} \leftarrow q_{i - t - 1} - 1$ \\ \\ Finalize the result. \\ 14. Clamp excess digits of $q$ \\ 15. $c \leftarrow q, c.sign \leftarrow sign$ \\ 16. $x.sign \leftarrow a.sign$ \\ 17. $d \leftarrow \lfloor x / 2^{norm} \rfloor$ \\ 18. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_div (continued)} \end{figure} \textbf{Algorithm mp\_div.} This algorithm will calculate quotient and remainder from an integer division given a dividend and divisor. The algorithm is a signed division and will produce a fully qualified quotient and remainder. First the divisor $b$ must be non-zero which is enforced in step one. If the divisor is larger than the dividend than the quotient is implicitly zero and the remainder is the dividend. After the first two trivial cases of inputs are handled the variable $q$ is setup to receive the digits of the quotient. Two unsigned copies of the divisor $y$ and dividend $x$ are made as well. The core of the division algorithm is an unsigned division and will only work if the values are positive. Now the two values $x$ and $y$ must be normalized such that the leading digit of $y$ is greater than or equal to $\beta / 2$. This is performed by shifting both to the left by enough bits to get the desired normalization. At this point the division algorithm can begin producing digits of the quotient. Recall that maximum value of the estimation used is $2\beta - {2 \over \beta}$ which means that a digit of the quotient must be first produced by another means. In this case $y$ is shifted to the left (\textit{step ten}) so that it has the same number of digits as $x$. The loop on step eleven will subtract multiples of the shifted copy of $y$ until $x$ is smaller. Since the leading digit of $y$ is greater than or equal to $\beta/2$ this loop will iterate at most two times to produce the desired leading digit of the quotient. Now the remainder of the digits can be produced. The equation $\hat q = \lfloor {{x_i \beta + x_{i-1}}\over y_t} \rfloor$ is used to fairly accurately approximate the true quotient digit. The estimation can in theory produce an estimation as high as $2\beta - {2 \over \beta}$ but by induction the upper quotient digit is correct (\textit{as established on step eleven}) and the estimate must be less than $\beta$. Recall from section~\ref{sec:divest} that the estimation is never too low but may be too high. The next step of the estimation process is to refine the estimation. The loop on step 13.5 uses $x_i\beta^2 + x_{i-1}\beta + x_{i-2}$ and $q_{i - t - 1}(y_t\beta + y_{t-1})$ as a higher order approximation to adjust the quotient digit. After both phases of estimation the quotient digit may still be off by a value of one\footnote{This is similar to the error introduced by optimizing Barrett reduction.}. Steps 13.6 and 13.7 subtract the multiple of the divisor from the dividend (\textit{Similar to step 3.3 of algorithm~\ref{fig:raddiv}} and then subsequently add a multiple of the divisor if the quotient was too large. Now that the quotient has been determine finializing the result is a matter of clamping the quotient, fixing the sizes and de-normalizing the remainder. An important aspect of this algorithm seemingly overlooked in other descriptions such as that of Algorithm 14.20 HAC \cite[pp. 598]{HAC} is that when the estimations are being made (\textit{inside the loop on step 13.5}) that the digits $y_{t-1}$, $x_{i-2}$ and $x_{i-1}$ may lie outside their respective boundaries. For example, if $t = 0$ or $i \le 1$ then the digits would be undefined. In those cases the digits should respectively be replaced with a zero. EXAM,bn_mp_div.c The implementation of this algorithm differs slightly from the pseudo code presented previously. In this algorithm either of the quotient $c$ or remainder $d$ may be passed as a \textbf{NULL} pointer which indicates their value is not desired. For example, the C code to call the division algorithm with only the quotient is \begin{verbatim} mp_div(&a, &b, &c, NULL); /* c = [a/b] */ \end{verbatim} Lines @37,if@ and @42,if@ handle the two trivial cases of inputs which are division by zero and dividend smaller than the divisor respectively. After the two trivial cases all of the temporary variables are initialized. Line @76,neg@ determines the sign of the quotient and line @77,sign@ ensures that both $x$ and $y$ are positive. The number of bits in the leading digit is calculated on line @80,norm@. Implictly an mp\_int with $r$ digits will require $lg(\beta)(r-1) + k$ bits of precision which when reduced modulo $lg(\beta)$ produces the value of $k$. In this case $k$ is the number of bits in the leading digit which is exactly what is required. For the algorithm to operate $k$ must equal $lg(\beta) - 1$ and when it does not the inputs must be normalized by shifting them to the left by $lg(\beta) - 1 - k$ bits. Throughout the variables $n$ and $t$ will represent the highest digit of $x$ and $y$ respectively. These are first used to produce the leading digit of the quotient. The loop beginning on line @113,for@ will produce the remainder of the quotient digits. The conditional ``continue'' on line @114,if@ is used to prevent the algorithm from reading past the leading edge of $x$ which can occur when the algorithm eliminates multiple non-zero digits in a single iteration. This ensures that $x_i$ is always non-zero since by definition the digits above the $i$'th position $x$ must be zero in order for the quotient to be precise\footnote{Precise as far as integer division is concerned.}. Lines @142,t1@, @143,t1@ and @150,t2@ through @152,t2@ manually construct the high accuracy estimations by setting the digits of the two mp\_int variables directly. \section{Single Digit Helpers} This section briefly describes a series of single digit helper algorithms which come in handy when working with small constants. All of the helper functions assume the single digit input is positive and will treat them as such. \subsection{Single Digit Addition and Subtraction} Both addition and subtraction are performed by ``cheating'' and using mp\_set followed by the higher level addition or subtraction algorithms. As a result these algorithms are subtantially simpler with a slight cost in performance. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_add\_d}. \\ \textbf{Input}. mp\_int $a$ and a mp\_digit $b$ \\ \textbf{Output}. $c = a + b$ \\ \hline \\ 1. $t \leftarrow b$ (\textit{mp\_set}) \\ 2. $c \leftarrow a + t$ \\ 3. Return(\textit{MP\_OKAY}) \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_add\_d} \end{figure} \textbf{Algorithm mp\_add\_d.} This algorithm initiates a temporary mp\_int with the value of the single digit and uses algorithm mp\_add to add the two values together. EXAM,bn_mp_add_d.c Clever use of the letter 't'. \subsubsection{Subtraction} The single digit subtraction algorithm mp\_sub\_d is essentially the same except it uses mp\_sub to subtract the digit from the mp\_int. \subsection{Single Digit Multiplication} Single digit multiplication arises enough in division and radix conversion that it ought to be implement as a special case of the baseline multiplication algorithm. Essentially this algorithm is a modified version of algorithm s\_mp\_mul\_digs where one of the multiplicands only has one digit. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_mul\_d}. \\ \textbf{Input}. mp\_int $a$ and a mp\_digit $b$ \\ \textbf{Output}. $c = ab$ \\ \hline \\ 1. $pa \leftarrow a.used$ \\ 2. Grow $c$ to at least $pa + 1$ digits. \\ 3. $oldused \leftarrow c.used$ \\ 4. $c.used \leftarrow pa + 1$ \\ 5. $c.sign \leftarrow a.sign$ \\ 6. $\mu \leftarrow 0$ \\ 7. for $ix$ from $0$ to $pa - 1$ do \\ \hspace{3mm}7.1 $\hat r \leftarrow \mu + a_{ix}b$ \\ \hspace{3mm}7.2 $c_{ix} \leftarrow \hat r \mbox{ (mod }\beta\mbox{)}$ \\ \hspace{3mm}7.3 $\mu \leftarrow \lfloor \hat r / \beta \rfloor$ \\ 8. $c_{pa} \leftarrow \mu$ \\ 9. for $ix$ from $pa + 1$ to $oldused$ do \\ \hspace{3mm}9.1 $c_{ix} \leftarrow 0$ \\ 10. Clamp excess digits of $c$. \\ 11. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_mul\_d} \end{figure} \textbf{Algorithm mp\_mul\_d.} This algorithm quickly multiplies an mp\_int by a small single digit value. It is specially tailored to the job and has a minimal of overhead. Unlike the full multiplication algorithms this algorithm does not require any significnat temporary storage or memory allocations. EXAM,bn_mp_mul_d.c In this implementation the destination $c$ may point to the same mp\_int as the source $a$ since the result is written after the digit is read from the source. This function uses pointer aliases $tmpa$ and $tmpc$ for the digits of $a$ and $c$ respectively. \subsection{Single Digit Division} Like the single digit multiplication algorithm, single digit division is also a fairly common algorithm used in radix conversion. Since the divisor is only a single digit a specialized variant of the division algorithm can be used to compute the quotient. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_div\_d}. \\ \textbf{Input}. mp\_int $a$ and a mp\_digit $b$ \\ \textbf{Output}. $c = \lfloor a / b \rfloor, d = a - cb$ \\ \hline \\ 1. If $b = 0$ then return(\textit{MP\_VAL}).\\ 2. If $b = 3$ then use algorithm mp\_div\_3 instead. \\ 3. Init $q$ to $a.used$ digits. \\ 4. $q.used \leftarrow a.used$ \\ 5. $q.sign \leftarrow a.sign$ \\ 6. $\hat w \leftarrow 0$ \\ 7. for $ix$ from $a.used - 1$ down to $0$ do \\ \hspace{3mm}7.1 $\hat w \leftarrow \hat w \beta + a_{ix}$ \\ \hspace{3mm}7.2 If $\hat w \ge b$ then \\ \hspace{6mm}7.2.1 $t \leftarrow \lfloor \hat w / b \rfloor$ \\ \hspace{6mm}7.2.2 $\hat w \leftarrow \hat w \mbox{ (mod }b\mbox{)}$ \\ \hspace{3mm}7.3 else\\ \hspace{6mm}7.3.1 $t \leftarrow 0$ \\ \hspace{3mm}7.4 $q_{ix} \leftarrow t$ \\ 8. $d \leftarrow \hat w$ \\ 9. Clamp excess digits of $q$. \\ 10. $c \leftarrow q$ \\ 11. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_div\_d} \end{figure} \textbf{Algorithm mp\_div\_d.} This algorithm divides the mp\_int $a$ by the single mp\_digit $b$ using an optimized approach. Essentially in every iteration of the algorithm another digit of the dividend is reduced and another digit of quotient produced. Provided $b < \beta$ the value of $\hat w$ after step 7.1 will be limited such that $0 \le \lfloor \hat w / b \rfloor < \beta$. If the divisor $b$ is equal to three a variant of this algorithm is used which is called mp\_div\_3. It replaces the division by three with a multiplication by $\lfloor \beta / 3 \rfloor$ and the appropriate shift and residual fixup. In essence it is much like the Barrett reduction from chapter seven. EXAM,bn_mp_div_d.c Like the implementation of algorithm mp\_div this algorithm allows either of the quotient or remainder to be passed as a \textbf{NULL} pointer to indicate the respective value is not required. This allows a trivial single digit modular reduction algorithm, mp\_mod\_d to be created. The division and remainder on lines @44,/@ and @45,%@ can be replaced often by a single division on most processors. For example, the 32-bit x86 based processors can divide a 64-bit quantity by a 32-bit quantity and produce the quotient and remainder simultaneously. Unfortunately the GCC compiler does not recognize that optimization and will actually produce two function calls to find the quotient and remainder respectively. \subsection{Single Digit Root Extraction} Finding the $n$'th root of an integer is fairly easy as far as numerical analysis is concerned. Algorithms such as the Newton-Raphson approximation (\ref{eqn:newton}) series will converge very quickly to a root for any continuous function $f(x)$. \begin{equation} x_{i+1} = x_i - {f(x_i) \over f'(x_i)} \label{eqn:newton} \end{equation} In this case the $n$'th root is desired and $f(x) = x^n - a$ where $a$ is the integer of which the root is desired. The derivative of $f(x)$ is simply $f'(x) = nx^{n - 1}$. Of particular importance is that this algorithm will be used over the integers not over the a more continuous domain such as the real numbers. As a result the root found can be above the true root by few and must be manually adjusted. Ideally at the end of the algorithm the $n$'th root $b$ of an integer $a$ is desired such that $b^n \le a$. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_n\_root}. \\ \textbf{Input}. mp\_int $a$ and a mp\_digit $b$ \\ \textbf{Output}. $c^b \le a$ \\ \hline \\ 1. If $b$ is even and $a.sign = MP\_NEG$ return(\textit{MP\_VAL}). \\ 2. $sign \leftarrow a.sign$ \\ 3. $a.sign \leftarrow MP\_ZPOS$ \\ 4. t$2 \leftarrow 2$ \\ 5. Loop \\ \hspace{3mm}5.1 t$1 \leftarrow $ t$2$ \\ \hspace{3mm}5.2 t$3 \leftarrow $ t$1^{b - 1}$ \\ \hspace{3mm}5.3 t$2 \leftarrow $ t$3 $ $\cdot$ t$1$ \\ \hspace{3mm}5.4 t$2 \leftarrow $ t$2 - a$ \\ \hspace{3mm}5.5 t$3 \leftarrow $ t$3 \cdot b$ \\ \hspace{3mm}5.6 t$3 \leftarrow \lfloor $t$2 / $t$3 \rfloor$ \\ \hspace{3mm}5.7 t$2 \leftarrow $ t$1 - $ t$3$ \\ \hspace{3mm}5.8 If t$1 \ne $ t$2$ then goto step 5. \\ 6. Loop \\ \hspace{3mm}6.1 t$2 \leftarrow $ t$1^b$ \\ \hspace{3mm}6.2 If t$2 > a$ then \\ \hspace{6mm}6.2.1 t$1 \leftarrow $ t$1 - 1$ \\ \hspace{6mm}6.2.2 Goto step 6. \\ 7. $a.sign \leftarrow sign$ \\ 8. $c \leftarrow $ t$1$ \\ 9. $c.sign \leftarrow sign$ \\ 10. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_n\_root} \end{figure} \textbf{Algorithm mp\_n\_root.} This algorithm finds the integer $n$'th root of an input using the Newton-Raphson approach. It is partially optimized based on the observation that the numerator of ${f(x) \over f'(x)}$ can be derived from a partial denominator. That is at first the denominator is calculated by finding $x^{b - 1}$. This value can then be multiplied by $x$ and have $a$ subtracted from it to find the numerator. This saves a total of $b - 1$ multiplications by t$1$ inside the loop. The initial value of the approximation is t$2 = 2$ which allows the algorithm to start with very small values and quickly converge on the root. Ideally this algorithm is meant to find the $n$'th root of an input where $n$ is bounded by $2 \le n \le 5$. EXAM,bn_mp_n_root.c \section{Random Number Generation} Random numbers come up in a variety of activities from public key cryptography to simple simulations and various randomized algorithms. Pollard-Rho factoring for example, can make use of random values as starting points to find factors of a composite integer. In this case the algorithm presented is solely for simulations and not intended for cryptographic use. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_rand}. \\ \textbf{Input}. An integer $b$ \\ \textbf{Output}. A pseudo-random number of $b$ digits \\ \hline \\ 1. $a \leftarrow 0$ \\ 2. If $b \le 0$ return(\textit{MP\_OKAY}) \\ 3. Pick a non-zero random digit $d$. \\ 4. $a \leftarrow a + d$ \\ 5. for $ix$ from 1 to $d - 1$ do \\ \hspace{3mm}5.1 $a \leftarrow a \cdot \beta$ \\ \hspace{3mm}5.2 Pick a random digit $d$. \\ \hspace{3mm}5.3 $a \leftarrow a + d$ \\ 6. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_rand} \end{figure} \textbf{Algorithm mp\_rand.} This algorithm produces a pseudo-random integer of $b$ digits. By ensuring that the first digit is non-zero the algorithm also guarantees that the final result has at least $b$ digits. It relies heavily on a third-part random number generator which should ideally generate uniformly all of the integers from $0$ to $\beta - 1$. EXAM,bn_mp_rand.c \section{Formatted Representations} The ability to emit a radix-$n$ textual representation of an integer is useful for interacting with human parties. For example, the ability to be given a string of characters such as ``114585'' and turn it into the radix-$\beta$ equivalent would make it easier to enter numbers into a program. \subsection{Reading Radix-n Input} For the purposes of this text we will assume that a simple lower ASCII map (\ref{fig:ASC}) is used for the values of from $0$ to $63$ to printable characters. For example, when the character ``N'' is read it represents the integer $23$. The first $16$ characters of the map are for the common representations up to hexadecimal. After that they match the ``base64'' encoding scheme which are suitable chosen such that they are printable. While outputting as base64 may not be too helpful for human operators it does allow communication via non binary mediums. \newpage\begin{figure}[here] \begin{center} \begin{tabular}{cc|cc|cc|cc} \hline \textbf{Value} & \textbf{Char} & \textbf{Value} & \textbf{Char} & \textbf{Value} & \textbf{Char} & \textbf{Value} & \textbf{Char} \\ \hline 0 & 0 & 1 & 1 & 2 & 2 & 3 & 3 \\ 4 & 4 & 5 & 5 & 6 & 6 & 7 & 7 \\ 8 & 8 & 9 & 9 & 10 & A & 11 & B \\ 12 & C & 13 & D & 14 & E & 15 & F \\ 16 & G & 17 & H & 18 & I & 19 & J \\ 20 & K & 21 & L & 22 & M & 23 & N \\ 24 & O & 25 & P & 26 & Q & 27 & R \\ 28 & S & 29 & T & 30 & U & 31 & V \\ 32 & W & 33 & X & 34 & Y & 35 & Z \\ 36 & a & 37 & b & 38 & c & 39 & d \\ 40 & e & 41 & f & 42 & g & 43 & h \\ 44 & i & 45 & j & 46 & k & 47 & l \\ 48 & m & 49 & n & 50 & o & 51 & p \\ 52 & q & 53 & r & 54 & s & 55 & t \\ 56 & u & 57 & v & 58 & w & 59 & x \\ 60 & y & 61 & z & 62 & $+$ & 63 & $/$ \\ \hline \end{tabular} \end{center} \caption{Lower ASCII Map} \label{fig:ASC} \end{figure} \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_read\_radix}. \\ \textbf{Input}. A string $str$ of length $sn$ and radix $r$. \\ \textbf{Output}. The radix-$\beta$ equivalent mp\_int. \\ \hline \\ 1. If $r < 2$ or $r > 64$ return(\textit{MP\_VAL}). \\ 2. $ix \leftarrow 0$ \\ 3. If $str_0 =$ ``-'' then do \\ \hspace{3mm}3.1 $ix \leftarrow ix + 1$ \\ \hspace{3mm}3.2 $sign \leftarrow MP\_NEG$ \\ 4. else \\ \hspace{3mm}4.1 $sign \leftarrow MP\_ZPOS$ \\ 5. $a \leftarrow 0$ \\ 6. for $iy$ from $ix$ to $sn - 1$ do \\ \hspace{3mm}6.1 Let $y$ denote the position in the map of $str_{iy}$. \\ \hspace{3mm}6.2 If $str_{iy}$ is not in the map or $y \ge r$ then goto step 7. \\ \hspace{3mm}6.3 $a \leftarrow a \cdot r$ \\ \hspace{3mm}6.4 $a \leftarrow a + y$ \\ 7. If $a \ne 0$ then $a.sign \leftarrow sign$ \\ 8. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_read\_radix} \end{figure} \textbf{Algorithm mp\_read\_radix.} This algorithm will read an ASCII string and produce the radix-$\beta$ mp\_int representation of the same integer. A minus symbol ``-'' may precede the string to indicate the value is negative, otherwise it is assumed to be positive. The algorithm will read up to $sn$ characters from the input and will stop when it reads a character it cannot map the algorithm stops reading characters from the string. This allows numbers to be embedded as part of larger input without any significant problem. EXAM,bn_mp_read_radix.c \subsection{Generating Radix-$n$ Output} Generating radix-$n$ output is fairly trivial with a division and remainder algorithm. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_toradix}. \\ \textbf{Input}. A mp\_int $a$ and an integer $r$\\ \textbf{Output}. The radix-$r$ representation of $a$ \\ \hline \\ 1. If $r < 2$ or $r > 64$ return(\textit{MP\_VAL}). \\ 2. If $a = 0$ then $str = $ ``$0$'' and return(\textit{MP\_OKAY}). \\ 3. $t \leftarrow a$ \\ 4. $str \leftarrow$ ``'' \\ 5. if $t.sign = MP\_NEG$ then \\ \hspace{3mm}5.1 $str \leftarrow str + $ ``-'' \\ \hspace{3mm}5.2 $t.sign = MP\_ZPOS$ \\ 6. While ($t \ne 0$) do \\ \hspace{3mm}6.1 $d \leftarrow t \mbox{ (mod }r\mbox{)}$ \\ \hspace{3mm}6.2 $t \leftarrow \lfloor t / r \rfloor$ \\ \hspace{3mm}6.3 Look up $d$ in the map and store the equivalent character in $y$. \\ \hspace{3mm}6.4 $str \leftarrow str + y$ \\ 7. If $str_0 = $``$-$'' then \\ \hspace{3mm}7.1 Reverse the digits $str_1, str_2, \ldots str_n$. \\ 8. Otherwise \\ \hspace{3mm}8.1 Reverse the digits $str_0, str_1, \ldots str_n$. \\ 9. Return(\textit{MP\_OKAY}).\\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_toradix} \end{figure} \textbf{Algorithm mp\_toradix.} This algorithm computes the radix-$r$ representation of an mp\_int $a$. The ``digits'' of the representation are extracted by reducing successive powers of $\lfloor a / r^k \rfloor$ the input modulo $r$ until $r^k > a$. Note that instead of actually dividing by $r^k$ in each iteration the quotient $\lfloor a / r \rfloor$ is saved for the next iteration. As a result a series of trivial $n \times 1$ divisions are required instead of a series of $n \times k$ divisions. One design flaw of this approach is that the digits are produced in the reverse order (see~\ref{fig:mpradix}). To remedy this flaw the digits must be swapped or simply ``reversed''. \begin{figure} \begin{center} \begin{tabular}{|c|c|c|} \hline \textbf{Value of $a$} & \textbf{Value of $d$} & \textbf{Value of $str$} \\ \hline $1234$ & -- & -- \\ \hline $123$ & $4$ & ``4'' \\ \hline $12$ & $3$ & ``43'' \\ \hline $1$ & $2$ & ``432'' \\ \hline $0$ & $1$ & ``4321'' \\ \hline \end{tabular} \end{center} \caption{Example of Algorithm mp\_toradix.} \label{fig:mpradix} \end{figure} EXAM,bn_mp_toradix.c \chapter{Number Theoretic Algorithms} This chapter discusses several fundamental number theoretic algorithms such as the greatest common divisor, least common multiple and Jacobi symbol computation. These algorithms arise as essential components in several key cryptographic algorithms such as the RSA public key algorithm and various Sieve based factoring algorithms. \section{Greatest Common Divisor} The greatest common divisor of two integers $a$ and $b$, often denoted as $(a, b)$ is the largest integer $k$ that is a proper divisor of both $a$ and $b$. That is, $k$ is the largest integer such that $0 \equiv a \mbox{ (mod }k\mbox{)}$ and $0 \equiv b \mbox{ (mod }k\mbox{)}$ occur simultaneously. The most common approach (cite) is to reduce one input modulo another. That is if $a$ and $b$ are divisible by some integer $k$ and if $qa + r = b$ then $r$ is also divisible by $k$. The reduction pattern follows $\left < a , b \right > \rightarrow \left < b, a \mbox{ mod } b \right >$. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{Greatest Common Divisor (I)}. \\ \textbf{Input}. Two positive integers $a$ and $b$ greater than zero. \\ \textbf{Output}. The greatest common divisor $(a, b)$. \\ \hline \\ 1. While ($b > 0$) do \\ \hspace{3mm}1.1 $r \leftarrow a \mbox{ (mod }b\mbox{)}$ \\ \hspace{3mm}1.2 $a \leftarrow b$ \\ \hspace{3mm}1.3 $b \leftarrow r$ \\ 2. Return($a$). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm Greatest Common Divisor (I)} \label{fig:gcd1} \end{figure} This algorithm will quickly converge on the greatest common divisor since the residue $r$ tends diminish rapidly. However, divisions are relatively expensive operations to perform and should ideally be avoided. There is another approach based on a similar relationship of greatest common divisors. The faster approach is based on the observation that if $k$ divides both $a$ and $b$ it will also divide $a - b$. In particular, we would like $a - b$ to decrease in magnitude which implies that $b \ge a$. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{Greatest Common Divisor (II)}. \\ \textbf{Input}. Two positive integers $a$ and $b$ greater than zero. \\ \textbf{Output}. The greatest common divisor $(a, b)$. \\ \hline \\ 1. While ($b > 0$) do \\ \hspace{3mm}1.1 Swap $a$ and $b$ such that $a$ is the smallest of the two. \\ \hspace{3mm}1.2 $b \leftarrow b - a$ \\ 2. Return($a$). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm Greatest Common Divisor (II)} \label{fig:gcd2} \end{figure} \textbf{Proof} \textit{Algorithm~\ref{fig:gcd2} will return the greatest common divisor of $a$ and $b$.} The algorithm in figure~\ref{fig:gcd2} will eventually terminate since $b \ge a$ the subtraction in step 1.2 will be a value less than $b$. In other words in every iteration that tuple $\left < a, b \right >$ decrease in magnitude until eventually $a = b$. Since both $a$ and $b$ are always divisible by the greatest common divisor (\textit{until the last iteration}) and in the last iteration of the algorithm $b = 0$, therefore, in the second to last iteration of the algorithm $b = a$ and clearly $(a, a) = a$ which concludes the proof. \textbf{QED}. As a matter of practicality algorithm \ref{fig:gcd1} decreases far too slowly to be useful. Specially if $b$ is much larger than $a$ such that $b - a$ is still very much larger than $a$. A simple addition to the algorithm is to divide $b - a$ by a power of some integer $p$ which does not divide the greatest common divisor but will divide $b - a$. In this case ${b - a} \over p$ is also an integer and still divisible by the greatest common divisor. However, instead of factoring $b - a$ to find a suitable value of $p$ the powers of $p$ can be removed from $a$ and $b$ that are in common first. Then inside the loop whenever $b - a$ is divisible by some power of $p$ it can be safely removed. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{Greatest Common Divisor (III)}. \\ \textbf{Input}. Two positive integers $a$ and $b$ greater than zero. \\ \textbf{Output}. The greatest common divisor $(a, b)$. \\ \hline \\ 1. $k \leftarrow 0$ \\ 2. While $a$ and $b$ are both divisible by $p$ do \\ \hspace{3mm}2.1 $a \leftarrow \lfloor a / p \rfloor$ \\ \hspace{3mm}2.2 $b \leftarrow \lfloor b / p \rfloor$ \\ \hspace{3mm}2.3 $k \leftarrow k + 1$ \\ 3. While $a$ is divisible by $p$ do \\ \hspace{3mm}3.1 $a \leftarrow \lfloor a / p \rfloor$ \\ 4. While $b$ is divisible by $p$ do \\ \hspace{3mm}4.1 $b \leftarrow \lfloor b / p \rfloor$ \\ 5. While ($b > 0$) do \\ \hspace{3mm}5.1 Swap $a$ and $b$ such that $a$ is the smallest of the two. \\ \hspace{3mm}5.2 $b \leftarrow b - a$ \\ \hspace{3mm}5.3 While $b$ is divisible by $p$ do \\ \hspace{6mm}5.3.1 $b \leftarrow \lfloor b / p \rfloor$ \\ 6. Return($a \cdot p^k$). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm Greatest Common Divisor (III)} \label{fig:gcd3} \end{figure} This algorithm is based on the first except it removes powers of $p$ first and inside the main loop to ensure the tuple $\left < a, b \right >$ decreases more rapidly. The first loop on step two removes powers of $p$ that are in common. A count, $k$, is kept which will present a common divisor of $p^k$. After step two the remaining common divisor of $a$ and $b$ cannot be divisible by $p$. This means that $p$ can be safely divided out of the difference $b - a$ so long as the division leaves no remainder. In particular the value of $p$ should be chosen such that the division on step 5.3.1 occur often. It also helps that division by $p$ be easy to compute. The ideal choice of $p$ is two since division by two amounts to a right logical shift. Another important observation is that by step five both $a$ and $b$ are odd. Therefore, the diffrence $b - a$ must be even which means that each iteration removes one bit from the largest of the pair. \subsection{Complete Greatest Common Divisor} The algorithms presented so far cannot handle inputs which are zero or negative. The following algorithm can handle all input cases properly and will produce the greatest common divisor. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_gcd}. \\ \textbf{Input}. mp\_int $a$ and $b$ \\ \textbf{Output}. The greatest common divisor $c = (a, b)$. \\ \hline \\ 1. If $a = 0$ and $b \ne 0$ then \\ \hspace{3mm}1.1 $c \leftarrow b$ \\ \hspace{3mm}1.2 Return(\textit{MP\_OKAY}). \\ 2. If $a \ne 0$ and $b = 0$ then \\ \hspace{3mm}2.1 $c \leftarrow a$ \\ \hspace{3mm}2.2 Return(\textit{MP\_OKAY}). \\ 3. If $a = b = 0$ then \\ \hspace{3mm}3.1 $c \leftarrow 1$ \\ \hspace{3mm}3.2 Return(\textit{MP\_OKAY}). \\ 4. $u \leftarrow \vert a \vert, v \leftarrow \vert b \vert$ \\ 5. $k \leftarrow 0$ \\ 6. While $u.used > 0$ and $v.used > 0$ and $u_0 \equiv v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ \hspace{3mm}6.1 $k \leftarrow k + 1$ \\ \hspace{3mm}6.2 $u \leftarrow \lfloor u / 2 \rfloor$ \\ \hspace{3mm}6.3 $v \leftarrow \lfloor v / 2 \rfloor$ \\ 7. While $u.used > 0$ and $u_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ \hspace{3mm}7.1 $u \leftarrow \lfloor u / 2 \rfloor$ \\ 8. While $v.used > 0$ and $v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ \hspace{3mm}8.1 $v \leftarrow \lfloor v / 2 \rfloor$ \\ 9. While $v.used > 0$ \\ \hspace{3mm}9.1 If $\vert u \vert > \vert v \vert$ then \\ \hspace{6mm}9.1.1 Swap $u$ and $v$. \\ \hspace{3mm}9.2 $v \leftarrow \vert v \vert - \vert u \vert$ \\ \hspace{3mm}9.3 While $v.used > 0$ and $v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ \hspace{6mm}9.3.1 $v \leftarrow \lfloor v / 2 \rfloor$ \\ 10. $c \leftarrow u \cdot 2^k$ \\ 11. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_gcd} \end{figure} \textbf{Algorithm mp\_gcd.} This algorithm will produce the greatest common divisor of two mp\_ints $a$ and $b$. The algorithm was originally based on Algorithm B of Knuth \cite[pp. 338]{TAOCPV2} but has been modified to be simpler to explain. In theory it achieves the same asymptotic working time as Algorithm B and in practice this appears to be true. The first three steps handle the cases where either one of or both inputs are zero. If either input is zero the greatest common divisor is the largest input or zero if they are both zero. If the inputs are not trivial than $u$ and $v$ are assigned the absolute values of $a$ and $b$ respectively and the algorithm will proceed to reduce the pair. Step six will divide out any common factors of two and keep track of the count in the variable $k$. After this step two is no longer a factor of the remaining greatest common divisor between $u$ and $v$ and can be safely evenly divided out of either whenever they are even. Step seven and eight ensure that the $u$ and $v$ respectively have no more factors of two. At most only one of the while loops will iterate since they cannot both be even. By step nine both of $u$ and $v$ are odd which is required for the inner logic. First the pair are swapped such that $v$ is equal to or greater than $u$. This ensures that the subtraction on step 9.2 will always produce a positive and even result. Step 9.3 removes any factors of two from the difference $u$ to ensure that in the next iteration of the loop both are once again odd. After $v = 0$ occurs the variable $u$ has the greatest common divisor of the pair $\left < u, v \right >$ just after step six. The result must be adjusted by multiplying by the common factors of two ($2^k$) removed earlier. EXAM,bn_mp_gcd.c This function makes use of the macros mp\_iszero and mp\_iseven. The former evaluates to $1$ if the input mp\_int is equivalent to the integer zero otherwise it evaluates to $0$. The latter evaluates to $1$ if the input mp\_int represents a non-zero even integer otherwise it evaluates to $0$. Note that just because mp\_iseven may evaluate to $0$ does not mean the input is odd, it could also be zero. The three trivial cases of inputs are handled on lines @25,zero@ through @34,}@. After those lines the inputs are assumed to be non-zero. Lines @36,if@ and @40,if@ make local copies $u$ and $v$ of the inputs $a$ and $b$ respectively. At this point the common factors of two must be divided out of the two inputs. The while loop on line @49,while@ iterates so long as both are even. The local integer $k$ is used to keep track of how many factors of $2$ are pulled out of both values. It is assumed that the number of factors will not exceed the maximum value of a C ``int'' data type\footnote{Strictly speaking no array in C may have more than entries than are accessible by an ``int'' so this is not a limitation.}. At this point there are no more common factors of two in the two values. The while loops on lines @60,while@ and @65,while@ remove any independent factors of two such that both $u$ and $v$ are guaranteed to be an odd integer before hitting the main body of the algorithm. The while loop on line @71, while@ performs the reduction of the pair until $v$ is equal to zero. The unsigned comparison and subtraction algorithms are used in place of the full signed routines since both values are guaranteed to be positive and the result of the subtraction is guaranteed to be non-negative. \section{Least Common Multiple} The least common multiple of a pair of integers is their product divided by their greatest common divisor. For two integers $a$ and $b$ the least common multiple is normally denoted as $[ a, b ]$ and numerically equivalent to ${ab} \over {(a, b)}$. For example, if $a = 2 \cdot 2 \cdot 3 = 12$ and $b = 2 \cdot 3 \cdot 3 \cdot 7 = 126$ the least common multiple is ${126 \over {(12, 126)}} = {126 \over 6} = 21$. The least common multiple arises often in coding theory as well as number theory. If two functions have periods of $a$ and $b$ respectively they will collide, that is be in synchronous states, after only $[ a, b ]$ iterations. This is why, for example, random number generators based on Linear Feedback Shift Registers (LFSR) tend to use registers with periods which are co-prime (\textit{e.g. the greatest common divisor is one.}). Similarly in number theory if a composite $n$ has two prime factors $p$ and $q$ then maximal order of any unit of $\Z/n\Z$ will be $[ p - 1, q - 1] $. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_lcm}. \\ \textbf{Input}. mp\_int $a$ and $b$ \\ \textbf{Output}. The least common multiple $c = [a, b]$. \\ \hline \\ 1. $c \leftarrow (a, b)$ \\ 2. $t \leftarrow a \cdot b$ \\ 3. $c \leftarrow \lfloor t / c \rfloor$ \\ 4. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_lcm} \end{figure} \textbf{Algorithm mp\_lcm.} This algorithm computes the least common multiple of two mp\_int inputs $a$ and $b$. It computes the least common multiple directly by dividing the product of the two inputs by their greatest common divisor. EXAM,bn_mp_lcm.c \section{Jacobi Symbol Computation} To explain the Jacobi Symbol we shall first discuss the Legendre function\footnote{Arrg. What is the name of this?} off which the Jacobi symbol is defined. The Legendre function computes whether or not an integer $a$ is a quadratic residue modulo an odd prime $p$. Numerically it is equivalent to equation \ref{eqn:legendre}. \textit{-- Tom, don't be an ass, cite your source here...!} \begin{equation} a^{(p-1)/2} \equiv \begin{array}{rl} -1 & \mbox{if }a\mbox{ is a quadratic non-residue.} \\ 0 & \mbox{if }a\mbox{ divides }p\mbox{.} \\ 1 & \mbox{if }a\mbox{ is a quadratic residue}. \end{array} \mbox{ (mod }p\mbox{)} \label{eqn:legendre} \end{equation} \textbf{Proof.} \textit{Equation \ref{eqn:legendre} correctly identifies the residue status of an integer $a$ modulo a prime $p$.} An integer $a$ is a quadratic residue if the following equation has a solution. \begin{equation} x^2 \equiv a \mbox{ (mod }p\mbox{)} \label{eqn:root} \end{equation} Consider the following equation. \begin{equation} 0 \equiv x^{p-1} - 1 \equiv \left \lbrace \left (x^2 \right )^{(p-1)/2} - a^{(p-1)/2} \right \rbrace + \left ( a^{(p-1)/2} - 1 \right ) \mbox{ (mod }p\mbox{)} \label{eqn:rooti} \end{equation} Whether equation \ref{eqn:root} has a solution or not equation \ref{eqn:rooti} is always true. If $a^{(p-1)/2} - 1 \equiv 0 \mbox{ (mod }p\mbox{)}$ then the quantity in the braces must be zero. By reduction, \begin{eqnarray} \left (x^2 \right )^{(p-1)/2} - a^{(p-1)/2} \equiv 0 \nonumber \\ \left (x^2 \right )^{(p-1)/2} \equiv a^{(p-1)/2} \nonumber \\ x^2 \equiv a \mbox{ (mod }p\mbox{)} \end{eqnarray} As a result there must be a solution to the quadratic equation and in turn $a$ must be a quadratic residue. If $a$ does not divide $p$ and $a$ is not a quadratic residue then the only other value $a^{(p-1)/2}$ may be congruent to is $-1$ since \begin{equation} 0 \equiv a^{p - 1} - 1 \equiv (a^{(p-1)/2} + 1)(a^{(p-1)/2} - 1) \mbox{ (mod }p\mbox{)} \end{equation} One of the terms on the right hand side must be zero. \textbf{QED} \subsection{Jacobi Symbol} The Jacobi symbol is a generalization of the Legendre function for any odd non prime moduli $p$ greater than 2. If $p = \prod_{i=0}^n p_i$ then the Jacobi symbol $\left ( { a \over p } \right )$ is equal to the following equation. \begin{equation} \left ( { a \over p } \right ) = \left ( { a \over p_0} \right ) \left ( { a \over p_1} \right ) \ldots \left ( { a \over p_n} \right ) \end{equation} By inspection if $p$ is prime the Jacobi symbol is equivalent to the Legendre function. The following facts\footnote{See HAC \cite[pp. 72-74]{HAC} for further details.} will be used to derive an efficient Jacobi symbol algorithm. Where $p$ is an odd integer greater than two and $a, b \in \Z$ the following are true. \begin{enumerate} \item $\left ( { a \over p} \right )$ equals $-1$, $0$ or $1$. \item $\left ( { ab \over p} \right ) = \left ( { a \over p} \right )\left ( { b \over p} \right )$. \item If $a \equiv b$ then $\left ( { a \over p} \right ) = \left ( { b \over p} \right )$. \item $\left ( { 2 \over p} \right )$ equals $1$ if $p \equiv 1$ or $7 \mbox{ (mod }8\mbox{)}$. Otherwise, it equals $-1$. \item $\left ( { a \over p} \right ) \equiv \left ( { p \over a} \right ) \cdot (-1)^{(p-1)(a-1)/4}$. More specifically $\left ( { a \over p} \right ) = \left ( { p \over a} \right )$ if $p \equiv a \equiv 1 \mbox{ (mod }4\mbox{)}$. \end{enumerate} Using these facts if $a = 2^k \cdot a'$ then \begin{eqnarray} \left ( { a \over p } \right ) = \left ( {{2^k} \over p } \right ) \left ( {a' \over p} \right ) \nonumber \\ = \left ( {2 \over p } \right )^k \left ( {a' \over p} \right ) \label{eqn:jacobi} \end{eqnarray} By fact five, \begin{equation} \left ( { a \over p } \right ) = \left ( { p \over a } \right ) \cdot (-1)^{(p-1)(a-1)/4} \end{equation} Subsequently by fact three since $p \equiv (p \mbox{ mod }a) \mbox{ (mod }a\mbox{)}$ then \begin{equation} \left ( { a \over p } \right ) = \left ( { {p \mbox{ mod } a} \over a } \right ) \cdot (-1)^{(p-1)(a-1)/4} \end{equation} By putting both observations into equation \ref{eqn:jacobi} the following simplified equation is formed. \begin{equation} \left ( { a \over p } \right ) = \left ( {2 \over p } \right )^k \left ( {{p\mbox{ mod }a'} \over a'} \right ) \cdot (-1)^{(p-1)(a'-1)/4} \end{equation} The value of $\left ( {{p \mbox{ mod }a'} \over a'} \right )$ can be found by using the same equation recursively. The value of $\left ( {2 \over p } \right )^k$ equals $1$ if $k$ is even otherwise it equals $\left ( {2 \over p } \right )$. Using this approach the factors of $p$ do not have to be known. Furthermore, if $(a, p) = 1$ then the algorithm will terminate when the recursion requests the Jacobi symbol computation of $\left ( {1 \over a'} \right )$ which is simply $1$. \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_jacobi}. \\ \textbf{Input}. mp\_int $a$ and $p$, $a \ge 0$, $p \ge 3$, $p \equiv 1 \mbox{ (mod }2\mbox{)}$ \\ \textbf{Output}. The Jacobi symbol $c = \left ( {a \over p } \right )$. \\ \hline \\ 1. If $a = 0$ then \\ \hspace{3mm}1.1 $c \leftarrow 0$ \\ \hspace{3mm}1.2 Return(\textit{MP\_OKAY}). \\ 2. If $a = 1$ then \\ \hspace{3mm}2.1 $c \leftarrow 1$ \\ \hspace{3mm}2.2 Return(\textit{MP\_OKAY}). \\ 3. $a' \leftarrow a$ \\ 4. $k \leftarrow 0$ \\ 5. While $a'.used > 0$ and $a'_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ \hspace{3mm}5.1 $k \leftarrow k + 1$ \\ \hspace{3mm}5.2 $a' \leftarrow \lfloor a' / 2 \rfloor$ \\ 6. If $k \equiv 0 \mbox{ (mod }2\mbox{)}$ then \\ \hspace{3mm}6.1 $s \leftarrow 1$ \\ 7. else \\ \hspace{3mm}7.1 $r \leftarrow p_0 \mbox{ (mod }8\mbox{)}$ \\ \hspace{3mm}7.2 If $r = 1$ or $r = 7$ then \\ \hspace{6mm}7.2.1 $s \leftarrow 1$ \\ \hspace{3mm}7.3 else \\ \hspace{6mm}7.3.1 $s \leftarrow -1$ \\ 8. If $p_0 \equiv a'_0 \equiv 3 \mbox{ (mod }4\mbox{)}$ then \\ \hspace{3mm}8.1 $s \leftarrow -s$ \\ 9. If $a' \ne 1$ then \\ \hspace{3mm}9.1 $p' \leftarrow p \mbox{ (mod }a'\mbox{)}$ \\ \hspace{3mm}9.2 $s \leftarrow s \cdot \mbox{mp\_jacobi}(p', a')$ \\ 10. $c \leftarrow s$ \\ 11. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_jacobi} \end{figure} \textbf{Algorithm mp\_jacobi.} This algorithm computes the Jacobi symbol for an arbitrary positive integer $a$ with respect to an odd integer $p$ greater than three. The algorithm is based on algorithm 2.149 of HAC \cite[pp. 73]{HAC}. Step numbers one and two handle the trivial cases of $a = 0$ and $a = 1$ respectively. Step five determines the number of two factors in the input $a$. If $k$ is even than the term $\left ( { 2 \over p } \right )^k$ must always evaluate to one. If $k$ is odd than the term evaluates to one if $p_0$ is congruent to one or seven modulo eight, otherwise it evaluates to $-1$. After the the $\left ( { 2 \over p } \right )^k$ term is handled the $(-1)^{(p-1)(a'-1)/4}$ is computed and multiplied against the current product $s$. The latter term evaluates to one if both $p$ and $a'$ are congruent to one modulo four, otherwise it evaluates to negative one. By step nine if $a'$ does not equal one a recursion is required. Step 9.1 computes $p' \equiv p \mbox{ (mod }a'\mbox{)}$ and will recurse to compute $\left ( {p' \over a'} \right )$ which is multiplied against the current Jacobi product. EXAM,bn_mp_jacobi.c As a matter of practicality the variable $a'$ as per the pseudo-code is reprensented by the variable $a1$ since the $'$ symbol is not valid for a C variable name character. The two simple cases of $a = 0$ and $a = 1$ are handled at the very beginning to simplify the algorithm. If the input is non-trivial the algorithm has to proceed compute the Jacobi. The variable $s$ is used to hold the current Jacobi product. Note that $s$ is merely a C ``int'' data type since the values it may obtain are merely $-1$, $0$ and $1$. After a local copy of $a$ is made all of the factors of two are divided out and the total stored in $k$. Technically only the least significant bit of $k$ is required, however, it makes the algorithm simpler to follow to perform an addition. In practice an exclusive-or and addition have the same processor requirements and neither is faster than the other. Line @59, if@ through @70, }@ determines the value of $\left ( { 2 \over p } \right )^k$. If the least significant bit of $k$ is zero than $k$ is even and the value is one. Otherwise, the value of $s$ depends on which residue class $p$ belongs to modulo eight. The value of $(-1)^{(p-1)(a'-1)/4}$ is compute and multiplied against $s$ on lines @73, if@ through @75, }@. Finally, if $a1$ does not equal one the algorithm must recurse and compute $\left ( {p' \over a'} \right )$. \textit{-- Comment about default $s$ and such...} \section{Modular Inverse} \label{sec:modinv} The modular inverse of a number actually refers to the modular multiplicative inverse. Essentially for any integer $a$ such that $(a, p) = 1$ there exist another integer $b$ such that $ab \equiv 1 \mbox{ (mod }p\mbox{)}$. The integer $b$ is called the multiplicative inverse of $a$ which is denoted as $b = a^{-1}$. Technically speaking modular inversion is a well defined operation for any finite ring or field not just for rings and fields of integers. However, the former will be the matter of discussion. The simplest approach is to compute the algebraic inverse of the input. That is to compute $b \equiv a^{\Phi(p) - 1}$. If $\Phi(p)$ is the order of the multiplicative subgroup modulo $p$ then $b$ must be the multiplicative inverse of $a$. The proof of which is trivial. \begin{equation} ab \equiv a \left (a^{\Phi(p) - 1} \right ) \equiv a^{\Phi(p)} \equiv a^0 \equiv 1 \mbox{ (mod }p\mbox{)} \end{equation} However, as simple as this approach may be it has two serious flaws. It requires that the value of $\Phi(p)$ be known which if $p$ is composite requires all of the prime factors. This approach also is very slow as the size of $p$ grows. A simpler approach is based on the observation that solving for the multiplicative inverse is equivalent to solving the linear Diophantine\footnote{See LeVeque \cite[pp. 40-43]{LeVeque} for more information.} equation. \begin{equation} ab + pq = 1 \end{equation} Where $a$, $b$, $p$ and $q$ are all integers. If such a pair of integers $ \left < b, q \right >$ exist than $b$ is the multiplicative inverse of $a$ modulo $p$. The extended Euclidean algorithm (Knuth \cite[pp. 342]{TAOCPV2}) can be used to solve such equations provided $(a, p) = 1$. However, instead of using that algorithm directly a variant known as the binary Extended Euclidean algorithm will be used in its place. The binary approach is very similar to the binary greatest common divisor algorithm except it will produce a full solution to the Diophantine equation. \subsection{General Case} \newpage\begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_invmod}. \\ \textbf{Input}. mp\_int $a$ and $b$, $(a, b) = 1$, $p \ge 2$, $0 < a < p$. \\ \textbf{Output}. The modular inverse $c \equiv a^{-1} \mbox{ (mod }b\mbox{)}$. \\ \hline \\ 1. If $b \le 0$ then return(\textit{MP\_VAL}). \\ 2. If $b_0 \equiv 1 \mbox{ (mod }2\mbox{)}$ then use algorithm fast\_mp\_invmod. \\ 3. $x \leftarrow \vert a \vert, y \leftarrow b$ \\ 4. If $x_0 \equiv y_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ then return(\textit{MP\_VAL}). \\ 5. $B \leftarrow 0, C \leftarrow 0, A \leftarrow 1, D \leftarrow 1$ \\ 6. While $u.used > 0$ and $u_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ \hspace{3mm}6.1 $u \leftarrow \lfloor u / 2 \rfloor$ \\ \hspace{3mm}6.2 If ($A.used > 0$ and $A_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) or ($B.used > 0$ and $B_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) then \\ \hspace{6mm}6.2.1 $A \leftarrow A + y$ \\ \hspace{6mm}6.2.2 $B \leftarrow B - x$ \\ \hspace{3mm}6.3 $A \leftarrow \lfloor A / 2 \rfloor$ \\ \hspace{3mm}6.4 $B \leftarrow \lfloor B / 2 \rfloor$ \\ 7. While $v.used > 0$ and $v_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ \hspace{3mm}7.1 $v \leftarrow \lfloor v / 2 \rfloor$ \\ \hspace{3mm}7.2 If ($C.used > 0$ and $C_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) or ($D.used > 0$ and $D_0 \equiv 1 \mbox{ (mod }2\mbox{)}$) then \\ \hspace{6mm}7.2.1 $C \leftarrow C + y$ \\ \hspace{6mm}7.2.2 $D \leftarrow D - x$ \\ \hspace{3mm}7.3 $C \leftarrow \lfloor C / 2 \rfloor$ \\ \hspace{3mm}7.4 $D \leftarrow \lfloor D / 2 \rfloor$ \\ 8. If $u \ge v$ then \\ \hspace{3mm}8.1 $u \leftarrow u - v$ \\ \hspace{3mm}8.2 $A \leftarrow A - C$ \\ \hspace{3mm}8.3 $B \leftarrow B - D$ \\ 9. else \\ \hspace{3mm}9.1 $v \leftarrow v - u$ \\ \hspace{3mm}9.2 $C \leftarrow C - A$ \\ \hspace{3mm}9.3 $D \leftarrow D - B$ \\ 10. If $u \ne 0$ goto step 6. \\ 11. If $v \ne 1$ return(\textit{MP\_VAL}). \\ 12. While $C \le 0$ do \\ \hspace{3mm}12.1 $C \leftarrow C + b$ \\ 13. While $C \ge b$ do \\ \hspace{3mm}13.1 $C \leftarrow C - b$ \\ 14. $c \leftarrow C$ \\ 15. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \end{figure} \textbf{Algorithm mp\_invmod.} This algorithm computes the modular multiplicative inverse of an integer $a$ modulo an integer $b$. This algorithm is a variation of the extended binary Euclidean algorithm from HAC \cite[pp. 608]{HAC}. It has been modified to only compute the modular inverse and not a complete Diophantine solution. If $b \le 0$ than the modulus is invalid and MP\_VAL is returned. Similarly if both $a$ and $b$ are even then there cannot be a multiplicative inverse for $a$ and the error is reported. The astute reader will observe that steps seven through nine are very similar to the binary greatest common divisor algorithm mp\_gcd. In this case the other variables to the Diophantine equation are solved. The algorithm terminates when $u = 0$ in which case the solution is \begin{equation} Ca + Db = v \end{equation} If $v$, the greatest common divisor of $a$ and $b$ is not equal to one then the algorithm will report an error as no inverse exists. Otherwise, $C$ is the modular inverse of $a$. The actual value of $C$ is congruent to, but not necessarily equal to, the ideal modular inverse which should lie within $1 \le a^{-1} < b$. Step numbers twelve and thirteen adjust the inverse until it is in range. If the original input $a$ is within $0 < a < p$ then only a couple of additions or subtractions will be required to adjust the inverse. EXAM,bn_mp_invmod.c \subsubsection{Odd Moduli} When the modulus $b$ is odd the variables $A$ and $C$ are fixed and are not required to compute the inverse. In particular by attempting to solve the Diophantine $Cb + Da = 1$ only $B$ and $D$ are required to find the inverse of $a$. The algorithm fast\_mp\_invmod is a direct adaptation of algorithm mp\_invmod with all all steps involving either $A$ or $C$ removed. This optimization will halve the time required to compute the modular inverse. \section{Primality Tests} A non-zero integer $a$ is said to be prime if it is not divisible by any other integer excluding one and itself. For example, $a = 7$ is prime since the integers $2 \ldots 6$ do not evenly divide $a$. By contrast, $a = 6$ is not prime since $a = 6 = 2 \cdot 3$. Prime numbers arise in cryptography considerably as they allow finite fields to be formed. The ability to determine whether an integer is prime or not quickly has been a viable subject in cryptography and number theory for considerable time. The algorithms that will be presented are all probablistic algorithms in that when they report an integer is composite it must be composite. However, when the algorithms report an integer is prime the algorithm may be incorrect. As will be discussed it is possible to limit the probability of error so well that for practical purposes the probablity of error might as well be zero. For the purposes of these discussions let $n$ represent the candidate integer of which the primality is in question. \subsection{Trial Division} Trial division means to attempt to evenly divide a candidate integer by small prime integers. If the candidate can be evenly divided it obviously cannot be prime. By dividing by all primes $1 < p \le \sqrt{n}$ this test can actually prove whether an integer is prime. However, such a test would require a prohibitive amount of time as $n$ grows. Instead of dividing by every prime, a smaller, more mangeable set of primes may be used instead. By performing trial division with only a subset of the primes less than $\sqrt{n} + 1$ the algorithm cannot prove if a candidate is prime. However, often it can prove a candidate is not prime. The benefit of this test is that trial division by small values is fairly efficient. Specially compared to the other algorithms that will be discussed shortly. The probability that this approach correctly identifies a composite candidate when tested with all primes upto $q$ is given by $1 - {1.12 \over ln(q)}$. The graph (\ref{pic:primality}, will be added later) demonstrates the probability of success for the range $3 \le q \le 100$. At approximately $q = 30$ the gain of performing further tests diminishes fairly quickly. At $q = 90$ further testing is generally not going to be of any practical use. In the case of LibTomMath the default limit $q = 256$ was chosen since it is not too high and will eliminate approximately $80\%$ of all candidate integers. The constant \textbf{PRIME\_SIZE} is equal to the number of primes in the test base. The array \_\_prime\_tab is an array of the first \textbf{PRIME\_SIZE} prime numbers. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_prime\_is\_divisible}. \\ \textbf{Input}. mp\_int $a$ \\ \textbf{Output}. $c = 1$ if $n$ is divisible by a small prime, otherwise $c = 0$. \\ \hline \\ 1. for $ix$ from $0$ to $PRIME\_SIZE$ do \\ \hspace{3mm}1.1 $d \leftarrow n \mbox{ (mod }\_\_prime\_tab_{ix}\mbox{)}$ \\ \hspace{3mm}1.2 If $d = 0$ then \\ \hspace{6mm}1.2.1 $c \leftarrow 1$ \\ \hspace{6mm}1.2.2 Return(\textit{MP\_OKAY}). \\ 2. $c \leftarrow 0$ \\ 3. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_prime\_is\_divisible} \end{figure} \textbf{Algorithm mp\_prime\_is\_divisible.} This algorithm attempts to determine if a candidate integer $n$ is composite by performing trial divisions. EXAM,bn_mp_prime_is_divisible.c The algorithm defaults to a return of $0$ in case an error occurs. The values in the prime table are all specified to be in the range of a mp\_digit. The table \_\_prime\_tab is defined in the following file. EXAM,bn_prime_tab.c Note that there are two possible tables. When an mp\_digit is 7-bits long only the primes upto $127$ may be included, otherwise the primes upto $1619$ are used. Note that the value of \textbf{PRIME\_SIZE} is a constant dependent on the size of a mp\_digit. \subsection{The Fermat Test} The Fermat test is probably one the oldest tests to have a non-trivial probability of success. It is based on the fact that if $n$ is in fact prime then $a^{n} \equiv a \mbox{ (mod }n\mbox{)}$ for all $0 < a < n$. The reason being that if $n$ is prime than the order of the multiplicative sub group is $n - 1$. Any base $a$ must have an order which divides $n - 1$ and as such $a^n$ is equivalent to $a^1 = a$. If $n$ is composite then any given base $a$ does not have to have a period which divides $n - 1$. In which case it is possible that $a^n \nequiv a \mbox{ (mod }n\mbox{)}$. However, this test is not absolute as it is possible that the order of a base will divide $n - 1$ which would then be reported as prime. Such a base yields what is known as a Fermat pseudo-prime. Several integers known as Carmichael numbers will be a pseudo-prime to all valid bases. Fortunately such numbers are extremely rare as $n$ grows in size. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_prime\_fermat}. \\ \textbf{Input}. mp\_int $a$ and $b$, $a \ge 2$, $0 < b < a$. \\ \textbf{Output}. $c = 1$ if $b^a \equiv b \mbox{ (mod }a\mbox{)}$, otherwise $c = 0$. \\ \hline \\ 1. $t \leftarrow b^a \mbox{ (mod }a\mbox{)}$ \\ 2. If $t = b$ then \\ \hspace{3mm}2.1 $c = 1$ \\ 3. else \\ \hspace{3mm}3.1 $c = 0$ \\ 4. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_prime\_fermat} \end{figure} \textbf{Algorithm mp\_prime\_fermat.} This algorithm determines whether an mp\_int $a$ is a Fermat prime to the base $b$ or not. It uses a single modular exponentiation to determine the result. EXAM,bn_mp_prime_fermat.c \subsection{The Miller-Rabin Test} The Miller-Rabin (citation) test is another primality test which has tighter error bounds than the Fermat test specifically with sequentially chosen candidate integers. The algorithm is based on the observation that if $n - 1 = 2^kr$ and if $b^r \nequiv \pm 1$ then after upto $k - 1$ squarings the value must be equal to $-1$. The squarings are stopped as soon as $-1$ is observed. If the value of $1$ is observed first it means that some value not congruent to $\pm 1$ when squared equals one which cannot occur if $n$ is prime. \begin{figure}[!here] \begin{small} \begin{center} \begin{tabular}{l} \hline Algorithm \textbf{mp\_prime\_miller\_rabin}. \\ \textbf{Input}. mp\_int $a$ and $b$, $a \ge 2$, $0 < b < a$. \\ \textbf{Output}. $c = 1$ if $a$ is a Miller-Rabin prime to the base $a$, otherwise $c = 0$. \\ \hline 1. $a' \leftarrow a - 1$ \\ 2. $r \leftarrow n1$ \\ 3. $c \leftarrow 0, s \leftarrow 0$ \\ 4. While $r.used > 0$ and $r_0 \equiv 0 \mbox{ (mod }2\mbox{)}$ \\ \hspace{3mm}4.1 $s \leftarrow s + 1$ \\ \hspace{3mm}4.2 $r \leftarrow \lfloor r / 2 \rfloor$ \\ 5. $y \leftarrow b^r \mbox{ (mod }a\mbox{)}$ \\ 6. If $y \nequiv \pm 1$ then \\ \hspace{3mm}6.1 $j \leftarrow 1$ \\ \hspace{3mm}6.2 While $j \le (s - 1)$ and $y \nequiv a'$ \\ \hspace{6mm}6.2.1 $y \leftarrow y^2 \mbox{ (mod }a\mbox{)}$ \\ \hspace{6mm}6.2.2 If $y = 1$ then goto step 8. \\ \hspace{6mm}6.2.3 $j \leftarrow j + 1$ \\ \hspace{3mm}6.3 If $y \nequiv a'$ goto step 8. \\ 7. $c \leftarrow 1$\\ 8. Return(\textit{MP\_OKAY}). \\ \hline \end{tabular} \end{center} \end{small} \caption{Algorithm mp\_prime\_miller\_rabin} \end{figure} \textbf{Algorithm mp\_prime\_miller\_rabin.} This algorithm performs one trial round of the Miller-Rabin algorithm to the base $b$. It will set $c = 1$ if the algorithm cannot determine if $b$ is composite or $c = 0$ if $b$ is provably composite. The values of $s$ and $r$ are computed such that $a' = a - 1 = 2^sr$. If the value $y \equiv b^r$ is congruent to $\pm 1$ then the algorithm cannot prove if $a$ is composite or not. Otherwise, the algorithm will square $y$ upto $s - 1$ times stopping only when $y \equiv -1$. If $y^2 \equiv 1$ and $y \nequiv \pm 1$ then the algorithm can report that $a$ is provably composite. If the algorithm performs $s - 1$ squarings and $y \nequiv -1$ then $a$ is provably composite. If $a$ is not provably composite then it is \textit{probably} prime. EXAM,bn_mp_prime_miller_rabin.c \backmatter \appendix \begin{thebibliography}{ABCDEF} \bibitem[1]{TAOCPV2} Donald Knuth, \textit{The Art of Computer Programming}, Third Edition, Volume Two, Seminumerical Algorithms, Addison-Wesley, 1998 \bibitem[2]{HAC} A. Menezes, P. van Oorschot, S. Vanstone, \textit{Handbook of Applied Cryptography}, CRC Press, 1996 \bibitem[3]{ROSE} Michael Rosing, \textit{Implementing Elliptic Curve Cryptography}, Manning Publications, 1999 \bibitem[4]{COMBA} Paul G. Comba, \textit{Exponentiation Cryptosystems on the IBM PC}. IBM Systems Journal 29(4): 526-538 (1990) \bibitem[5]{KARA} A. Karatsuba, Doklay Akad. Nauk SSSR 145 (1962), pp.293-294 \bibitem[6]{KARAP} Andre Weimerskirch and Christof Paar, \textit{Generalizations of the Karatsuba Algorithm for Polynomial Multiplication}, Submitted to Design, Codes and Cryptography, March 2002 \bibitem[7]{BARRETT} Paul Barrett, \textit{Implementing the Rivest Shamir and Adleman Public Key Encryption Algorithm on a Standard Digital Signal Processor}, Advances in Cryptology, Crypto '86, Springer-Verlag. \bibitem[8]{MONT} P.L.Montgomery. \textit{Modular multiplication without trial division}. Mathematics of Computation, 44(170):519-521, April 1985. \bibitem[9]{DRMET} Chae Hoon Lim and Pil Joong Lee, \textit{Generating Efficient Primes for Discrete Log Cryptosystems}, POSTECH Information Research Laboratories \bibitem[10]{MMB} J. Daemen and R. Govaerts and J. Vandewalle, \textit{Block ciphers based on Modular Arithmetic}, State and {P}rogress in the {R}esearch of {C}ryptography, 1993, pp. 80-89 \bibitem[11]{RSAREF} R.L. Rivest, A. Shamir, L. Adleman, \textit{A Method for Obtaining Digital Signatures and Public-Key Cryptosystems} \bibitem[12]{DHREF} Whitfield Diffie, Martin E. Hellman, \textit{New Directions in Cryptography}, IEEE Transactions on Information Theory, 1976 \bibitem[13]{IEEE} IEEE Standard for Binary Floating-Point Arithmetic (ANSI/IEEE Std 754-1985) \bibitem[14]{GMP} GNU Multiple Precision (GMP), \url{http://www.swox.com/gmp/} \bibitem[15]{MPI} Multiple Precision Integer Library (MPI), Michael Fromberger, \url{http://thayer.dartmouth.edu/~sting/mpi/} \bibitem[16]{OPENSSL} OpenSSL Cryptographic Toolkit, \url{http://openssl.org} \bibitem[17]{LIP} Large Integer Package, \url{http://home.hetnet.nl/~ecstr/LIP.zip} \bibitem[18]{ISOC} JTC1/SC22/WG14, ISO/IEC 9899:1999, ``A draft rationale for the C99 standard.'' \bibitem[19]{JAVA} The Sun Java Website, \url{http://java.sun.com/} \end{thebibliography} \input{tommath.ind} \end{document} |
Added libtommath/tommath.tex.
more than 10,000 changes
Added libtommath/tommath_class.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #if !(defined(LTM1) && defined(LTM2) && defined(LTM3)) #if defined(LTM2) #define LTM3 #endif #if defined(LTM1) #define LTM2 #endif #define LTM1 #if defined(LTM_ALL) #define BN_ERROR_C #define BN_FAST_MP_INVMOD_C #define BN_FAST_MP_MONTGOMERY_REDUCE_C #define BN_FAST_S_MP_MUL_DIGS_C #define BN_FAST_S_MP_MUL_HIGH_DIGS_C #define BN_FAST_S_MP_SQR_C #define BN_MP_2EXPT_C #define BN_MP_ABS_C #define BN_MP_ADD_C #define BN_MP_ADD_D_C #define BN_MP_ADDMOD_C #define BN_MP_AND_C #define BN_MP_CLAMP_C #define BN_MP_CLEAR_C #define BN_MP_CLEAR_MULTI_C #define BN_MP_CMP_C #define BN_MP_CMP_D_C #define BN_MP_CMP_MAG_C #define BN_MP_CNT_LSB_C #define BN_MP_COPY_C #define BN_MP_COUNT_BITS_C #define BN_MP_DIV_C #define BN_MP_DIV_2_C #define BN_MP_DIV_2D_C #define BN_MP_DIV_3_C #define BN_MP_DIV_D_C #define BN_MP_DR_IS_MODULUS_C #define BN_MP_DR_REDUCE_C #define BN_MP_DR_SETUP_C #define BN_MP_EXCH_C #define BN_MP_EXPT_D_C #define BN_MP_EXPTMOD_C #define BN_MP_EXPTMOD_FAST_C #define BN_MP_EXTEUCLID_C #define BN_MP_FREAD_C #define BN_MP_FWRITE_C #define BN_MP_GCD_C #define BN_MP_GET_INT_C #define BN_MP_GROW_C #define BN_MP_INIT_C #define BN_MP_INIT_COPY_C #define BN_MP_INIT_MULTI_C #define BN_MP_INIT_SET_C #define BN_MP_INIT_SET_INT_C #define BN_MP_INIT_SIZE_C #define BN_MP_INVMOD_C #define BN_MP_INVMOD_SLOW_C #define BN_MP_IS_SQUARE_C #define BN_MP_JACOBI_C #define BN_MP_KARATSUBA_MUL_C #define BN_MP_KARATSUBA_SQR_C #define BN_MP_LCM_C #define BN_MP_LSHD_C #define BN_MP_MOD_C #define BN_MP_MOD_2D_C #define BN_MP_MOD_D_C #define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C #define BN_MP_MONTGOMERY_REDUCE_C #define BN_MP_MONTGOMERY_SETUP_C #define BN_MP_MUL_C #define BN_MP_MUL_2_C #define BN_MP_MUL_2D_C #define BN_MP_MUL_D_C #define BN_MP_MULMOD_C #define BN_MP_N_ROOT_C #define BN_MP_NEG_C #define BN_MP_OR_C #define BN_MP_PRIME_FERMAT_C #define BN_MP_PRIME_IS_DIVISIBLE_C #define BN_MP_PRIME_IS_PRIME_C #define BN_MP_PRIME_MILLER_RABIN_C #define BN_MP_PRIME_NEXT_PRIME_C #define BN_MP_PRIME_RABIN_MILLER_TRIALS_C #define BN_MP_PRIME_RANDOM_EX_C #define BN_MP_RADIX_SIZE_C #define BN_MP_RADIX_SMAP_C #define BN_MP_RAND_C #define BN_MP_READ_RADIX_C #define BN_MP_READ_SIGNED_BIN_C #define BN_MP_READ_UNSIGNED_BIN_C #define BN_MP_REDUCE_C #define BN_MP_REDUCE_2K_C #define BN_MP_REDUCE_2K_L_C #define BN_MP_REDUCE_2K_SETUP_C #define BN_MP_REDUCE_2K_SETUP_L_C #define BN_MP_REDUCE_IS_2K_C #define BN_MP_REDUCE_IS_2K_L_C #define BN_MP_REDUCE_SETUP_C #define BN_MP_RSHD_C #define BN_MP_SET_C #define BN_MP_SET_INT_C #define BN_MP_SHRINK_C #define BN_MP_SIGNED_BIN_SIZE_C #define BN_MP_SQR_C #define BN_MP_SQRMOD_C #define BN_MP_SQRT_C #define BN_MP_SUB_C #define BN_MP_SUB_D_C #define BN_MP_SUBMOD_C #define BN_MP_TO_SIGNED_BIN_C #define BN_MP_TO_SIGNED_BIN_N_C #define BN_MP_TO_UNSIGNED_BIN_C #define BN_MP_TO_UNSIGNED_BIN_N_C #define BN_MP_TOOM_MUL_C #define BN_MP_TOOM_SQR_C #define BN_MP_TORADIX_C #define BN_MP_TORADIX_N_C #define BN_MP_UNSIGNED_BIN_SIZE_C #define BN_MP_XOR_C #define BN_MP_ZERO_C #define BN_PRIME_TAB_C #define BN_REVERSE_C #define BN_S_MP_ADD_C #define BN_S_MP_EXPTMOD_C #define BN_S_MP_MUL_DIGS_C #define BN_S_MP_MUL_HIGH_DIGS_C #define BN_S_MP_SQR_C #define BN_S_MP_SUB_C #define BNCORE_C #endif #if defined(BN_ERROR_C) #define BN_MP_ERROR_TO_STRING_C #endif #if defined(BN_FAST_MP_INVMOD_C) #define BN_MP_ISEVEN_C #define BN_MP_INIT_MULTI_C #define BN_MP_COPY_C #define BN_MP_MOD_C #define BN_MP_SET_C #define BN_MP_DIV_2_C #define BN_MP_ISODD_C #define BN_MP_SUB_C #define BN_MP_CMP_C #define BN_MP_ISZERO_C #define BN_MP_CMP_D_C #define BN_MP_ADD_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_MULTI_C #endif #if defined(BN_FAST_MP_MONTGOMERY_REDUCE_C) #define BN_MP_GROW_C #define BN_MP_RSHD_C #define BN_MP_CLAMP_C #define BN_MP_CMP_MAG_C #define BN_S_MP_SUB_C #endif #if defined(BN_FAST_S_MP_MUL_DIGS_C) #define BN_MP_GROW_C #define BN_MP_CLAMP_C #endif #if defined(BN_FAST_S_MP_MUL_HIGH_DIGS_C) #define BN_MP_GROW_C #define BN_MP_CLAMP_C #endif #if defined(BN_FAST_S_MP_SQR_C) #define BN_MP_GROW_C #define BN_MP_CLAMP_C #endif #if defined(BN_MP_2EXPT_C) #define BN_MP_ZERO_C #define BN_MP_GROW_C #endif #if defined(BN_MP_ABS_C) #define BN_MP_COPY_C #endif #if defined(BN_MP_ADD_C) #define BN_S_MP_ADD_C #define BN_MP_CMP_MAG_C #define BN_S_MP_SUB_C #endif #if defined(BN_MP_ADD_D_C) #define BN_MP_GROW_C #define BN_MP_SUB_D_C #define BN_MP_CLAMP_C #endif #if defined(BN_MP_ADDMOD_C) #define BN_MP_INIT_C #define BN_MP_ADD_C #define BN_MP_CLEAR_C #define BN_MP_MOD_C #endif #if defined(BN_MP_AND_C) #define BN_MP_INIT_COPY_C #define BN_MP_CLAMP_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_CLAMP_C) #endif #if defined(BN_MP_CLEAR_C) #endif #if defined(BN_MP_CLEAR_MULTI_C) #define BN_MP_CLEAR_C #endif #if defined(BN_MP_CMP_C) #define BN_MP_CMP_MAG_C #endif #if defined(BN_MP_CMP_D_C) #endif #if defined(BN_MP_CMP_MAG_C) #endif #if defined(BN_MP_CNT_LSB_C) #define BN_MP_ISZERO_C #endif #if defined(BN_MP_COPY_C) #define BN_MP_GROW_C #endif #if defined(BN_MP_COUNT_BITS_C) #endif #if defined(BN_MP_DIV_C) #define BN_MP_ISZERO_C #define BN_MP_CMP_MAG_C #define BN_MP_COPY_C #define BN_MP_ZERO_C #define BN_MP_INIT_MULTI_C #define BN_MP_SET_C #define BN_MP_COUNT_BITS_C #define BN_MP_ABS_C #define BN_MP_MUL_2D_C #define BN_MP_CMP_C #define BN_MP_SUB_C #define BN_MP_ADD_C #define BN_MP_DIV_2D_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_MULTI_C #define BN_MP_INIT_SIZE_C #define BN_MP_INIT_C #define BN_MP_INIT_COPY_C #define BN_MP_LSHD_C #define BN_MP_RSHD_C #define BN_MP_MUL_D_C #define BN_MP_CLAMP_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_DIV_2_C) #define BN_MP_GROW_C #define BN_MP_CLAMP_C #endif #if defined(BN_MP_DIV_2D_C) #define BN_MP_COPY_C #define BN_MP_ZERO_C #define BN_MP_INIT_C #define BN_MP_MOD_2D_C #define BN_MP_CLEAR_C #define BN_MP_RSHD_C #define BN_MP_CLAMP_C #define BN_MP_EXCH_C #endif #if defined(BN_MP_DIV_3_C) #define BN_MP_INIT_SIZE_C #define BN_MP_CLAMP_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_DIV_D_C) #define BN_MP_ISZERO_C #define BN_MP_COPY_C #define BN_MP_DIV_2D_C #define BN_MP_DIV_3_C #define BN_MP_INIT_SIZE_C #define BN_MP_CLAMP_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_DR_IS_MODULUS_C) #endif #if defined(BN_MP_DR_REDUCE_C) #define BN_MP_GROW_C #define BN_MP_CLAMP_C #define BN_MP_CMP_MAG_C #define BN_S_MP_SUB_C #endif #if defined(BN_MP_DR_SETUP_C) #endif #if defined(BN_MP_EXCH_C) #endif #if defined(BN_MP_EXPT_D_C) #define BN_MP_INIT_COPY_C #define BN_MP_SET_C #define BN_MP_SQR_C #define BN_MP_CLEAR_C #define BN_MP_MUL_C #endif #if defined(BN_MP_EXPTMOD_C) #define BN_MP_INIT_C #define BN_MP_INVMOD_C #define BN_MP_CLEAR_C #define BN_MP_ABS_C #define BN_MP_CLEAR_MULTI_C #define BN_MP_REDUCE_IS_2K_L_C #define BN_S_MP_EXPTMOD_C #define BN_MP_DR_IS_MODULUS_C #define BN_MP_REDUCE_IS_2K_C #define BN_MP_ISODD_C #define BN_MP_EXPTMOD_FAST_C #endif #if defined(BN_MP_EXPTMOD_FAST_C) #define BN_MP_COUNT_BITS_C #define BN_MP_INIT_C #define BN_MP_CLEAR_C #define BN_MP_MONTGOMERY_SETUP_C #define BN_FAST_MP_MONTGOMERY_REDUCE_C #define BN_MP_MONTGOMERY_REDUCE_C #define BN_MP_DR_SETUP_C #define BN_MP_DR_REDUCE_C #define BN_MP_REDUCE_2K_SETUP_C #define BN_MP_REDUCE_2K_C #define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C #define BN_MP_MULMOD_C #define BN_MP_SET_C #define BN_MP_MOD_C #define BN_MP_COPY_C #define BN_MP_SQR_C #define BN_MP_MUL_C #define BN_MP_EXCH_C #endif #if defined(BN_MP_EXTEUCLID_C) #define BN_MP_INIT_MULTI_C #define BN_MP_SET_C #define BN_MP_COPY_C #define BN_MP_ISZERO_C #define BN_MP_DIV_C #define BN_MP_MUL_C #define BN_MP_SUB_C #define BN_MP_NEG_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_MULTI_C #endif #if defined(BN_MP_FREAD_C) #define BN_MP_ZERO_C #define BN_MP_S_RMAP_C #define BN_MP_MUL_D_C #define BN_MP_ADD_D_C #define BN_MP_CMP_D_C #endif #if defined(BN_MP_FWRITE_C) #define BN_MP_RADIX_SIZE_C #define BN_MP_TORADIX_C #endif #if defined(BN_MP_GCD_C) #define BN_MP_ISZERO_C #define BN_MP_ABS_C #define BN_MP_ZERO_C #define BN_MP_INIT_COPY_C #define BN_MP_CNT_LSB_C #define BN_MP_DIV_2D_C #define BN_MP_CMP_MAG_C #define BN_MP_EXCH_C #define BN_S_MP_SUB_C #define BN_MP_MUL_2D_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_GET_INT_C) #endif #if defined(BN_MP_GROW_C) #endif #if defined(BN_MP_INIT_C) #endif #if defined(BN_MP_INIT_COPY_C) #define BN_MP_COPY_C #endif #if defined(BN_MP_INIT_MULTI_C) #define BN_MP_ERR_C #define BN_MP_INIT_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_INIT_SET_C) #define BN_MP_INIT_C #define BN_MP_SET_C #endif #if defined(BN_MP_INIT_SET_INT_C) #define BN_MP_INIT_C #define BN_MP_SET_INT_C #endif #if defined(BN_MP_INIT_SIZE_C) #define BN_MP_INIT_C #endif #if defined(BN_MP_INVMOD_C) #define BN_MP_ISZERO_C #define BN_MP_ISODD_C #define BN_FAST_MP_INVMOD_C #define BN_MP_INVMOD_SLOW_C #endif #if defined(BN_MP_INVMOD_SLOW_C) #define BN_MP_ISZERO_C #define BN_MP_INIT_MULTI_C #define BN_MP_MOD_C #define BN_MP_COPY_C #define BN_MP_ISEVEN_C #define BN_MP_SET_C #define BN_MP_DIV_2_C #define BN_MP_ISODD_C #define BN_MP_ADD_C #define BN_MP_SUB_C #define BN_MP_CMP_C #define BN_MP_CMP_D_C #define BN_MP_CMP_MAG_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_MULTI_C #endif #if defined(BN_MP_IS_SQUARE_C) #define BN_MP_MOD_D_C #define BN_MP_INIT_SET_INT_C #define BN_MP_MOD_C #define BN_MP_GET_INT_C #define BN_MP_SQRT_C #define BN_MP_SQR_C #define BN_MP_CMP_MAG_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_JACOBI_C) #define BN_MP_CMP_D_C #define BN_MP_ISZERO_C #define BN_MP_INIT_COPY_C #define BN_MP_CNT_LSB_C #define BN_MP_DIV_2D_C #define BN_MP_MOD_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_KARATSUBA_MUL_C) #define BN_MP_MUL_C #define BN_MP_INIT_SIZE_C #define BN_MP_CLAMP_C #define BN_MP_SUB_C #define BN_MP_ADD_C #define BN_MP_LSHD_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_KARATSUBA_SQR_C) #define BN_MP_INIT_SIZE_C #define BN_MP_CLAMP_C #define BN_MP_SQR_C #define BN_MP_SUB_C #define BN_S_MP_ADD_C #define BN_MP_LSHD_C #define BN_MP_ADD_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_LCM_C) #define BN_MP_INIT_MULTI_C #define BN_MP_GCD_C #define BN_MP_CMP_MAG_C #define BN_MP_DIV_C #define BN_MP_MUL_C #define BN_MP_CLEAR_MULTI_C #endif #if defined(BN_MP_LSHD_C) #define BN_MP_GROW_C #define BN_MP_RSHD_C #endif #if defined(BN_MP_MOD_C) #define BN_MP_INIT_C #define BN_MP_DIV_C #define BN_MP_CLEAR_C #define BN_MP_ADD_C #define BN_MP_EXCH_C #endif #if defined(BN_MP_MOD_2D_C) #define BN_MP_ZERO_C #define BN_MP_COPY_C #define BN_MP_CLAMP_C #endif #if defined(BN_MP_MOD_D_C) #define BN_MP_DIV_D_C #endif #if defined(BN_MP_MONTGOMERY_CALC_NORMALIZATION_C) #define BN_MP_COUNT_BITS_C #define BN_MP_2EXPT_C #define BN_MP_SET_C #define BN_MP_MUL_2_C #define BN_MP_CMP_MAG_C #define BN_S_MP_SUB_C #endif #if defined(BN_MP_MONTGOMERY_REDUCE_C) #define BN_FAST_MP_MONTGOMERY_REDUCE_C #define BN_MP_GROW_C #define BN_MP_CLAMP_C #define BN_MP_RSHD_C #define BN_MP_CMP_MAG_C #define BN_S_MP_SUB_C #endif #if defined(BN_MP_MONTGOMERY_SETUP_C) #endif #if defined(BN_MP_MUL_C) #define BN_MP_TOOM_MUL_C #define BN_MP_KARATSUBA_MUL_C #define BN_FAST_S_MP_MUL_DIGS_C #define BN_S_MP_MUL_C #define BN_S_MP_MUL_DIGS_C #endif #if defined(BN_MP_MUL_2_C) #define BN_MP_GROW_C #endif #if defined(BN_MP_MUL_2D_C) #define BN_MP_COPY_C #define BN_MP_GROW_C #define BN_MP_LSHD_C #define BN_MP_CLAMP_C #endif #if defined(BN_MP_MUL_D_C) #define BN_MP_GROW_C #define BN_MP_CLAMP_C #endif #if defined(BN_MP_MULMOD_C) #define BN_MP_INIT_C #define BN_MP_MUL_C #define BN_MP_CLEAR_C #define BN_MP_MOD_C #endif #if defined(BN_MP_N_ROOT_C) #define BN_MP_INIT_C #define BN_MP_SET_C #define BN_MP_COPY_C #define BN_MP_EXPT_D_C #define BN_MP_MUL_C #define BN_MP_SUB_C #define BN_MP_MUL_D_C #define BN_MP_DIV_C #define BN_MP_CMP_C #define BN_MP_SUB_D_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_NEG_C) #define BN_MP_COPY_C #define BN_MP_ISZERO_C #endif #if defined(BN_MP_OR_C) #define BN_MP_INIT_COPY_C #define BN_MP_CLAMP_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_PRIME_FERMAT_C) #define BN_MP_CMP_D_C #define BN_MP_INIT_C #define BN_MP_EXPTMOD_C #define BN_MP_CMP_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_PRIME_IS_DIVISIBLE_C) #define BN_MP_MOD_D_C #endif #if defined(BN_MP_PRIME_IS_PRIME_C) #define BN_MP_CMP_D_C #define BN_MP_PRIME_IS_DIVISIBLE_C #define BN_MP_INIT_C #define BN_MP_SET_C #define BN_MP_PRIME_MILLER_RABIN_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_PRIME_MILLER_RABIN_C) #define BN_MP_CMP_D_C #define BN_MP_INIT_COPY_C #define BN_MP_SUB_D_C #define BN_MP_CNT_LSB_C #define BN_MP_DIV_2D_C #define BN_MP_EXPTMOD_C #define BN_MP_CMP_C #define BN_MP_SQRMOD_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_PRIME_NEXT_PRIME_C) #define BN_MP_CMP_D_C #define BN_MP_SET_C #define BN_MP_SUB_D_C #define BN_MP_ISEVEN_C #define BN_MP_MOD_D_C #define BN_MP_INIT_C #define BN_MP_ADD_D_C #define BN_MP_PRIME_MILLER_RABIN_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_PRIME_RABIN_MILLER_TRIALS_C) #endif #if defined(BN_MP_PRIME_RANDOM_EX_C) #define BN_MP_READ_UNSIGNED_BIN_C #define BN_MP_PRIME_IS_PRIME_C #define BN_MP_SUB_D_C #define BN_MP_DIV_2_C #define BN_MP_MUL_2_C #define BN_MP_ADD_D_C #endif #if defined(BN_MP_RADIX_SIZE_C) #define BN_MP_COUNT_BITS_C #define BN_MP_INIT_COPY_C #define BN_MP_ISZERO_C #define BN_MP_DIV_D_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_RADIX_SMAP_C) #define BN_MP_S_RMAP_C #endif #if defined(BN_MP_RAND_C) #define BN_MP_ZERO_C #define BN_MP_ADD_D_C #define BN_MP_LSHD_C #endif #if defined(BN_MP_READ_RADIX_C) #define BN_MP_ZERO_C #define BN_MP_S_RMAP_C #define BN_MP_RADIX_SMAP_C #define BN_MP_MUL_D_C #define BN_MP_ADD_D_C #define BN_MP_ISZERO_C #endif #if defined(BN_MP_READ_SIGNED_BIN_C) #define BN_MP_READ_UNSIGNED_BIN_C #endif #if defined(BN_MP_READ_UNSIGNED_BIN_C) #define BN_MP_GROW_C #define BN_MP_ZERO_C #define BN_MP_MUL_2D_C #define BN_MP_CLAMP_C #endif #if defined(BN_MP_REDUCE_C) #define BN_MP_REDUCE_SETUP_C #define BN_MP_INIT_COPY_C #define BN_MP_RSHD_C #define BN_MP_MUL_C #define BN_S_MP_MUL_HIGH_DIGS_C #define BN_FAST_S_MP_MUL_HIGH_DIGS_C #define BN_MP_MOD_2D_C #define BN_S_MP_MUL_DIGS_C #define BN_MP_SUB_C #define BN_MP_CMP_D_C #define BN_MP_SET_C #define BN_MP_LSHD_C #define BN_MP_ADD_C #define BN_MP_CMP_C #define BN_S_MP_SUB_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_REDUCE_2K_C) #define BN_MP_INIT_C #define BN_MP_COUNT_BITS_C #define BN_MP_DIV_2D_C #define BN_MP_MUL_D_C #define BN_S_MP_ADD_C #define BN_MP_CMP_MAG_C #define BN_S_MP_SUB_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_REDUCE_2K_L_C) #define BN_MP_INIT_C #define BN_MP_COUNT_BITS_C #define BN_MP_DIV_2D_C #define BN_MP_MUL_C #define BN_S_MP_ADD_C #define BN_MP_CMP_MAG_C #define BN_S_MP_SUB_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_REDUCE_2K_SETUP_C) #define BN_MP_INIT_C #define BN_MP_COUNT_BITS_C #define BN_MP_2EXPT_C #define BN_MP_CLEAR_C #define BN_S_MP_SUB_C #endif #if defined(BN_MP_REDUCE_2K_SETUP_L_C) #define BN_MP_INIT_C #define BN_MP_2EXPT_C #define BN_MP_COUNT_BITS_C #define BN_S_MP_SUB_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_REDUCE_IS_2K_C) #define BN_MP_REDUCE_2K_C #define BN_MP_COUNT_BITS_C #endif #if defined(BN_MP_REDUCE_IS_2K_L_C) #endif #if defined(BN_MP_REDUCE_SETUP_C) #define BN_MP_2EXPT_C #define BN_MP_DIV_C #endif #if defined(BN_MP_RSHD_C) #define BN_MP_ZERO_C #endif #if defined(BN_MP_SET_C) #define BN_MP_ZERO_C #endif #if defined(BN_MP_SET_INT_C) #define BN_MP_ZERO_C #define BN_MP_MUL_2D_C #define BN_MP_CLAMP_C #endif #if defined(BN_MP_SHRINK_C) #endif #if defined(BN_MP_SIGNED_BIN_SIZE_C) #define BN_MP_UNSIGNED_BIN_SIZE_C #endif #if defined(BN_MP_SQR_C) #define BN_MP_TOOM_SQR_C #define BN_MP_KARATSUBA_SQR_C #define BN_FAST_S_MP_SQR_C #define BN_S_MP_SQR_C #endif #if defined(BN_MP_SQRMOD_C) #define BN_MP_INIT_C #define BN_MP_SQR_C #define BN_MP_CLEAR_C #define BN_MP_MOD_C #endif #if defined(BN_MP_SQRT_C) #define BN_MP_N_ROOT_C #define BN_MP_ISZERO_C #define BN_MP_ZERO_C #define BN_MP_INIT_COPY_C #define BN_MP_RSHD_C #define BN_MP_DIV_C #define BN_MP_ADD_C #define BN_MP_DIV_2_C #define BN_MP_CMP_MAG_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_SUB_C) #define BN_S_MP_ADD_C #define BN_MP_CMP_MAG_C #define BN_S_MP_SUB_C #endif #if defined(BN_MP_SUB_D_C) #define BN_MP_GROW_C #define BN_MP_ADD_D_C #define BN_MP_CLAMP_C #endif #if defined(BN_MP_SUBMOD_C) #define BN_MP_INIT_C #define BN_MP_SUB_C #define BN_MP_CLEAR_C #define BN_MP_MOD_C #endif #if defined(BN_MP_TO_SIGNED_BIN_C) #define BN_MP_TO_UNSIGNED_BIN_C #endif #if defined(BN_MP_TO_SIGNED_BIN_N_C) #define BN_MP_SIGNED_BIN_SIZE_C #define BN_MP_TO_SIGNED_BIN_C #endif #if defined(BN_MP_TO_UNSIGNED_BIN_C) #define BN_MP_INIT_COPY_C #define BN_MP_ISZERO_C #define BN_MP_DIV_2D_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_TO_UNSIGNED_BIN_N_C) #define BN_MP_UNSIGNED_BIN_SIZE_C #define BN_MP_TO_UNSIGNED_BIN_C #endif #if defined(BN_MP_TOOM_MUL_C) #define BN_MP_INIT_MULTI_C #define BN_MP_MOD_2D_C #define BN_MP_COPY_C #define BN_MP_RSHD_C #define BN_MP_MUL_C #define BN_MP_MUL_2_C #define BN_MP_ADD_C #define BN_MP_SUB_C #define BN_MP_DIV_2_C #define BN_MP_MUL_2D_C #define BN_MP_MUL_D_C #define BN_MP_DIV_3_C #define BN_MP_LSHD_C #define BN_MP_CLEAR_MULTI_C #endif #if defined(BN_MP_TOOM_SQR_C) #define BN_MP_INIT_MULTI_C #define BN_MP_MOD_2D_C #define BN_MP_COPY_C #define BN_MP_RSHD_C #define BN_MP_SQR_C #define BN_MP_MUL_2_C #define BN_MP_ADD_C #define BN_MP_SUB_C #define BN_MP_DIV_2_C #define BN_MP_MUL_2D_C #define BN_MP_MUL_D_C #define BN_MP_DIV_3_C #define BN_MP_LSHD_C #define BN_MP_CLEAR_MULTI_C #endif #if defined(BN_MP_TORADIX_C) #define BN_MP_ISZERO_C #define BN_MP_INIT_COPY_C #define BN_MP_DIV_D_C #define BN_MP_CLEAR_C #define BN_MP_S_RMAP_C #endif #if defined(BN_MP_TORADIX_N_C) #define BN_MP_ISZERO_C #define BN_MP_INIT_COPY_C #define BN_MP_DIV_D_C #define BN_MP_CLEAR_C #define BN_MP_S_RMAP_C #endif #if defined(BN_MP_UNSIGNED_BIN_SIZE_C) #define BN_MP_COUNT_BITS_C #endif #if defined(BN_MP_XOR_C) #define BN_MP_INIT_COPY_C #define BN_MP_CLAMP_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_C #endif #if defined(BN_MP_ZERO_C) #endif #if defined(BN_PRIME_TAB_C) #endif #if defined(BN_REVERSE_C) #endif #if defined(BN_S_MP_ADD_C) #define BN_MP_GROW_C #define BN_MP_CLAMP_C #endif #if defined(BN_S_MP_EXPTMOD_C) #define BN_MP_COUNT_BITS_C #define BN_MP_INIT_C #define BN_MP_CLEAR_C #define BN_MP_REDUCE_SETUP_C #define BN_MP_REDUCE_C #define BN_MP_REDUCE_2K_SETUP_L_C #define BN_MP_REDUCE_2K_L_C #define BN_MP_MOD_C #define BN_MP_COPY_C #define BN_MP_SQR_C #define BN_MP_MUL_C #define BN_MP_SET_C #define BN_MP_EXCH_C #endif #if defined(BN_S_MP_MUL_DIGS_C) #define BN_FAST_S_MP_MUL_DIGS_C #define BN_MP_INIT_SIZE_C #define BN_MP_CLAMP_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_C #endif #if defined(BN_S_MP_MUL_HIGH_DIGS_C) #define BN_FAST_S_MP_MUL_HIGH_DIGS_C #define BN_MP_INIT_SIZE_C #define BN_MP_CLAMP_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_C #endif #if defined(BN_S_MP_SQR_C) #define BN_MP_INIT_SIZE_C #define BN_MP_CLAMP_C #define BN_MP_EXCH_C #define BN_MP_CLEAR_C #endif #if defined(BN_S_MP_SUB_C) #define BN_MP_GROW_C #define BN_MP_CLAMP_C #endif #if defined(BNCORE_C) #endif #ifdef LTM3 #define LTM_LAST #endif #include <tommath_superclass.h> #include <tommath_class.h> #else #define LTM_LAST #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/tommath_class.h,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Added libtommath/tommath_superclass.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | /* super class file for PK algos */ /* default ... include all MPI */ #define LTM_ALL /* RSA only (does not support DH/DSA/ECC) */ /* #define SC_RSA_1 */ /* For reference.... On an Athlon64 optimizing for speed... LTM's mpi.o with all functions [striped] is 142KiB in size. */ /* Works for RSA only, mpi.o is 68KiB */ #ifdef SC_RSA_1 #define BN_MP_SHRINK_C #define BN_MP_LCM_C #define BN_MP_PRIME_RANDOM_EX_C #define BN_MP_INVMOD_C #define BN_MP_GCD_C #define BN_MP_MOD_C #define BN_MP_MULMOD_C #define BN_MP_ADDMOD_C #define BN_MP_EXPTMOD_C #define BN_MP_SET_INT_C #define BN_MP_INIT_MULTI_C #define BN_MP_CLEAR_MULTI_C #define BN_MP_UNSIGNED_BIN_SIZE_C #define BN_MP_TO_UNSIGNED_BIN_C #define BN_MP_MOD_D_C #define BN_MP_PRIME_RABIN_MILLER_TRIALS_C #define BN_REVERSE_C #define BN_PRIME_TAB_C /* other modifiers */ #define BN_MP_DIV_SMALL /* Slower division, not critical */ /* here we are on the last pass so we turn things off. The functions classes are still there * but we remove them specifically from the build. This also invokes tweaks in functions * like removing support for even moduli, etc... */ #ifdef LTM_LAST #undef BN_MP_TOOM_MUL_C #undef BN_MP_TOOM_SQR_C #undef BN_MP_KARATSUBA_MUL_C #undef BN_MP_KARATSUBA_SQR_C #undef BN_MP_REDUCE_C #undef BN_MP_REDUCE_SETUP_C #undef BN_MP_DR_IS_MODULUS_C #undef BN_MP_DR_SETUP_C #undef BN_MP_DR_REDUCE_C #undef BN_MP_REDUCE_IS_2K_C #undef BN_MP_REDUCE_2K_SETUP_C #undef BN_MP_REDUCE_2K_C #undef BN_S_MP_EXPTMOD_C #undef BN_MP_DIV_3_C #undef BN_S_MP_MUL_HIGH_DIGS_C #undef BN_FAST_S_MP_MUL_HIGH_DIGS_C #undef BN_FAST_MP_INVMOD_C /* To safely undefine these you have to make sure your RSA key won't exceed the Comba threshold * which is roughly 255 digits [7140 bits for 32-bit machines, 15300 bits for 64-bit machines] * which means roughly speaking you can handle upto 2536-bit RSA keys with these defined without * trouble. */ #undef BN_S_MP_MUL_DIGS_C #undef BN_S_MP_SQR_C #undef BN_MP_MONTGOMERY_REDUCE_C #endif #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/tommath_superclass.h,v $ */ /* $Revision: 1.1.1.1.2.2 $ */ /* $Date: 2005/09/26 20:16:54 $ */ |
Changes to macosx/Makefile.
1 2 | ######################################################################################################## # | | | > | | > < < < < < | > > > > | < < | | < | < | < < < | | < < | < < | < < < < > | > > | | | > > > | | | > > > > > > | > | | | < < | | < | | | < | > | < > | | < | | > | | > | > | > > > > > > > | < > > | > | | < < < | | < | | | < < < < < < | | < < < > | < | | | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | ######################################################################################################## # # Makefile wrapper to build tcl on Mac OS X in a way compatible with the tk/macosx Xcode buildsystem # uses the standard unix build system in tcl/unix (which can be used directly instead of this # if you are not using the tk/macosx projects). # # RCS: @(#) $Id: Makefile,v 1.18.2.2 2005/07/12 20:37:06 kennykb Exp $ # ######################################################################################################## #------------------------------------------------------------------------------------------------------- # customizable settings DESTDIR ?= INSTALL_ROOT ?= ${DESTDIR} BUILD_DIR ?= ${CURDIR}/../../build SYMROOT ?= ${BUILD_DIR}/${PROJECT} OBJROOT ?= ${SYMROOT} EXTRA_CONFIGURE_ARGS ?= EXTRA_MAKE_ARGS ?= INSTALL_PATH ?= /Library/Frameworks PREFIX ?= /usr/local BINDIR ?= ${PREFIX}/bin LIBDIR ?= ${INSTALL_PATH} MANDIR ?= ${PREFIX}/man # set to non-empty value to install manpages in addition to html help: INSTALL_MANPAGES ?= #------------------------------------------------------------------------------------------------------- # meta targets meta := all install embedded install-embedded clean distclean test styles := develop deploy all := ${styles} all : ${all} install := ${styles:%=install-%} install : ${install} install-%: action := install- embedded := ${styles:%=embedded-%} embedded : embedded-deploy install-embedded := ${embedded:%=install-%} install-embedded : install-embedded-deploy clean := ${styles:%=clean-%} clean : ${clean} clean-%: action := clean- distclean := ${styles:%=distclean-%} distclean : ${distclean} distclean-%: action := distclean- test := ${styles:%=test-%} test : ${test} test-%: action := test- targets := $(foreach v,${meta},${$v}) #------------------------------------------------------------------------------------------------------- # build styles BUILD_STYLE = CONFIGURE_ARGS = OBJ_DIR = ${OBJROOT}/${BUILD_STYLE} develop_make_args := BUILD_STYLE=Development CONFIGURE_ARGS=--enable-symbols deploy_make_args := BUILD_STYLE=Deployment INSTALL_TARGET=install-strip \ GENERIC_FLAGS=-DNDEBUG embedded_make_args := EMBEDDED_BUILD=1 install_make_args := INSTALL_BUILD=1 ${targets}: ${MAKE} ${action}${PROJECT} \ $(foreach s,${styles} embedded install,$(if $(findstring $s,$@),${${s}_make_args})) #------------------------------------------------------------------------------------------------------- # project specific settings PROJECT := tcl PRODUCT_NAME := Tcl UNIX_DIR := ${CURDIR}/../unix VERSION := $(shell awk -F= '/^TCL_VERSION/ {print $$2; nextfile}' ${UNIX_DIR}/configure.in) TCLSH := tclsh${VERSION} BUILD_TARGET := tclsh tcltest INSTALL_TARGET := install override GENERIC_FLAGS := ${GENERIC_FLAGS} -DTCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING export CPPROG := cp -p INSTALL_TARGETS = install-binaries install-libraries ifeq (${EMBEDDED_BUILD},) INSTALL_TARGETS += install-private-headers endif ifeq (${INSTALL_BUILD}_${EMBEDDED_BUILD}_${BUILD_STYLE},1__Deployment) INSTALL_TARGETS += html-tcl ifneq (${INSTALL_MANPAGES},) INSTALL_TARGETS += install-doc endif endif MAKE_VARS := INSTALL_ROOT INSTALL_TARGETS VERSION GENERIC_FLAGS MAKE_ARGS_V = $(foreach v,${MAKE_VARS},$v='${$v}') build-${PROJECT}: target = ${TARGET} install-${PROJECT}: target = ${INSTALL_TARGET} clean-${PROJECT} distclean-${PROJECT} test-${PROJECT}: \ target = $* DO_MAKE = +${MAKE} -C ${OBJ_DIR} ${target} ${MAKE_ARGS_V} ${MAKE_ARGS} ${EXTRA_MAKE_ARGS} #------------------------------------------------------------------------------------------------------- # build rules ${PROJECT}: ${MAKE} install-${PROJECT} INSTALL_ROOT=${OBJ_DIR}/ ${OBJ_DIR}/Makefile: ${UNIX_DIR}/Makefile.in ${UNIX_DIR}/configure mkdir -p ${OBJ_DIR} && cd ${OBJ_DIR} && ${UNIX_DIR}/configure -C \ --prefix=${PREFIX} --bindir=${BINDIR} --libdir=${LIBDIR} \ --mandir=${MANDIR} --enable-threads --enable-framework \ ${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS} build-${PROJECT}: ${OBJ_DIR}/Makefile ${DO_MAKE} # symolic link hackery to trick # 'make install INSTALL_ROOT=${OBJ_DIR}' # into building Tcl.framework and tclsh in ${SYMROOT} @cd ${OBJ_DIR} && mkdir -p $(dir ./${LIBDIR}) $(dir ./${BINDIR}) ${SYMROOT} && \ rm -f ./${LIBDIR} ./${BINDIR} && ln -fs ${SYMROOT} ./${LIBDIR} && \ ln -fs ${SYMROOT} ./${BINDIR} && ln -fs ${OBJ_DIR}/tcltest ${SYMROOT} install-${PROJECT}: build-${PROJECT} ifeq (${EMBEDDED_BUILD}_${INSTALL_ROOT},1_) @echo "Cannot install-embedded with empty INSTALL_ROOT !" && false endif ifeq (${EMBEDDED_BUILD},1) @rm -rf "${INSTALL_ROOT}/${LIBDIR}/Tcl.framework" endif ${DO_MAKE} ifeq (${INSTALL_BUILD},1) ifeq (${EMBEDDED_BUILD},1) # if we are embedding frameworks, don't install tclsh @rm -f "${INSTALL_ROOT}${BINDIR}/${TCLSH}" && \ rmdir -p "${INSTALL_ROOT}${BINDIR}" 2>&- || true else # redo prebinding @cd ${INSTALL_ROOT}/ && \ if [ ! -d usr/lib ]; then mkdir -p usr && ln -fs /usr/lib usr/ && RM_USRLIB=1; fi; \ if [ ! -d System ]; then ln -fs /System . && RM_SYSTEM=1; fi; \ redo_prebinding -r . "./${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}/${PRODUCT_NAME}"; \ redo_prebinding -r . "./${BINDIR}/${TCLSH}"; \ if [ -n "$${RM_USRLIB:-}" ]; then rm -f usr/lib; rmdir -p usr 2>&-; fi; \ if [ -n "$${RM_SYSTEM:-}" ]; then rm -f System; fi # install tclsh symbolic link @ln -fs ${TCLSH} ${INSTALL_ROOT}${BINDIR}/tclsh endif endif ifeq (${BUILD_STYLE}_${EMBEDDED_BUILD},Development_) # keep copy of debug library around, so that # Deployment build can be installed on top # of Development build without overwriting # the debug library @cd ${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION} && \ ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug" endif clean-${PROJECT}: %-${PROJECT}: ${DO_MAKE} rm -rf ${SYMROOT}/{${PRODUCT_NAME}.framework,${TCLSH},tcltest} rm -f ${OBJ_DIR}{${LIBDIR},${BINDIR}} && \ rmdir -p ${OBJ_DIR}$(dir ${LIBDIR}) 2>&- || true && \ rmdir -p ${OBJ_DIR}$(dir ${BINDIR}) 2>&- || true distclean-${PROJECT}: %-${PROJECT}: clean-${PROJECT} ${DO_MAKE} rm -rf ${OBJ_DIR} test-${PROJECT}: %-${PROJECT}: build-${PROJECT} ${DO_MAKE} #------------------------------------------------------------------------------------------------------- .PHONY: ${meta} ${targets} ${PROJECT} build-${PROJECT} install-${PROJECT} \ clean-${PROJECT} distclean-${PROJECT} .NOTPARALLEL: #------------------------------------------------------------------------------------------------------- |
Changes to macosx/README.
1 2 3 | Tcl MacOSX README ----------------- | | | 1 2 3 4 5 6 7 8 9 10 11 | Tcl MacOSX README ----------------- RCS: @(#) $Id: README,v 1.2.4.2 2005/07/12 20:37:06 kennykb Exp $ This is the README file for the Mac OS X native version of Tcl (framework build). 1. General ---------- |
︙ | ︙ | |||
30 31 32 33 34 35 36 | please make sure that your report Tk specific bugs to the tktoolkit bug tracker and not the tcl one. 2. Using Tcl on MacOSX ---------------------- | | | | | | | | | | | > > | > | > | < < | | 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 | please make sure that your report Tk specific bugs to the tktoolkit bug tracker and not the tcl one. 2. Using Tcl on MacOSX ---------------------- - Mac OS X 10.2 (or higher) is required to run Tcl on MacOSX. - Tcl built on Mac OS X 10.3 or higher will not run on 10.2 due to missing symbols in libSystem, however Tcl built on 10.2 will run on 10.3 (but without prebinding and other optimizations). - Tcl extensions will be found in any of: $HOME/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl $HOME/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks (searched in that order). Given a potential package directory $pkg, Tcl on OSX checks for the file $pkg/Resources/Scripts/pkgIndex.tcl as well as the usual $pkg/pkgIndex.tcl. This allows building extensions as frameworks with all script files contained in the Resources/Scripts directory of the framework. - The Tcl framework contains documentation in html format in the standard location for frameworks: Tcl.framework/Resources/Documentation/Reference/Tcl No manpages are installed by default. - the framework Tcl.framework can be placed in any of the system's standard framework directories: $HOME/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks and /usr/bin/tclsh will work. - the format of binary extensions expected by [load] is that of ordinary shared libraries (.dylib) and not MachO bundles, at present loading of MachO bundles is not supported. 3. Building Tcl.framework ------------------------- - Mac OS X 10.2 (or higher) is required to build Tcl on MacOSX. - Apple's Developer Tools CD needs to be installed (the most recent version matching your OS release, but no earlier than December 2002). This CD should have come with Mac OS X retail or should be present as a disk image on new macs that came with OSX preinstalled. It can also be downloaded from http://connect.apple.com (after you register for free ADC membership). - Tcl is built as a Mac OS X framework via the Makefile in tcl/macosx, but can but can also be built directly with the standard unix configure and make buildsystem in tcl/unix. - It is still possible to build with Apple's Xcode IDE using the Tcl.pbproj project but this is not recommended anymore (currently Tcl.pbproj calls through to the tcl/macosx/Makefile so there should be no build differences). - Unpack the tcl source release archive. - The following instructions assume the tcl source tree is named "tcl${ver}", where ${ver} is a shell variable containing the tcl version number (for example '8.4.2'). Setup the shell variable as follows: set ver="8.4.2" ;: if your shell is csh ver="8.4.2" ;: if your shell is sh The source tree will be named this way only if you are building from a release archive, if you are building from CVS, the version numbers will be missing; so set ${ver} to the empty string instead: set ver="" ;: if your shell is csh ver="" ;: if your shell is sh - The following steps will build Tcl from the Terminal, assuming you are located in the directory containing the tcl source tree: make -C tcl${ver}/macosx and the following will then install Tcl onto the root volume (admin password required): sudo make -C tcl${ver}/macosx install if you don't have the admin password, you can install into your home directory, instead by passing an INSTALL_ROOT argument to make: |
︙ | ︙ |
Added macosx/Tcl-Info.plist.in.
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | <?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> <plist version="1.0"> <dict> <key>CFBundleDevelopmentRegion</key> <string>English</string> <key>CFBundleExecutable</key> <string>@TCL_LIB_FILE@</string> <key>CFBundleGetInfoString</key> <string>Tcl Library @TCL_VERSION@, Copyright © @TCL_YEAR@ Tcl Core Team. Initial MacOS X Port by Jim Ingham <[email protected]> & Ian Reid, Copyright © 2001-2002, Apple Computer, Inc.</string> <key>CFBundleIdentifier</key> <string>com.tcltk.tcllibrary</string> <key>CFBundleInfoDictionaryVersion</key> <string>6.0</string> <key>CFBundleName</key> <string>Tcl Library @TCL_VERSION@</string> <key>CFBundlePackageType</key> <string>FMWK</string> <key>CFBundleShortVersionString</key> <string>@TCL_VERSION@@TCL_PATCH_LEVEL@</string> <key>CFBundleSignature</key> <string>Tcl </string> <key>CFBundleVersion</key> <string>@TCL_VERSION@@TCL_PATCH_LEVEL@</string> </dict> </plist> |
Changes to macosx/tclMacOSXBundle.c.
1 2 3 | /* * tclMacOSXBundle.c -- * | | | | | | | < | | | < | | | | | | < | | | | | < | | | | | | | | | | < | | | | | | | < > > > | < | | | | | | | | | | < | | | | > | | > | > > | > > | | > | > > | | | > > > | > | | > | > > | | | | | | > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 | /* * tclMacOSXBundle.c -- * * This file implements functions that inspect CFBundle structures on * MacOS X. * * Copyright 2001, Apple Computer, Inc. * * The following terms apply to all files originating from Apple * Computer, Inc. ("Apple") and associated with the software unless * explicitly disclaimed in individual files. * * Apple hereby grants permission to use, copy, modify, distribute, and * license this software and its documentation for any purpose, provided * that existing copyright notices are retained in all copies and that * this notice is included verbatim in any distributions. No written * agreement, license, or royalty fee is required for any of the * authorized uses. Modifications to this software may be copyrighted by * their authors and need not follow the licensing terms described here, * provided that the new terms are clearly indicated on the first page of * each file where they apply. * * IN NO EVENT SHALL APPLE, THE AUTHORS OR DISTRIBUTORS OF THE SOFTWARE * BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR * CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS * DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF APPLE OR THE * AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. APPLE, * THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND * NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND * APPLE,THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE * MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. * * GOVERNMENT USE: If you are acquiring this software on behalf of the * U.S. government, the Government shall have only "Restricted Rights" in * the software and related documentation as defined in the Federal * Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are * acquiring the software on behalf of the Department of Defense, the * software shall be classified as "Commercial Computer Software" and the * Government shall have only "Restricted Rights" as defined in Clause * 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the * authors grant the U.S. Government and others acting in its behalf * permission to use and distribute the software in accordance with the * terms specified in this license. */ #ifdef HAVE_COREFOUNDATION #include <CoreFoundation/CoreFoundation.h> #include <mach-o/dyld.h> #endif /* HAVE_COREFOUNDATION */ #include "tcl.h" /* *---------------------------------------------------------------------- * * Tcl_MacOSXOpenBundleResources -- * * Given the bundle name for a shared library, this routine sets * libraryPath to the Resources/Scripts directory in the framework * package. If hasResourceFile is true, it will also open the main * resource file for the bundle. * * Results: * TCL_OK if the bundle could be opened, and the Scripts folder found. * TCL_ERROR otherwise. * * Side effects: * libraryVariableName may be set, and the resource file opened. * *---------------------------------------------------------------------- */ int Tcl_MacOSXOpenBundleResources( Tcl_Interp *interp, CONST char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath) { return Tcl_MacOSXOpenVersionedBundleResources(interp, bundleName, NULL, hasResourceFile, maxPathLen, libraryPath); } /* *---------------------------------------------------------------------- * * Tcl_MacOSXOpenVersionedBundleResources -- * * Given the bundle and version name for a shared library (version name * can be NULL to indicate latest version), this routine sets libraryPath * to the Resources/Scripts directory in the framework package. If * hasResourceFile is true, it will also open the main resource file for * the bundle. * * Results: * TCL_OK if the bundle could be opened, and the Scripts folder found. * TCL_ERROR otherwise. * * Side effects: * libraryVariableName may be set, and the resource file opened. * *---------------------------------------------------------------------- */ int Tcl_MacOSXOpenVersionedBundleResources( Tcl_Interp *interp, CONST char *bundleName, CONST char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath) { #ifdef HAVE_COREFOUNDATION CFBundleRef bundleRef; CFStringRef bundleNameRef; CFURLRef libURL; libraryPath[0] = '\0'; bundleNameRef = CFStringCreateWithCString(NULL, bundleName, kCFStringEncodingUTF8); bundleRef = CFBundleGetBundleWithIdentifier(bundleNameRef); CFRelease(bundleNameRef); if (bundleVersion && bundleRef) { /* * Create bundle from bundleVersion subdirectory of 'Versions'. */ CFBundleRef versionedBundleRef = NULL; CFURLRef versionedBundleURL = NULL; CFStringRef bundleVersionRef = CFStringCreateWithCString(NULL, bundleVersion, kCFStringEncodingUTF8); CFURLRef bundleURL = CFBundleCopyBundleURL(bundleRef); if (bundleURL) { CFStringRef bundleTailRef = CFURLCopyLastPathComponent(bundleURL); if (bundleTailRef) { if (CFStringCompare(bundleTailRef, bundleVersionRef, 0) == kCFCompareEqualTo) { versionedBundleRef = bundleRef; } CFRelease(bundleTailRef); } } if (bundleURL && !versionedBundleRef) { CFURLRef versURL = CFURLCreateCopyAppendingPathComponent(NULL, bundleURL, CFSTR("Versions"), TRUE); if (versURL) { versionedBundleURL = CFURLCreateCopyAppendingPathComponent( NULL, versURL, bundleVersionRef, TRUE); CFRelease(versURL); } CFRelease(bundleURL); } CFRelease(bundleVersionRef); if (versionedBundleURL) { versionedBundleRef = CFBundleCreate(NULL, versionedBundleURL); CFRelease(versionedBundleURL); } bundleRef = versionedBundleRef; } if (bundleRef) { if (hasResourceFile) { /* * Dynamically acquire address for CFBundleOpenBundleResourceMap * symbol, since it is only present in full CoreFoundation on Mac * OS X and not in CFLite on pure Darwin. */ static int initialized = FALSE; static short (*openresourcemap)(CFBundleRef) = NULL; if (!initialized) { NSSymbol nsSymbol = NULL; if (NSIsSymbolNameDefinedWithHint( "_CFBundleOpenBundleResourceMap", "CoreFoundation")) { nsSymbol = NSLookupAndBindSymbolWithHint( "_CFBundleOpenBundleResourceMap","CoreFoundation"); if (nsSymbol) { openresourcemap = NSAddressOfSymbol(nsSymbol); } } initialized = TRUE; } if (openresourcemap) { short refNum; refNum = openresourcemap(bundleRef); } } libURL = CFBundleCopyResourceURL(bundleRef, CFSTR("Scripts"), NULL, NULL); if (libURL) { /* * FIXME: This is a quick fix, it is probably not right for * internationalization. */ CFURLGetFileSystemRepresentation(libURL, TRUE, (unsigned char*) libraryPath, maxPathLen); CFRelease(libURL); } } if (libraryPath[0]) { return TCL_OK; } else { return TCL_ERROR; } #else /* HAVE_COREFOUNDATION */ return TCL_ERROR; #endif /* HAVE_COREFOUNDATION */ } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to macosx/tclMacOSXFCmd.c.
1 2 3 | /* * tclMacOSXFCmd.c * | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | > > | | | | | | | | | | | | | | | | | | | | | | | | | < | > | < | | | | | | | < | | > > | > | | | | | | | | | | | | | | | | > | | | | > | | | | | | | > | > > | | | | | | | | | | | | | | | | | | | | | | > | > > | | | | | | | > | > > | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 | /* * tclMacOSXFCmd.c * * This file implements the MacOSX specific portion of file manipulation * subcommands of the "file" command. * * Copyright (c) 2003 Tcl Core Team. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclMacOSXFCmd.c,v 1.3.2.1 2005/08/02 18:16:16 dgp Exp $ */ #include "tclInt.h" #ifdef HAVE_GETATTRLIST #include <sys/attr.h> #include <sys/paths.h> #endif /* * Constants for file attributes subcommand. Need to be kept in sync with * tclUnixFCmd.c ! */ enum { UNIX_GROUP_ATTRIBUTE, UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE, #ifdef HAVE_CHFLAGS UNIX_READONLY_ATTRIBUTE, #endif #ifdef MAC_OSX_TCL MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE, MACOSX_RSRCLENGTH_ATTRIBUTE, #endif }; typedef u_int32_t OSType; static int Tcl_GetOSTypeFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, OSType *osTypePtr); static Tcl_Obj * Tcl_NewOSTypeStringObj(CONST OSType newOSType); enum { kFinfoIsInvisible = 0x4000, }; typedef struct fileinfobuf { u_int32_t info_length; union { struct { u_int32_t type; u_int32_t creator; u_int16_t fdFlags; u_int16_t location; u_int32_t padding[4]; } finder; off_t rsrcForkSize; } data __attribute__ ((packed)); } fileinfobuf; /* *---------------------------------------------------------------------- * * TclMacOSXGetFileAttribute * * Gets a MacOSX attribute of a file. Which attribute is controlled by * objIndex. The object will have ref count 0. * * Results: * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there * is no error. * * Side effects: * A new object is allocated. * *---------------------------------------------------------------------- */ int TclMacOSXGetFileAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { #ifdef HAVE_GETATTRLIST int result; Tcl_StatBuf statBuf; struct attrlist alist; fileinfobuf finfo; CONST char *native; result = TclpObjStat(fileName, &statBuf); if (result != 0) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } if (S_ISDIR(statBuf.st_mode) && objIndex != MACOSX_HIDDEN_ATTRIBUTE) { /* * Directories only support attribute "-hidden". */ errno = EISDIR; Tcl_AppendResult(interp, "invalid attribute: ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } memset(&alist, 0, sizeof(struct attrlist)); alist.bitmapcount = ATTR_BIT_MAP_COUNT; if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) { alist.fileattr = ATTR_FILE_RSRCLENGTH; } else { alist.commonattr = ATTR_CMN_FNDRINFO; } native = Tcl_FSGetNativePath(fileName); result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0); if (result != 0) { Tcl_AppendResult(interp, "could not read attributes of \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } switch (objIndex) { case MACOSX_CREATOR_ATTRIBUTE: *attributePtrPtr = Tcl_NewOSTypeStringObj(finfo.data.finder.creator); break; case MACOSX_TYPE_ATTRIBUTE: *attributePtrPtr = Tcl_NewOSTypeStringObj(finfo.data.finder.type); break; case MACOSX_HIDDEN_ATTRIBUTE: *attributePtrPtr = Tcl_NewBooleanObj( (finfo.data.finder.fdFlags & kFinfoIsInvisible) != 0); break; case MACOSX_RSRCLENGTH_ATTRIBUTE: *attributePtrPtr = Tcl_NewWideIntObj(finfo.data.rsrcForkSize); break; } return TCL_OK; #else Tcl_AppendResult(interp, "Mac OS X file attributes not supported", (char *) NULL); return TCL_ERROR; #endif } /* *--------------------------------------------------------------------------- * * TclMacOSXSetFileAttribute -- * * Sets a MacOSX attribute of a file. Which attribute is controlled by * objIndex. * * Results: * Standard TCL result. * * Side effects: * As above. * *--------------------------------------------------------------------------- */ int TclMacOSXSetFileAttribute(interp, objIndex, fileName, attributePtr) Tcl_Interp *interp; /* The interp for error reporting. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr; /* New owner for file. */ { #ifdef HAVE_GETATTRLIST int result; Tcl_StatBuf statBuf; struct attrlist alist; fileinfobuf finfo; CONST char *native; result = TclpObjStat(fileName, &statBuf); if (result != 0) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } if (S_ISDIR(statBuf.st_mode) && objIndex != MACOSX_HIDDEN_ATTRIBUTE) { /* * Directories only support attribute "-hidden". */ errno = EISDIR; Tcl_AppendResult(interp, "invalid attribute: ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } memset(&alist, 0, sizeof(struct attrlist)); alist.bitmapcount = ATTR_BIT_MAP_COUNT; if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) { alist.fileattr = ATTR_FILE_RSRCLENGTH; } else { alist.commonattr = ATTR_CMN_FNDRINFO; } native = Tcl_FSGetNativePath(fileName); result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0); if (result != 0) { Tcl_AppendResult(interp, "could not read attributes of \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } if (objIndex != MACOSX_RSRCLENGTH_ATTRIBUTE) { switch (objIndex) { case MACOSX_CREATOR_ATTRIBUTE: if (Tcl_GetOSTypeFromObj(interp, attributePtr, &finfo.data.finder.creator) != TCL_OK) { return TCL_ERROR; } break; case MACOSX_TYPE_ATTRIBUTE: if (Tcl_GetOSTypeFromObj(interp, attributePtr, &finfo.data.finder.type) != TCL_OK) { return TCL_ERROR; } break; case MACOSX_HIDDEN_ATTRIBUTE: { int hidden; if (Tcl_GetBooleanFromObj(interp,attributePtr,&hidden) != TCL_OK) { return TCL_ERROR; } if (hidden) { finfo.data.finder.fdFlags |= kFinfoIsInvisible; } else { finfo.data.finder.fdFlags &= ~kFinfoIsInvisible; } break; } } result = setattrlist(native, &alist, &finfo.data, sizeof(finfo.data), 0); if (result != 0) { Tcl_AppendResult(interp, "could not set attributes of \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } } else { off_t newRsrcForkSize; if (Tcl_GetWideIntFromObj(interp, attributePtr, &newRsrcForkSize) != TCL_OK) { return TCL_ERROR; } if (newRsrcForkSize != finfo.data.rsrcForkSize) { Tcl_DString ds; /* * Only setting rsrclength to 0 to strip a file's resource fork is * supported. */ if(newRsrcForkSize != 0) { Tcl_AppendResult(interp, "setting nonzero rsrclength not supported", (char *) NULL); return TCL_ERROR; } /* * Construct path to resource fork. */ Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, native, -1); Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, -1); result = truncate(Tcl_DStringValue(&ds), (off_t)0); Tcl_DStringFree(&ds); if (result != 0) { Tcl_AppendResult(interp, "could not truncate resource fork of \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } } } return TCL_OK; #else Tcl_AppendResult(interp, "Mac OS X file attributes not supported", (char *) NULL); return TCL_ERROR; #endif } /* *--------------------------------------------------------------------------- * * TclMacOSXCopyFileAttributes -- * * Copy the MacOSX attributes and resource fork (if present) from one * file to another. * * Results: * Standard Tcl result. * * Side effects: * MacOSX attributes and resource fork are updated in the new file to * reflect the old file. * *--------------------------------------------------------------------------- */ int TclMacOSXCopyFileAttributes(src, dst, statBufPtr) CONST char *src; /* Path name of source file (native). */ CONST char *dst; /* Path name of target file (native). */ CONST Tcl_StatBuf *statBufPtr; /* Stat info for source file */ { #ifdef HAVE_GETATTRLIST struct attrlist alist; fileinfobuf finfo; memset(&alist, 0, sizeof(struct attrlist)); alist.bitmapcount = ATTR_BIT_MAP_COUNT; alist.commonattr = ATTR_CMN_FNDRINFO; if (getattrlist(src, &alist, &finfo, sizeof(fileinfobuf), 0)) { return TCL_ERROR; } if (setattrlist(dst, &alist, &finfo.data, sizeof(finfo.data), 0)) { return TCL_ERROR; } if (!S_ISDIR(statBufPtr->st_mode)) { /* * Only copy non-empty resource fork. */ alist.commonattr = 0; alist.fileattr = ATTR_FILE_RSRCLENGTH; if (getattrlist(src, &alist, &finfo, sizeof(fileinfobuf), 0)) { return TCL_ERROR; } if(finfo.data.rsrcForkSize > 0) { int result; Tcl_DString ds_src, ds_dst; /* * Construct paths to resource forks. */ Tcl_DStringInit(&ds_src); Tcl_DStringAppend(&ds_src, src, -1); Tcl_DStringAppend(&ds_src, _PATH_RSRCFORKSPEC, -1); Tcl_DStringInit(&ds_dst); Tcl_DStringAppend(&ds_dst, dst, -1); Tcl_DStringAppend(&ds_dst, _PATH_RSRCFORKSPEC, -1); result = TclUnixCopyFile(Tcl_DStringValue(&ds_src), Tcl_DStringValue(&ds_dst), statBufPtr, 1); Tcl_DStringFree(&ds_src); Tcl_DStringFree(&ds_dst); if (result != 0) { return TCL_ERROR; } } } return TCL_OK; #else return TCL_ERROR; #endif } /* *---------------------------------------------------------------------- * * Tcl_GetOSTypeFromObj -- * * Attempt to return an OSType from the Tcl object "objPtr". * * Results: * Standard TCL result. If an error occurs during conversion, an error * message is left in interp->objResult. * * Side effects: * The string representation of objPtr will be updated if necessary. * *---------------------------------------------------------------------- */ static int Tcl_GetOSTypeFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get an OSType. */ OSType *osTypePtr) /* Place to store resulting OSType. */ { char *string; int length, result = TCL_OK; Tcl_DString ds; Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); string = Tcl_GetStringFromObj(objPtr, &length); Tcl_UtfToExternalDString(encoding, string, length, &ds); if (Tcl_DStringLength(&ds) > sizeof(OSType)) { Tcl_AppendResult(interp, "expected Macintosh OS type but got \"", string, "\": ", (char *) NULL); result = TCL_ERROR; } else { memset(osTypePtr, 0, sizeof(OSType)); memcpy(osTypePtr, Tcl_DStringValue(&ds), (size_t) Tcl_DStringLength(&ds)); } Tcl_DStringFree(&ds); Tcl_FreeEncoding(encoding); return result; } /* |
︙ | ︙ | |||
450 451 452 453 454 455 456 | Tcl_Obj *resultPtr; Tcl_DString ds; Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); memcpy(string, &newOSType, sizeof(OSType)); string[sizeof(OSType)] = '\0'; Tcl_ExternalToUtfDString(encoding, string, -1, &ds); | | > > > > > > > > > | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 | Tcl_Obj *resultPtr; Tcl_DString ds; Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); memcpy(string, &newOSType, sizeof(OSType)); string[sizeof(OSType)] = '\0'; Tcl_ExternalToUtfDString(encoding, string, -1, &ds); resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); Tcl_FreeEncoding(encoding); return resultPtr; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Added macosx/tclMacOSXNotify.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 | /* * tclMacOSXNotify.c -- * * This file contains the implementation of a merged CFRunLoop/select() * based notifier, which is the lowest-level part of the Tcl event loop. * This file works together with generic/tclNotify.c. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright 2001, Apple Computer, Inc. * Copyright 2005, Tcl Core Team. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclMacOSXNotify.c,v 1.3.2.3 2005/08/02 18:16:16 dgp Exp $ */ #ifdef HAVE_COREFOUNDATION /* Traditional unix select-based notifier is * in tclUnixNotfy.c */ #include "tclInt.h" #include <CoreFoundation/CoreFoundation.h> #include <pthread.h> extern TclStubs tclStubs; extern Tcl_NotifierProcs tclOriginalNotifier; /* * This structure is used to keep track of the notifier info for a registered * file. */ typedef struct FileHandler { int fd; int mask; /* Mask of desired events: TCL_READABLE, * etc. */ int readyMask; /* Mask of events that have been seen since * the last time file handlers were invoked * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ ClientData clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; /* * The following structure is what is added to the Tcl event queue when file * handlers are ready to fire. */ typedef struct FileHandlerEvent { Tcl_Event header; /* Information that is standard for all * events. */ int fd; /* File descriptor that is ready. Used to find * the FileHandler structure for the file * (can't point directly to the FileHandler * structure because it could go away while * the event is queued). */ } FileHandlerEvent; /* * The following structure contains a set of select() masks to track readable, * writable, and exceptional conditions. */ typedef struct SelectMasks { fd_set readable; fd_set writable; fd_set exceptional; } SelectMasks; /* * The following static structure contains the state information for the * select based implementation of the Tcl notifier. One of these structures is * created for each thread that is using the notifier. */ typedef struct ThreadSpecificData { FileHandler *firstFileHandlerPtr; /* Pointer to head of file handler list. */ SelectMasks checkMasks; /* This structure is used to build up the * masks to be used in the next call to * select. Bits are set in response to calls * to Tcl_CreateFileHandler. */ SelectMasks readyMasks; /* This array reflects the readable/writable * conditions that were found to exist by the * last call to select. */ int numFdBits; /* Number of valid bits in checkMasks (one * more than highest fd for which * Tcl_WatchFile has been called). */ int onList; /* True if it is in this list */ unsigned int pollState; /* pollState is used to implement a polling * handshake between each thread and the * notifier thread. Bits defined below. */ struct ThreadSpecificData *nextPtr, *prevPtr; /* All threads that are currently waiting on * an event have their ThreadSpecificData * structure on a doubly-linked listed formed * from these pointers. You must hold the * notifierLock before accessing these * fields. */ CFRunLoopSourceRef runLoopSource; /* Any other thread alerts a notifier that an * event is ready to be processed by signaling * this CFRunLoopSource. */ CFRunLoopRef runLoop; /* This thread's CFRunLoop, needs to be woken * up whenever the runLoopSource is * signaled. */ int eventReady; /* True if an event is ready to be * processed. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * The following static indicates the number of threads that have initialized * notifiers. * * You must hold the notifierInitLock before accessing this variable. */ static int notifierCount = 0; /* * The following variable points to the head of a doubly-linked list of * ThreadSpecificData structures for all threads that are currently waiting on * an event. * * You must hold the notifierLock before accessing this list. */ static ThreadSpecificData *waitingListPtr = NULL; /* * The notifier thread spends all its time in select() waiting for a file * descriptor associated with one of the threads on the waitingListPtr list to * do something interesting. But if the contents of the waitingListPtr list * ever changes, we need to wake up and restart the select() system call. You * can wake up the notifier thread by writing a single byte to the file * descriptor defined below. This file descriptor is the input-end of a pipe * and the notifier thread is listening for data on the output-end of the same * pipe. Hence writing to this file descriptor will cause the select() system * call to return and wake up the notifier thread. * * You must hold the notifierLock lock before writing to the pipe. */ static int triggerPipe = -1; static int receivePipe = -1; /* Output end of triggerPipe */ /* * We use Darwin-native spinlocks instead of pthread mutexes for notifier * locking: this radically simplifies the implementation and lowers overhead. * Note that these are not pure spinlocks, they employ various strategies to * back off, making them immune to most priority-inversion livelocks (c.f. man * 3 OSSpinLockLock). */ #if defined(HAVE_LIBKERN_OSATOMIC_H) && defined(HAVE_OSSPINLOCKLOCK) /* * Use OSSpinLock API where available (Tiger or later). */ #include <libkern/OSAtomic.h> #else /* * Otherwise, use commpage spinlock SPI directly. */ typedef uint32_t OSSpinLock; extern void _spin_lock(OSSpinLock *lock); extern void _spin_unlock(OSSpinLock *lock); #define OSSpinLockLock(p) _spin_lock(p) #define OSSpinLockUnlock(p) _spin_unlock(p) #endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */ /* * These spinlocks lock access to the global notifier state. */ static OSSpinLock notifierInitLock = 0; static OSSpinLock notifierLock = 0; /* * Macros abstracting notifier locking/unlocking */ #define LOCK_NOTIFIER_INIT OSSpinLockLock(¬ifierInitLock) #define UNLOCK_NOTIFIER_INIT OSSpinLockUnlock(¬ifierInitLock) #define LOCK_NOTIFIER OSSpinLockLock(¬ifierLock) #define UNLOCK_NOTIFIER OSSpinLockUnlock(¬ifierLock) /* * The pollState bits * POLL_WANT is set by each thread before it waits on its condition * variable. It is checked by the notifier before it does select. * POLL_DONE is set by the notifier if it goes into select after seeing * POLL_WANT. The idea is to ensure it tries a select with the * same bits the initial thread had set. */ #define POLL_WANT 0x1 #define POLL_DONE 0x2 /* * This is the thread ID of the notifier thread that does select. */ static pthread_t notifierThread; /* * Static routines defined in this file. */ static void NotifierThreadProc(ClientData clientData); static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); /* *---------------------------------------------------------------------- * * Tcl_InitNotifier -- * * Initializes the platform specific notifier state. * * Results: * Returns a handle to the notifier state for this thread.. * * Side effects: * None. * *---------------------------------------------------------------------- */ ClientData Tcl_InitNotifier() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->eventReady = 0; /* * Initialize CFRunLoopSource and add it to CFRunLoop of this thread */ if (!tsdPtr->runLoop) { CFRunLoopRef runLoop = CFRunLoopGetCurrent(); CFRunLoopSourceRef runLoopSource; CFRunLoopSourceContext runLoopSourceContext; bzero(&runLoopSourceContext, sizeof(CFRunLoopSourceContext)); runLoopSourceContext.info = tsdPtr; runLoopSource = CFRunLoopSourceCreate(NULL, 0, &runLoopSourceContext); if (!runLoopSource) { Tcl_Panic("Tcl_InitNotifier: could not create CFRunLoopSource."); } CFRunLoopAddSource(runLoop, runLoopSource, kCFRunLoopCommonModes); tsdPtr->runLoopSource = runLoopSource; tsdPtr->runLoop = runLoop; } /* * Initialize trigger pipe and start the Notifier thread if necessary. */ LOCK_NOTIFIER_INIT; if (notifierCount == 0) { int fds[2], status, result; pthread_attr_t attr; if (pipe(fds) != 0) { Tcl_Panic("Tcl_InitNotifier: could not create trigger pipe."); } status = fcntl(fds[0], F_GETFL); status |= O_NONBLOCK; if (fcntl(fds[0], F_SETFL, status) < 0) { Tcl_Panic("Tcl_InitNotifier: could not make receive pipe non blocking."); } status = fcntl(fds[1], F_GETFL); status |= O_NONBLOCK; if (fcntl(fds[1], F_SETFL, status) < 0) { Tcl_Panic("Tcl_InitNotifier: could not make trigger pipe non blocking."); } receivePipe = fds[0]; triggerPipe = fds[1]; pthread_attr_init(&attr); pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE); pthread_attr_setstacksize(&attr, 60 * 1024); result = pthread_create(¬ifierThread, &attr, (void * (*)(void *))NotifierThreadProc, NULL); pthread_attr_destroy(&attr); if (result) { Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread."); } } notifierCount++; UNLOCK_NOTIFIER_INIT; return (ClientData) tsdPtr; } /* *---------------------------------------------------------------------- * * Tcl_FinalizeNotifier -- * * This function is called to cleanup the notifier state before a thread * is terminated. * * Results: * None. * * Side effects: * May terminate the background notifier thread if this is the last * notifier instance. * *---------------------------------------------------------------------- */ void Tcl_FinalizeNotifier(clientData) ClientData clientData; /* Not used. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); LOCK_NOTIFIER_INIT; notifierCount--; /* * If this is the last thread to use the notifier, close the notifier pipe * and wait for the background thread to terminate. */ if (notifierCount == 0) { int result; if (triggerPipe < 0) { Tcl_Panic("Tcl_FinalizeNotifier: notifier pipe not initialized."); } /* * Send "q" message to the notifier thread so that it will terminate. * The notifier will return from its call to select() and notice that * a "q" message has arrived, it will then close its side of the pipe * and terminate its thread. Note the we can not just close the pipe * and check for EOF in the notifier thread because if a background * child process was created with exec, select() would not register * the EOF on the pipe until the child processes had terminated. [Bug: * 4139] */ write(triggerPipe, "q", 1); close(triggerPipe); result = pthread_join(notifierThread, NULL); if (result) { Tcl_Panic("Tcl_FinalizeNotifier: unable to join notifier thread."); } close(receivePipe); triggerPipe = -1; } UNLOCK_NOTIFIER_INIT; LOCK_NOTIFIER; /* for concurrency with Tcl_AlertNotifier */ if (tsdPtr->runLoop) { tsdPtr->runLoop = NULL; /* * Remove runLoopSource from all CFRunLoops and release it. */ CFRunLoopSourceInvalidate(tsdPtr->runLoopSource); CFRelease(tsdPtr->runLoopSource); tsdPtr->runLoopSource = NULL; } UNLOCK_NOTIFIER; } /* *---------------------------------------------------------------------- * * Tcl_AlertNotifier -- * * Wake up the specified notifier from any thread. This routine is called * by the platform independent notifier code whenever the Tcl_ThreadAlert * routine is called. This routine is guaranteed not to be called on a * given notifier after Tcl_FinalizeNotifier is called for that notifier. * * Results: * None. * * Side effects: * Signals the notifier condition variable for the specified notifier. * *---------------------------------------------------------------------- */ void Tcl_AlertNotifier(clientData) ClientData clientData; { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; LOCK_NOTIFIER; if (tsdPtr->runLoop) { tsdPtr->eventReady = 1; CFRunLoopSourceSignal(tsdPtr->runLoopSource); CFRunLoopWakeUp(tsdPtr->runLoop); } UNLOCK_NOTIFIER; } /* *---------------------------------------------------------------------- * * Tcl_SetTimer -- * * This function sets the current notifier timer value. This interface is * not implemented in this notifier because we are always running inside * of Tcl_DoOneEvent. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_SetTimer(timePtr) Tcl_Time *timePtr; /* Timeout value, may be NULL. */ { /* * The interval timer doesn't do anything in this implementation, because * the only event loop is via Tcl_DoOneEvent, which passes timeout values * to Tcl_WaitForEvent. */ if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) { tclStubs.tcl_SetTimer(timePtr); } } /* *---------------------------------------------------------------------- * * Tcl_ServiceModeHook -- * * This function is invoked whenever the service mode changes. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_ServiceModeHook(mode) int mode; /* Either TCL_SERVICE_ALL, or * TCL_SERVICE_NONE. */ { } /* *---------------------------------------------------------------------- * * Tcl_CreateFileHandler -- * * This function registers a file handler with the select notifier. * * Results: * None. * * Side effects: * Creates a new file handler structure. * *---------------------------------------------------------------------- */ void Tcl_CreateFileHandler(fd, mask, proc, clientData) int fd; /* Handle of stream to watch. */ int mask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc; /* Function to call for each * selected event. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr; if (tclStubs.tcl_CreateFileHandler != tclOriginalNotifier.createFileHandlerProc) { tclStubs.tcl_CreateFileHandler(fd, mask, proc, clientData); return; } for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; filePtr = filePtr->nextPtr) { if (filePtr->fd == fd) { break; } } if (filePtr == NULL) { filePtr = (FileHandler*) ckalloc(sizeof(FileHandler)); filePtr->fd = fd; filePtr->readyMask = 0; filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; tsdPtr->firstFileHandlerPtr = filePtr; } filePtr->proc = proc; filePtr->clientData = clientData; filePtr->mask = mask; /* * Update the check masks for this file. */ if (mask & TCL_READABLE) { FD_SET(fd, &(tsdPtr->checkMasks.readable)); } else { FD_CLR(fd, &(tsdPtr->checkMasks.readable)); } if (mask & TCL_WRITABLE) { FD_SET(fd, &(tsdPtr->checkMasks.writable)); } else { FD_CLR(fd, &(tsdPtr->checkMasks.writable)); } if (mask & TCL_EXCEPTION) { FD_SET(fd, &(tsdPtr->checkMasks.exceptional)); } else { FD_CLR(fd, &(tsdPtr->checkMasks.exceptional)); } if (tsdPtr->numFdBits <= fd) { tsdPtr->numFdBits = fd+1; } } /* *---------------------------------------------------------------------- * * Tcl_DeleteFileHandler -- * * Cancel a previously-arranged callback arrangement for a file. * * Results: * None. * * Side effects: * If a callback was previously registered on file, remove it. * *---------------------------------------------------------------------- */ void Tcl_DeleteFileHandler(fd) int fd; /* Stream id for which to remove callback * function. */ { FileHandler *filePtr, *prevPtr; int i; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tclStubs.tcl_DeleteFileHandler != tclOriginalNotifier.deleteFileHandlerProc) { tclStubs.tcl_DeleteFileHandler(fd); return; } /* * Find the entry for the given file (and return if there isn't one). */ for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; prevPtr = filePtr, filePtr = filePtr->nextPtr) { if (filePtr == NULL) { return; } if (filePtr->fd == fd) { break; } } /* * Update the check masks for this file. */ if (filePtr->mask & TCL_READABLE) { FD_CLR(fd, &(tsdPtr->checkMasks.readable)); } if (filePtr->mask & TCL_WRITABLE) { FD_CLR(fd, &(tsdPtr->checkMasks.writable)); } if (filePtr->mask & TCL_EXCEPTION) { FD_CLR(fd, &(tsdPtr->checkMasks.exceptional)); } /* * Find current max fd. */ if (fd+1 == tsdPtr->numFdBits) { tsdPtr->numFdBits = 0; for (i = fd-1; i >= 0; i--) { if (FD_ISSET(i, &(tsdPtr->checkMasks.readable)) || FD_ISSET(i, &(tsdPtr->checkMasks.writable)) || FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) { tsdPtr->numFdBits = i+1; break; } } } /* * Clean up information in the callback record. */ if (prevPtr == NULL) { tsdPtr->firstFileHandlerPtr = filePtr->nextPtr; } else { prevPtr->nextPtr = filePtr->nextPtr; } ckfree((char *) filePtr); } /* *---------------------------------------------------------------------- * * FileHandlerEventProc -- * * This function is called by Tcl_ServiceEvent when a file event reaches * the front of the event queue. This function is responsible for * actually handling the event by invoking the callback for the file * handler. * * Results: * Returns 1 if the event was handled, meaning it should be removed from * the queue. Returns 0 if the event was not handled, meaning it should * stay on the queue. The only time the event isn't handled is if the * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the file handler's callback function does. * *---------------------------------------------------------------------- */ static int FileHandlerEventProc(evPtr, flags) Tcl_Event *evPtr; /* Event to service. */ int flags; /* Flags that indicate what events to handle, * such as TCL_FILE_EVENTS. */ { int mask; FileHandler *filePtr; FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; ThreadSpecificData *tsdPtr; if (!(flags & TCL_FILE_EVENTS)) { return 0; } /* * Search through the file handlers to find the one whose handle matches * the event. We do this rather than keeping a pointer to the file handler * directly in the event, so that the handler can be deleted while the * event is queued without leaving a dangling pointer. */ tsdPtr = TCL_TSD_INIT(&dataKey); for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; filePtr = filePtr->nextPtr) { if (filePtr->fd != fileEvPtr->fd) { continue; } /* * The code is tricky for two reasons: * 1. The file handler's desired events could have changed since the * time when the event was queued, so AND the ready mask with the * desired mask. * 2. The file could have been closed and re-opened since the time * when the event was queued. This is why the ready mask is stored * in the file handler rather than the queued event: it will be * zeroed when a new file handler is created for the newly opened * file. */ mask = filePtr->readyMask & filePtr->mask; filePtr->readyMask = 0; if (mask != 0) { (*filePtr->proc)(filePtr->clientData, mask); } break; } return 1; } /* *---------------------------------------------------------------------- * * Tcl_WaitForEvent -- * * This function is called by Tcl_DoOneEvent to wait for new events on * the message queue. If the block time is 0, then Tcl_WaitForEvent just * polls without blocking. * * Results: * Returns -1 if the select would block forever, otherwise returns 0. * * Side effects: * Queues file events that are detected by the select. * *---------------------------------------------------------------------- */ int Tcl_WaitForEvent(timePtr) Tcl_Time *timePtr; /* Maximum block time, or NULL. */ { FileHandler *filePtr; FileHandlerEvent *fileEvPtr; int mask; Tcl_Time myTime; int waitForFiles; Tcl_Time *myTimePtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) { return tclStubs.tcl_WaitForEvent(timePtr); } if (timePtr != NULL) { /* * TIP #233 (Virtualized Time). Is virtual time in effect? And do we * actually have something to scale? If yes to both then we call the * handler to do this scaling. */ myTime.sec = timePtr->sec; myTime.usec = timePtr->usec; if (myTime.sec != 0 || myTime.usec != 0) { (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData); } myTimePtr = &myTime; } else { myTimePtr = NULL; } /* * Place this thread on the list of interested threads, signal the * notifier thread, and wait for a response or a timeout. */ LOCK_NOTIFIER; waitForFiles = (tsdPtr->numFdBits > 0); if (myTimePtr != NULL && myTimePtr->sec == 0 && myTimePtr->usec == 0) { /* * Cannot emulate a polling select with a polling condition variable. * Instead, pretend to wait for files and tell the notifier thread * what we are doing. The notifier thread makes sure it goes through * select with its select mask in the same state as ours currently is. * We block until that happens. */ waitForFiles = 1; tsdPtr->pollState = POLL_WANT; myTimePtr = NULL; } else { tsdPtr->pollState = 0; } if (waitForFiles) { /* * Add the ThreadSpecificData structure of this thread to the list of * ThreadSpecificData structures of all threads that are waiting on * file events. */ tsdPtr->nextPtr = waitingListPtr; if (waitingListPtr) { waitingListPtr->prevPtr = tsdPtr; } tsdPtr->prevPtr = 0; waitingListPtr = tsdPtr; tsdPtr->onList = 1; write(triggerPipe, "", 1); } FD_ZERO(&(tsdPtr->readyMasks.readable)); FD_ZERO(&(tsdPtr->readyMasks.writable)); FD_ZERO(&(tsdPtr->readyMasks.exceptional)); if (!tsdPtr->eventReady) { CFTimeInterval waitTime; if (myTimePtr == NULL) { waitTime = 1.0e10; /* Wait forever, as per CFRunLoop.c */ } else { waitTime = myTimePtr->sec + 1.0e-6 * myTimePtr->usec; } UNLOCK_NOTIFIER; CFRunLoopRunInMode(kCFRunLoopDefaultMode, waitTime, TRUE); LOCK_NOTIFIER; } tsdPtr->eventReady = 0; if (waitForFiles && tsdPtr->onList) { /* * Remove the ThreadSpecificData structure of this thread from the * waiting list. Alert the notifier thread to recompute its select * masks - skipping this caused a hang when trying to close a pipe * which the notifier thread was still doing a select on. */ if (tsdPtr->prevPtr) { tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; } else { waitingListPtr = tsdPtr->nextPtr; } if (tsdPtr->nextPtr) { tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; } tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; tsdPtr->onList = 0; write(triggerPipe, "", 1); } /* * Queue all detected file events before returning. */ for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL); filePtr = filePtr->nextPtr) { mask = 0; if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.readable))) { mask |= TCL_READABLE; } if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.writable))) { mask |= TCL_WRITABLE; } if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.exceptional))) { mask |= TCL_EXCEPTION; } if (!mask) { continue; } /* * Don't bother to queue an event if the mask was previously non-zero * since an event must still be on the queue. */ if (filePtr->readyMask == 0) { fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); } filePtr->readyMask = mask; } UNLOCK_NOTIFIER; return 0; } /* *---------------------------------------------------------------------- * * NotifierThreadProc -- * * This routine is the initial (and only) function executed by the * special notifier thread. Its job is to wait for file descriptors to * become readable or writable or to have an exception condition and then * to notify other threads who are interested in this information by * signalling a condition variable. Other threads can signal this * notifier thread of a change in their interests by writing a single * byte to a special pipe that the notifier thread is monitoring. * * Result: * None. Once started, this routine never exits. It dies with the overall * process. * * Side effects: * The trigger pipe used to signal the notifier thread is created when * the notifier thread first starts. * *---------------------------------------------------------------------- */ static void NotifierThreadProc(clientData) ClientData clientData; /* Not used. */ { ThreadSpecificData *tsdPtr; fd_set readableMask; fd_set writableMask; fd_set exceptionalMask; int i, numFdBits = 0; long found; struct timeval poll = {0., 0.}, *timePtr; char buf[2]; /* * Look for file events and report them to interested threads. */ while (1) { FD_ZERO(&readableMask); FD_ZERO(&writableMask); FD_ZERO(&exceptionalMask); /* * Compute the logical OR of the select masks from all the waiting * notifiers. */ LOCK_NOTIFIER; timePtr = NULL; for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { for (i = tsdPtr->numFdBits-1; i >= 0; --i) { if (FD_ISSET(i, &(tsdPtr->checkMasks.readable))) { FD_SET(i, &readableMask); } if (FD_ISSET(i, &(tsdPtr->checkMasks.writable))) { FD_SET(i, &writableMask); } if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) { FD_SET(i, &exceptionalMask); } } if (tsdPtr->numFdBits > numFdBits) { numFdBits = tsdPtr->numFdBits; } if (tsdPtr->pollState & POLL_WANT) { /* * Here we make sure we go through select() with the same mask * bits that were present when the thread tried to poll. */ tsdPtr->pollState |= POLL_DONE; timePtr = &poll; } } UNLOCK_NOTIFIER; /* * Set up the select mask to include the receive pipe. */ if (receivePipe >= numFdBits) { numFdBits = receivePipe + 1; } FD_SET(receivePipe, &readableMask); if (select(numFdBits, &readableMask, &writableMask, &exceptionalMask, timePtr) == -1) { /* * Try again immediately on an error. */ continue; } /* * Alert any threads that are waiting on a ready file descriptor. */ LOCK_NOTIFIER; for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { found = 0; for (i = tsdPtr->numFdBits-1; i >= 0; --i) { if (FD_ISSET(i, &(tsdPtr->checkMasks.readable)) && FD_ISSET(i, &readableMask)) { FD_SET(i, &(tsdPtr->readyMasks.readable)); found = 1; } if (FD_ISSET(i, &(tsdPtr->checkMasks.writable)) && FD_ISSET(i, &writableMask)) { FD_SET(i, &(tsdPtr->readyMasks.writable)); found = 1; } if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional)) && FD_ISSET(i, &exceptionalMask)) { FD_SET(i, &(tsdPtr->readyMasks.exceptional)); found = 1; } } if (found || (tsdPtr->pollState & POLL_DONE)) { tsdPtr->eventReady = 1; if (tsdPtr->onList) { /* * Remove the ThreadSpecificData structure of this thread * from the waiting list. This prevents us from * continuously spining on select until the other threads * runs and services the file event. */ if (tsdPtr->prevPtr) { tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; } else { waitingListPtr = tsdPtr->nextPtr; } if (tsdPtr->nextPtr) { tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; } tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; tsdPtr->onList = 0; tsdPtr->pollState = 0; } if (tsdPtr->runLoop) { CFRunLoopSourceSignal(tsdPtr->runLoopSource); CFRunLoopWakeUp(tsdPtr->runLoop); } } } UNLOCK_NOTIFIER; /* * Consume the next byte from the notifier pipe if the pipe was * readable. Note that there may be multiple bytes pending, but to * avoid a race condition we only read one at a time. */ if (FD_ISSET(receivePipe, &readableMask)) { i = read(receivePipe, buf, 1); if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) { /* * Someone closed the write end of the pipe or sent us a Quit * message [Bug: 4139] and then closed the write end of the * pipe so we need to shut down the notifier thread. */ break; } } } pthread_exit (0); } #endif /* HAVE_COREFOUNDATION */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to tests/appendComp.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: append lappend # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Commands covered: append lappend # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: appendComp.test,v 1.7.2.1 2005/05/05 17:56:14 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } catch {unset x} |
︙ | ︙ | |||
347 348 349 350 351 352 353 | proc foo {args} {append ::result $args} append myvar a info exists ::result } bar } {0} | | | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 | proc foo {args} {append ::result $args} append myvar a info exists ::result } bar } {0} test appendComp-8.1 {defer error to runtime} -setup { interp create slave } -body { slave eval { proc foo {} { proc append args {} append } |
︙ | ︙ |
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 | # # 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.36.2.2 2005/04/10 23:14:58 kennykb Exp $ # package require tcltest 2 namespace import -force ::tcltest::* testConstraint testevalex [llength [info commands testevalex]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] |
︙ | ︙ | |||
433 434 435 436 437 438 439 440 441 442 443 444 445 446 | close $f set x } -cleanup { removeFile test1 interp bgerror {} $handler rename myHandler {} } -result "foo\n while executing\n\"error foo\"" test basic-27.1 {Tcl_ExprLong} {emptyTest} { } {} test basic-28.1 {Tcl_ExprDouble} {emptyTest} { } {} | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | close $f set x } -cleanup { removeFile test1 interp bgerror {} $handler rename myHandler {} } -result "foo\n while executing\n\"error foo\"" test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} { # # Follow the pure-list branch in a manner that # a - the pure-list internal rep is destroyed by shimmering # b - the command returns an error # As the error code in Tcl_EvalObjv accesses the list elements, this will # cause a segfault if [Bug 1119369] has not been fixed. # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. # set SRC [list foo 1] ;# pure-list command proc foo str { # Shimmer pure-list to cmdName, cleanup and error proc $::SRC {} {}; $::SRC error "BAD CALL" } catch {eval $SRC} } 1 test basic-26.3 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} { # # Follow the pure-list branch in a manner that # a - the pure-list internal rep is destroyed by shimmering # b - the command accesses its command line # This will cause a segfault if [Bug 1119369] has not been fixed. # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. # set SRC [list foo 1] ;# pure-list command proc foo str { # Shimmer pure-list to cmdName, cleanup and error proc $::SRC {} {}; $::SRC info level 0 } catch {eval $SRC} } 0 test basic-27.1 {Tcl_ExprLong} {emptyTest} { } {} test basic-28.1 {Tcl_ExprDouble} {emptyTest} { } {} |
︙ | ︙ | |||
563 564 565 566 567 568 569 | } -constraints { exec } -body { exec [interpreter] $fName } -cleanup { removeFile BREAKtest } -returnCodes error -match glob -result {invoked "break" outside of a loop | | < < | 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 | } -constraints { exec } -body { exec [interpreter] $fName } -cleanup { removeFile BREAKtest } -returnCodes error -match glob -result {invoked "break" outside of a loop while executing* "foo \[set a 1] \[break]" (file "*BREAKtest" line 2)} test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup { set fName [makeFile { return -code return } BREAKtest] |
︙ | ︙ |
Changes to tests/binary.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the tclBinary.c file and the "binary" Tcl command. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # This file tests the tclBinary.c file and the "binary" Tcl command. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: binary.test,v 1.18.2.10 2005/10/08 13:44:38 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } ::tcltest::testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] ::tcltest::testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}] |
︙ | ︙ | |||
509 510 511 512 513 514 515 | } \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 test binary-14.10 {Tcl_BinaryObjCmd: format} bigEndian { binary format d2 {1.6 3.4 5.6} } \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 test binary-14.11 {Tcl_BinaryObjCmd: format} littleEndian { binary format d2 {1.6 3.4 5.6} } \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 | < < < > > > > | 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 | } \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 test binary-14.10 {Tcl_BinaryObjCmd: format} bigEndian { binary format d2 {1.6 3.4 5.6} } \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 test binary-14.11 {Tcl_BinaryObjCmd: format} littleEndian { binary format d2 {1.6 3.4 5.6} } \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 test binary-14.14 {Tcl_BinaryObjCmd: format} { list [catch {binary format d2 {1.6}} msg] $msg } {1 {number of elements in list does not match count}} test binary-14.15 {Tcl_BinaryObjCmd: format} { set a {1.6 3.4} list [catch {binary format d $a} msg] $msg } [list 1 "expected floating-point number but got \"1.6 3.4\""] test binary-14.16 {Tcl_BinaryObjCmd: format} bigEndian { set a {1.6 3.4} binary format d1 $a } \x3f\xf9\x99\x99\x99\x99\x99\x9a test binary-14.17 {Tcl_BinaryObjCmd: format} littleEndian { set a {1.6 3.4} binary format d1 $a } \x9a\x99\x99\x99\x99\x99\xf9\x3f test binary-14.18 {FormatNumber: Bug 1116542} { binary scan [binary format d 1.25] d w set w } 1.25 test binary-15.1 {Tcl_BinaryObjCmd: format} { list [catch {binary format ax*a "y" "z"} msg] $msg } {1 {cannot use "*" in format string with "x"}} test binary-15.2 {Tcl_BinaryObjCmd: format} { binary format axa "y" "z" } y\x00z |
︙ | ︙ | |||
1067 1068 1069 1070 1071 1072 1073 | test binary-31.1 {Tcl_BinaryObjCmd: scan} { list [catch {binary scan abc f} msg] $msg } {1 {not enough arguments for all format specifiers}} test binary-31.2 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1 | | | | | | | | | | | | 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 | test binary-31.1 {Tcl_BinaryObjCmd: scan} { list [catch {binary scan abc f} msg] $msg } {1 {not enough arguments for all format specifiers}} test binary-31.2 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.3 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.4 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f arg1] $arg1 } {1 1.600000023841858} test binary-31.5 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f arg1] $arg1 } {1 1.600000023841858} test binary-31.6 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd f1 arg1] $arg1 } {1 1.600000023841858} test binary-31.7 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f f1 arg1] $arg1 } {1 1.600000023841858} test binary-31.8 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1 } {1 {}} test binary-31.9 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f f0 arg1] $arg1 } {1 {}} test binary-31.10 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.11 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.12 {Tcl_BinaryObjCmd: scan} { catch {unset arg1} set arg1 foo list [binary scan \x52 f1 arg1] $arg1 } {0 foo} test binary-31.13 {Tcl_BinaryObjCmd: scan} { catch {unset arg1} set arg1 1 list [catch {binary scan \x3f\xcc\xcc\xcd f1 arg1(a)} msg] $msg } {1 {can't set "arg1(a)": variable isn't array}} test binary-31.14 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1 arg2} set arg1 foo set arg2 bar list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 f2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-31.15 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1 arg2} set arg1 foo set arg2 bar list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-32.1 {Tcl_BinaryObjCmd: scan} { list [catch {binary scan abc d} msg] $msg } {1 {not enough arguments for all format specifiers}} test binary-32.2 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d* arg1] $arg1 |
︙ | ︙ | |||
1380 1381 1382 1383 1384 1385 1386 | list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 i5 arg1] $arg1 } {1 {33620225 16843137 16876033 25297153 -2130640639}} test binary-39.5 {ScanNumber: sign extension} { catch {unset arg1} list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1 } {1 {16843010 -2130640639 25297153 16876033 16843137}} | < < < < | > | | < < | > | | < | > | | | < | < < | < < < < | | | 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 | list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 i5 arg1] $arg1 } {1 {33620225 16843137 16876033 25297153 -2130640639}} test binary-39.5 {ScanNumber: sign extension} { catch {unset arg1} list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1 } {1 {16843010 -2130640639 25297153 16876033 16843137}} test binary-40.3 {ScanNumber: NaN} \ -body { catch {unset arg1} list [binary scan \xff\xff\xff\xff f1 arg1] $arg1 } \ -match glob \ -result {1 -NaN*} test binary-40.4 {ScanNumber: NaN} \ -body { catch {unset arg1} list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1 } \ -match glob \ -result {1 -NaN*} test binary-41.1 {ScanNumber: word alignment} { catch {unset arg1; unset arg2} list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2 } {2 1 1} test binary-41.2 {ScanNumber: word alignment} { catch {unset arg1; unset arg2} list [binary scan \x01\x00\x01 c1S1 arg1 arg2] $arg1 $arg2 } {2 1 1} test binary-41.3 {ScanNumber: word alignment} { catch {unset arg1; unset arg2} list [binary scan \x01\x01\x00\x00\x00 c1i1 arg1 arg2] $arg1 $arg2 } {2 1 1} test binary-41.4 {ScanNumber: word alignment} { catch {unset arg1; unset arg2} list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2 } {2 1 1} test binary-41.5 {ScanNumber: word alignment} bigEndian { catch {unset arg1; unset arg2} list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2 } {2 1 1.600000023841858} test binary-41.6 {ScanNumber: word alignment} littleEndian { catch {unset arg1; unset arg2} list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2 } {2 1 1.600000023841858} test binary-41.7 {ScanNumber: word alignment} bigEndian { catch {unset arg1; unset arg2} list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2 } {2 1 1.6} test binary-41.8 {ScanNumber: word alignment} littleEndian { catch {unset arg1; unset arg2} list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2 |
︙ | ︙ | |||
1688 1689 1690 1691 1692 1693 1694 | } \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 test binary-51.10 {Tcl_BinaryObjCmd: format} {} { binary format Q2 {1.6 3.4 5.6} } \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 test binary-51.11 {Tcl_BinaryObjCmd: format} {} { binary format q2 {1.6 3.4 5.6} } \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 | < < < < < < | 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 | } \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 test binary-51.10 {Tcl_BinaryObjCmd: format} {} { binary format Q2 {1.6 3.4 5.6} } \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 test binary-51.11 {Tcl_BinaryObjCmd: format} {} { binary format q2 {1.6 3.4 5.6} } \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 test binary-51.14 {Tcl_BinaryObjCmd: format} { list [catch {binary format q2 {1.6}} msg] $msg } {1 {number of elements in list does not match count}} test binary-51.15 {Tcl_BinaryObjCmd: format} { set a {1.6 3.4} list [catch {binary format q $a} msg] $msg } [list 1 "expected floating-point number but got \"1.6 3.4\""] |
︙ | ︙ | |||
1935 1936 1937 1938 1939 1940 1941 | } {1 {can't set "arg1(a)": variable isn't array}} test binary-57.9 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1 arg2} set arg1 foo set arg2 bar list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2 } {2 {1386435412 16909060} 5} | < < < < < < < < < < < < < < < < < < < | 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 | } {1 {can't set "arg1(a)": variable isn't array}} test binary-57.9 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1 arg2} set arg1 foo set arg2 bar list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2 } {2 {1386435412 16909060} 5} # scan Q/q test binary-58.1 {Tcl_BinaryObjCmd: scan} { list [catch {binary scan abc q} msg] $msg } {1 {not enough arguments for all format specifiers}} test binary-58.2 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} |
︙ | ︙ | |||
2029 2030 2031 2032 2033 2034 2035 | # scan R/r test binary-59.1 {Tcl_BinaryObjCmd: scan} { list [catch {binary scan abc r} msg] $msg } {1 {not enough arguments for all format specifiers}} test binary-59.2 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R* arg1] $arg1 | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # scan R/r test binary-59.1 {Tcl_BinaryObjCmd: scan} { list [catch {binary scan abc r} msg] $msg } {1 {not enough arguments for all format specifiers}} test binary-59.2 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.3 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.4 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R arg1] $arg1 } {1 1.600000023841858} test binary-59.5 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r arg1] $arg1 } {1 1.600000023841858} test binary-59.6 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd R1 arg1] $arg1 } {1 1.600000023841858} test binary-59.7 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f r1 arg1] $arg1 } {1 1.600000023841858} test binary-59.8 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd R0 arg1] $arg1 } {1 {}} test binary-59.9 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f r0 arg1] $arg1 } {1 {}} test binary-59.10 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1} list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.11 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1} list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.12 {Tcl_BinaryObjCmd: scan} { catch {unset arg1} set arg1 foo list [binary scan \x52 r1 arg1] $arg1 } {0 foo} test binary-59.13 {Tcl_BinaryObjCmd: scan} { catch {unset arg1} set arg1 1 list [catch {binary scan \x3f\xcc\xcc\xcd r1 arg1(a)} msg] $msg } {1 {can't set "arg1(a)": variable isn't array}} test binary-59.14 {Tcl_BinaryObjCmd: scan} bigEndian { catch {unset arg1 arg2} set arg1 foo set arg2 bar list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 R2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-59.15 {Tcl_BinaryObjCmd: scan} littleEndian { catch {unset arg1 arg2} set arg1 foo set arg2 bar list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 r2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-60.1 {[binary format] with NaN} -body { binary scan [binary format dqQfrR NaN NaN NaN NaN NaN NaN] dqQfrR \ v1 v2 v3 v4 v5 v6 list $v1 $v2 $v3 $v4 $v5 $v6 } -match regexp -result {NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))?} # scan m test binary-61.1 {Tcl_BinaryObjCmd: scan wide int} bigEndian { binary scan HelloTcl m x set x } 5216694956358656876 test binary-61.2 {Tcl_BinaryObjCmd: scan wide int} littleEndian { binary scan lcTolleH m x set x } 5216694956358656876 test binary-61.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} littleEndian { binary scan [binary format w [expr {wide(3) << 31}]] m x set x } 6442450944 test binary-61.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} bigEndian { binary scan [binary format W [expr {wide(3) << 31}]] m x set x } 6442450944 # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues binary scan [binary format dd -1.0 1.0] c* c switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ ieeeValues(-Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ ieeeValues(+Normal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ ieeeValues(+Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 } default { return 0 } } } testConstraint ieeeFloatingPoint [testIEEE] # scan/format infinities test binary-62.1 {infinity} ieeeFloatingPoint { binary scan [binary format q Infinity] w w format 0x%016lx $w } 0x7ff0000000000000 test binary-62.2 {infinity} ieeeFloatingPoint { binary scan [binary format q -Infinity] w w format 0x%016lx $w } 0xfff0000000000000 test binary-62.3 {infinity} ieeeFloatingPoint { binary scan [binary format q Inf] w w format 0x%016lx $w } 0x7ff0000000000000 test binary-62.4 {infinity} ieeeFloatingPoint { binary scan [binary format q -Infinity] w w format 0x%016lx $w } 0xfff0000000000000 test binary-62.5 {infinity} ieeeFloatingPoint { binary scan [binary format w 0x7ff0000000000000] q d set d } Inf test binary-62.6 {infinity} ieeeFloatingPoint { binary scan [binary format w 0xfff0000000000000] q d set d } -Inf # scan/format Not-a-Number test binary-63.1 {NaN} ieeeFloatingPoint { binary scan [binary format q NaN] w w format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] } 0x7ff0000000000000 test binary-63.2 {NaN} ieeeFloatingPoint { binary scan [binary format q -NaN] w w format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] } 0xfff0000000000000 test binary-63.3 {NaN} ieeeFloatingPoint { binary scan [binary format q NaN(3123456789aBc)] w w format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] } 0x7ff3123456789abc test binary-63.4 {NaN} ieeeFloatingPoint { binary scan [binary format q {NaN( 3123456789aBc)}] w w format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] } 0x7ff3123456789abc test binary-64.1 {NaN} \ -constraints ieeeFloatingPoint \ -body { binary scan [binary format w 0x7ff8000000000000] q d set d } \ -match glob -result NaN* test binary-64.2 {NaN} \ -constraints ieeeFloatingPoint \ -body { binary scan [binary format w 0x7ff0123456789aBc] q d set d } \ -match glob -result NaN(*123456789abc) test binary-65.1 {largest significand} ieeeFloatingPoint { binary scan [binary format w 0x3fcfffffffffffff] q d set d } 0.24999999999999997 test binary-65.2 {smallest significand} ieeeFloatingPoint { binary scan [binary format w 0x3fd0000000000000] q d set d } 0.25 test binary-65.3 {largest significand} ieeeFloatingPoint { binary scan [binary format w 0x3fdfffffffffffff] q d set d } 0.49999999999999994 test binary-65.4 {smallest significand} ieeeFloatingPoint { binary scan [binary format w 0x3fe0000000000000] q d set d } 0.5 test binary-65.5 {largest significand} ieeeFloatingPoint { binary scan [binary format w 0x3fffffffffffffff] q d set d } 1.9999999999999998 test binary-65.6 {smallest significand} ieeeFloatingPoint { binary scan [binary format w 0x4000000000000000] q d set d } 2.0 test binary-65.7 {smallest significand} ieeeFloatingPoint { binary scan [binary format w 0x434fffffffffffff] q d set d } 18014398509481982.0 test binary-65.8 {largest significand} ieeeFloatingPoint { binary scan [binary format w 0x4350000000000000] q d set d } 18014398509481984.0 test binary-65.8 {largest significand} ieeeFloatingPoint { binary scan [binary format w 0x4350000000000001] q d set d } 18014398509481988.0 # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
Added tests/chan.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 | # This file contains a collection of tests for the Tcl built-in 'chan' # command. Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # # Copyright (c) 2005 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: chan.test,v 1.4.6.3 2005/08/25 15:46:53 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # # Note: The tests for the chan methods "create" and "postevent" # currently reside in the file "ioCmd.test". # test chan-1.1 {chan command general syntax} -body { chan } -returnCodes error -result "wrong # args: should be \"chan subcommand ?argument ...?\"" test chan-1.2 {chan command general syntax} -body { chan FOOBAR } -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, postevent, puts, read, seek, tell, or truncate" test chan-2.1 {chan command: blocked subcommand} -body { chan blocked foo bar } -returnCodes error -result "wrong # args: should be \"chan blocked channelId\"" test chan-3.1 {chan command: close subcommand} -body { chan close foo bar } -returnCodes error -result "wrong # args: should be \"chan close channelId\"" test chan-4.1 {chan command: configure subcommand} -body { chan configure } -returnCodes error -result "wrong # args: should be \"chan configure channelId ?optionName? ?value? ?optionName value?...\"" test chan-5.1 {chan command: copy subcommand} -body { chan copy foo } -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\"" test chan-6.1 {chan command: eof subcommand} -body { chan eof foo bar } -returnCodes error -result "wrong # args: should be \"chan eof channelId\"" test chan-7.1 {chan command: event subcommand} -body { chan event foo } -returnCodes error -result "wrong # args: should be \"chan event channelId event ?script?\"" test chan-8.1 {chan command: flush subcommand} -body { chan flush foo bar } -returnCodes error -result "wrong # args: should be \"chan flush channelId\"" test chan-9.1 {chan command: gets subcommand} -body { chan gets } -returnCodes error -result "wrong # args: should be \"chan gets channelId ?varName?\"" test chan-10.1 {chan command: names subcommand} -body { chan names foo bar } -returnCodes error -result "wrong # args: should be \"chan names ?pattern?\"" test chan-11.1 {chan command: puts subcommand} -body { chan puts foo bar foo bar } -returnCodes error -result "wrong # args: should be \"chan puts ?-nonewline? ?channelId? string\"" test chan-12.1 {chan command: read subcommand} -body { chan read } -returnCodes error -result "wrong # args: should be \"chan read channelId ?numChars?\" or \"chan read ?-nonewline? channelId\"" test chan-13.1 {chan command: seek subcommand} -body { chan seek foo bar foo bar } -returnCodes error -result "wrong # args: should be \"chan seek channelId offset ?origin?\"" test chan-14.1 {chan command: tell subcommand} -body { chan tell foo bar } -returnCodes error -result "wrong # args: should be \"chan tell channelId\"" test chan-15.1 {chan command: truncate subcommand} -body { chan truncate foo bar foo bar } -returnCodes error -result "wrong \# args: should be \"chan truncate channelId ?length?\"" test chan-15.2 {chan command: truncate subcommand} -setup { set file [makeFile {} testTruncate] set f [open $file w+] fconfigure $f -translation binary } -body { seek $f 0 puts -nonewline $f 12345 seek $f 0 chan truncate $f 2 read $f } -result 12 -cleanup { catch {close $f} catch {removeFile $file} } cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to tests/clock.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # clock.test -- # # This test file covers the 'clock' command that manipulates time. # # 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) 2004 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 | # clock.test -- # # This test file covers the 'clock' command that manipulates time. # # 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) 2004 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: clock.test,v 1.52.2.6 2005/10/08 13:44:38 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } if { $::tcl_platform(platform) eq {windows} } { |
︙ | ︙ | |||
38 39 40 41 42 43 44 45 46 47 48 49 50 51 | # Still no registry! namespace eval ::tcl::clock [set NoRegistry {}] } } } package require msgcat 1.4 # TEST PLAN # clock-1: # [clock format] - tests of bad and empty arguments # # clock-2 # formatting of year, month and day of month | > > > > > | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | # Still no registry! namespace eval ::tcl::clock [set NoRegistry {}] } } } package require msgcat 1.4 ::tcltest::testConstraint detroit \ [expr {![catch {clock format 0 -timezone :America/Detroit -format %z}]}] ::tcltest::testConstraint y2038 \ [expr {[clock format 2158894800 -format %z -timezone :America/Detroit] eq {-0400}}] # TEST PLAN # clock-1: # [clock format] - tests of bad and empty arguments # # clock-2 # formatting of year, month and day of month |
︙ | ︙ | |||
14770 14771 14772 14773 14774 14775 14776 | } {23 xxiii 11 xi 23 xxiii 11 xi 59 lix PM pm 11:59:59 pm 23:59 59 lix 23:59:59 23:59:59 xxiii h lix m lix s Thu Jan 1 23:59:59 GMT 1970} # END testcases4 # BEGIN testcases5 # Test formatting of Daylight Saving Time | < < < | 14775 14776 14777 14778 14779 14780 14781 14782 14783 14784 14785 14786 14787 14788 14789 14790 14791 14792 14793 14794 14795 14796 | } {23 xxiii 11 xi 23 xxiii 11 xi 59 lix PM pm 11:59:59 pm 23:59 59 lix 23:59:59 23:59:59 xxiii h lix m lix s Thu Jan 1 23:59:59 GMT 1970} # END testcases4 # BEGIN testcases5 # Test formatting of Daylight Saving Time test clock-5.1 {does Detroit exist} { clock format 0 -format {} -timezone :America/Detroit concat } {} test clock-5.2 {does Detroit have a Y2038 problem} detroit { if { [clock format 2158894800 -format %z -timezone :America/Detroit] ne {-0400} } { concat {y2038 problem} } else { concat {ok} } } ok test clock-5.3 {time zone boundary case 1904-12-31 23:59:59} detroit { clock format -2051202470 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {23:59:59 -053211 LMT} |
︙ | ︙ | |||
15756 15757 15758 15759 15760 15761 15762 | clock format 1162101600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.245 {time zone boundary case 2006-10-29 01:00:01} detroit { clock format 1162101601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 15758 15759 15760 15761 15762 15763 15764 15765 15766 15767 15768 15769 15770 15771 15772 15773 15774 15775 15776 15777 15778 15779 15780 15781 15782 15783 15784 15785 15786 15787 15788 15789 15790 15791 15792 15793 15794 15795 15796 15797 15798 15799 15800 15801 15802 15803 15804 15805 15806 15807 15808 15809 15810 15811 15812 15813 15814 15815 15816 15817 15818 15819 15820 15821 15822 15823 15824 15825 15826 15827 15828 15829 15830 15831 15832 15833 15834 15835 15836 15837 15838 15839 15840 15841 15842 15843 15844 15845 15846 15847 15848 15849 15850 15851 15852 15853 15854 15855 15856 15857 15858 15859 15860 15861 15862 15863 15864 15865 15866 15867 15868 15869 15870 15871 15872 15873 15874 15875 15876 15877 15878 15879 15880 15881 15882 15883 15884 15885 15886 15887 15888 15889 15890 15891 15892 15893 15894 15895 15896 15897 15898 15899 15900 15901 15902 15903 15904 15905 15906 15907 15908 15909 15910 15911 15912 15913 15914 15915 15916 15917 15918 15919 15920 15921 15922 15923 15924 15925 15926 15927 15928 15929 15930 15931 15932 15933 15934 15935 15936 15937 15938 15939 15940 15941 15942 15943 15944 15945 15946 15947 15948 15949 15950 15951 15952 15953 15954 15955 15956 15957 15958 15959 15960 15961 15962 15963 15964 15965 15966 15967 15968 15969 15970 15971 15972 15973 15974 15975 15976 15977 15978 15979 15980 15981 15982 15983 15984 15985 15986 15987 15988 15989 15990 15991 15992 15993 15994 15995 15996 15997 15998 15999 16000 16001 16002 16003 16004 16005 16006 16007 16008 16009 16010 16011 16012 16013 16014 16015 16016 16017 16018 16019 16020 16021 16022 16023 16024 16025 16026 16027 16028 16029 16030 16031 16032 16033 16034 16035 16036 16037 16038 16039 16040 16041 16042 16043 16044 16045 16046 16047 16048 16049 16050 16051 16052 16053 16054 16055 16056 16057 16058 16059 16060 16061 16062 16063 16064 16065 16066 16067 16068 16069 16070 16071 16072 16073 16074 16075 16076 16077 16078 16079 16080 16081 16082 16083 16084 16085 16086 16087 16088 16089 16090 16091 16092 16093 16094 16095 16096 16097 16098 16099 16100 16101 16102 16103 16104 16105 16106 16107 16108 16109 16110 16111 16112 16113 16114 16115 16116 16117 16118 16119 16120 16121 16122 16123 16124 16125 16126 16127 16128 16129 16130 16131 16132 16133 16134 16135 16136 16137 16138 16139 16140 16141 16142 16143 16144 16145 16146 16147 16148 16149 16150 16151 16152 16153 16154 16155 16156 16157 16158 16159 16160 16161 16162 16163 16164 16165 16166 16167 16168 16169 16170 16171 16172 16173 16174 16175 16176 16177 16178 16179 16180 16181 16182 16183 16184 16185 16186 16187 16188 16189 16190 16191 16192 16193 16194 16195 16196 16197 16198 16199 16200 16201 16202 16203 16204 16205 16206 16207 16208 16209 16210 16211 16212 16213 16214 16215 16216 16217 16218 16219 16220 16221 16222 16223 16224 16225 16226 16227 16228 16229 16230 16231 16232 16233 16234 16235 16236 16237 16238 16239 16240 16241 16242 16243 16244 16245 16246 16247 16248 16249 16250 16251 16252 16253 16254 16255 16256 16257 16258 16259 16260 16261 16262 16263 16264 16265 16266 16267 16268 16269 16270 16271 16272 16273 16274 16275 16276 16277 16278 16279 16280 16281 16282 16283 16284 16285 16286 16287 16288 16289 16290 16291 16292 16293 16294 16295 16296 16297 16298 16299 16300 16301 16302 16303 16304 16305 16306 16307 16308 16309 16310 16311 16312 16313 16314 16315 16316 16317 16318 16319 16320 16321 16322 16323 16324 16325 16326 16327 16328 16329 16330 16331 16332 16333 16334 16335 16336 16337 16338 16339 16340 16341 16342 16343 16344 16345 16346 16347 16348 16349 16350 16351 16352 16353 16354 16355 16356 16357 16358 16359 16360 16361 16362 16363 16364 16365 16366 16367 16368 16369 16370 16371 16372 16373 16374 16375 16376 16377 16378 16379 16380 16381 16382 16383 16384 16385 16386 16387 16388 16389 16390 16391 16392 16393 16394 16395 16396 16397 16398 16399 16400 16401 16402 16403 16404 16405 16406 16407 16408 16409 16410 16411 16412 16413 16414 16415 16416 16417 16418 16419 16420 16421 16422 16423 16424 16425 16426 16427 16428 16429 16430 16431 16432 16433 16434 16435 16436 16437 16438 16439 16440 16441 16442 16443 16444 16445 16446 16447 16448 16449 16450 16451 16452 16453 16454 16455 16456 16457 16458 16459 16460 16461 16462 16463 16464 16465 16466 16467 16468 16469 16470 16471 16472 16473 16474 16475 16476 16477 16478 16479 16480 16481 16482 16483 16484 16485 16486 16487 16488 16489 16490 16491 16492 16493 16494 16495 16496 16497 16498 16499 16500 16501 16502 16503 16504 16505 16506 16507 16508 16509 16510 16511 16512 16513 16514 16515 16516 16517 16518 16519 16520 16521 16522 16523 16524 16525 16526 16527 16528 16529 16530 16531 16532 16533 16534 16535 16536 16537 16538 16539 16540 16541 16542 16543 16544 16545 16546 16547 16548 16549 16550 16551 16552 16553 16554 16555 16556 16557 16558 16559 16560 16561 16562 16563 16564 16565 16566 16567 16568 16569 16570 16571 16572 16573 16574 16575 16576 16577 16578 16579 16580 16581 16582 16583 16584 16585 16586 16587 16588 16589 16590 16591 16592 16593 16594 16595 16596 16597 16598 16599 16600 16601 16602 16603 16604 16605 16606 16607 16608 16609 16610 16611 16612 16613 16614 16615 16616 16617 16618 16619 16620 16621 16622 16623 16624 16625 16626 16627 16628 16629 16630 16631 16632 16633 16634 16635 16636 16637 16638 16639 16640 16641 16642 16643 16644 16645 16646 16647 16648 16649 16650 16651 16652 16653 16654 16655 16656 16657 16658 16659 16660 16661 16662 16663 16664 16665 16666 16667 16668 16669 16670 16671 16672 16673 16674 16675 16676 16677 16678 16679 16680 16681 16682 16683 16684 16685 16686 16687 16688 16689 16690 16691 16692 16693 16694 16695 16696 16697 16698 16699 16700 16701 16702 16703 16704 16705 16706 16707 16708 16709 16710 16711 16712 16713 16714 16715 16716 16717 16718 16719 16720 16721 16722 16723 16724 16725 16726 16727 16728 16729 16730 16731 16732 16733 16734 16735 16736 16737 16738 16739 16740 16741 16742 16743 16744 16745 16746 16747 16748 16749 16750 16751 16752 16753 16754 16755 16756 16757 16758 16759 16760 16761 16762 16763 16764 16765 16766 16767 16768 16769 16770 16771 16772 16773 16774 16775 16776 16777 16778 16779 16780 16781 16782 16783 16784 16785 16786 16787 16788 16789 16790 16791 16792 16793 16794 16795 16796 16797 16798 16799 16800 16801 16802 16803 16804 16805 16806 16807 16808 16809 16810 16811 16812 16813 16814 16815 16816 16817 16818 16819 16820 16821 16822 16823 16824 16825 16826 16827 16828 16829 16830 16831 16832 16833 16834 16835 16836 16837 16838 16839 16840 16841 16842 16843 16844 16845 16846 16847 16848 16849 16850 16851 16852 16853 16854 16855 16856 16857 16858 16859 16860 16861 16862 16863 16864 16865 16866 16867 16868 16869 16870 16871 16872 16873 16874 16875 16876 16877 16878 16879 16880 16881 16882 16883 16884 16885 16886 16887 16888 16889 16890 16891 16892 16893 16894 16895 16896 16897 16898 16899 16900 16901 16902 16903 16904 16905 16906 16907 16908 16909 16910 16911 16912 16913 16914 16915 16916 16917 16918 16919 16920 16921 16922 16923 16924 16925 16926 16927 16928 16929 16930 16931 16932 16933 16934 16935 16936 16937 16938 16939 16940 16941 16942 16943 16944 16945 16946 16947 16948 16949 16950 16951 16952 16953 16954 16955 16956 16957 16958 16959 16960 16961 16962 16963 16964 16965 16966 16967 16968 16969 16970 16971 16972 16973 16974 16975 16976 16977 16978 16979 16980 16981 16982 16983 16984 16985 16986 16987 16988 16989 16990 16991 16992 16993 16994 16995 16996 16997 16998 16999 17000 17001 17002 17003 17004 17005 17006 17007 17008 17009 17010 17011 17012 17013 17014 17015 17016 17017 17018 17019 17020 17021 17022 17023 17024 17025 17026 17027 17028 17029 17030 17031 17032 17033 17034 17035 17036 17037 17038 17039 17040 17041 17042 17043 17044 17045 17046 17047 17048 17049 17050 17051 17052 17053 17054 17055 17056 17057 17058 17059 17060 17061 17062 17063 17064 17065 17066 17067 17068 17069 17070 17071 17072 17073 17074 17075 17076 17077 17078 17079 17080 17081 17082 17083 17084 17085 17086 17087 17088 17089 17090 17091 17092 17093 17094 17095 17096 17097 17098 17099 17100 17101 17102 17103 17104 17105 17106 17107 17108 17109 17110 17111 17112 17113 17114 17115 17116 17117 17118 17119 17120 17121 17122 17123 17124 17125 17126 17127 17128 17129 17130 17131 17132 17133 17134 17135 17136 17137 17138 17139 17140 17141 17142 17143 17144 17145 17146 17147 17148 17149 17150 17151 17152 17153 17154 17155 17156 17157 17158 17159 17160 17161 17162 17163 17164 17165 17166 17167 17168 17169 17170 17171 17172 17173 17174 17175 17176 17177 17178 17179 17180 17181 17182 17183 17184 17185 17186 17187 17188 17189 17190 17191 17192 17193 17194 17195 17196 17197 17198 17199 17200 17201 17202 17203 17204 17205 17206 17207 17208 17209 17210 17211 17212 17213 17214 17215 17216 17217 17218 17219 17220 17221 17222 17223 17224 17225 17226 17227 17228 17229 17230 17231 17232 17233 17234 17235 17236 17237 17238 17239 17240 17241 17242 17243 17244 17245 17246 17247 17248 17249 17250 17251 17252 17253 17254 17255 17256 17257 17258 17259 17260 17261 17262 17263 17264 17265 17266 17267 17268 17269 17270 17271 17272 17273 17274 17275 17276 17277 17278 17279 17280 17281 17282 17283 17284 17285 17286 17287 17288 17289 17290 17291 17292 17293 17294 17295 17296 17297 17298 17299 17300 17301 17302 17303 17304 17305 17306 17307 17308 17309 17310 17311 17312 17313 17314 17315 17316 17317 17318 17319 17320 17321 17322 17323 17324 17325 17326 17327 17328 17329 17330 17331 17332 17333 17334 17335 17336 17337 17338 17339 17340 17341 17342 17343 17344 17345 17346 17347 17348 17349 17350 17351 17352 17353 17354 17355 17356 17357 17358 17359 17360 17361 17362 17363 17364 17365 17366 17367 17368 17369 17370 17371 17372 17373 17374 17375 17376 17377 17378 17379 17380 17381 17382 17383 17384 17385 17386 17387 17388 17389 17390 17391 17392 17393 17394 17395 17396 17397 17398 17399 17400 17401 17402 17403 17404 17405 17406 17407 17408 17409 17410 17411 17412 17413 17414 17415 17416 17417 17418 17419 17420 17421 17422 17423 17424 17425 17426 17427 17428 17429 17430 17431 17432 17433 17434 17435 17436 17437 17438 17439 17440 17441 17442 17443 17444 17445 17446 17447 17448 17449 17450 17451 17452 17453 17454 17455 17456 17457 17458 17459 17460 17461 17462 17463 17464 17465 17466 17467 17468 17469 17470 17471 17472 17473 17474 17475 17476 17477 17478 17479 17480 17481 17482 17483 17484 17485 17486 17487 17488 17489 17490 17491 17492 17493 17494 17495 17496 17497 17498 17499 17500 17501 17502 17503 17504 17505 17506 17507 17508 17509 17510 17511 17512 17513 17514 17515 17516 17517 17518 17519 17520 17521 17522 17523 17524 17525 17526 17527 17528 17529 17530 17531 17532 17533 17534 17535 17536 17537 17538 17539 17540 17541 17542 17543 17544 17545 17546 17547 17548 17549 17550 17551 17552 17553 17554 17555 17556 17557 17558 17559 17560 17561 17562 17563 17564 17565 17566 17567 17568 17569 17570 17571 17572 17573 17574 17575 17576 17577 17578 17579 17580 17581 17582 17583 17584 17585 17586 17587 17588 17589 17590 17591 17592 17593 17594 17595 17596 17597 17598 17599 17600 17601 17602 17603 17604 17605 17606 17607 17608 17609 17610 17611 17612 17613 17614 17615 17616 17617 17618 17619 17620 17621 17622 17623 17624 17625 17626 17627 17628 17629 17630 17631 17632 17633 17634 17635 17636 17637 17638 17639 17640 17641 17642 17643 17644 17645 17646 17647 17648 17649 17650 17651 17652 17653 17654 17655 17656 17657 17658 17659 17660 17661 17662 17663 17664 17665 17666 17667 17668 17669 17670 17671 17672 17673 17674 17675 17676 17677 17678 17679 17680 17681 17682 17683 17684 17685 17686 17687 17688 17689 17690 17691 17692 17693 17694 17695 17696 17697 17698 17699 17700 17701 17702 17703 17704 17705 17706 17707 17708 17709 17710 17711 17712 17713 17714 17715 17716 17717 17718 17719 17720 17721 17722 17723 17724 17725 17726 17727 17728 17729 17730 17731 17732 17733 17734 17735 17736 17737 17738 17739 17740 17741 17742 17743 17744 17745 17746 17747 17748 17749 17750 17751 17752 17753 17754 17755 17756 17757 17758 17759 17760 17761 17762 17763 17764 17765 17766 17767 17768 17769 17770 17771 17772 17773 17774 17775 17776 17777 17778 17779 17780 17781 17782 17783 17784 17785 17786 17787 17788 17789 17790 17791 17792 17793 17794 17795 17796 17797 17798 17799 17800 17801 17802 17803 17804 17805 17806 17807 17808 17809 17810 17811 17812 17813 17814 17815 17816 17817 17818 17819 17820 17821 17822 17823 17824 17825 17826 17827 17828 17829 17830 17831 17832 17833 17834 17835 17836 17837 17838 17839 17840 17841 17842 17843 17844 17845 17846 17847 17848 17849 17850 17851 17852 17853 17854 17855 17856 17857 17858 17859 17860 17861 17862 17863 17864 17865 17866 17867 17868 17869 17870 17871 17872 17873 17874 17875 17876 17877 17878 17879 17880 17881 17882 17883 17884 17885 17886 17887 17888 17889 17890 17891 17892 17893 17894 17895 17896 17897 17898 17899 17900 17901 17902 17903 17904 17905 17906 17907 17908 17909 17910 17911 17912 17913 17914 17915 17916 17917 17918 17919 17920 17921 17922 17923 17924 17925 17926 17927 17928 17929 17930 17931 17932 17933 17934 17935 17936 17937 17938 17939 17940 17941 17942 17943 17944 17945 17946 17947 17948 17949 17950 17951 17952 17953 17954 17955 17956 17957 17958 17959 17960 17961 17962 17963 17964 17965 17966 17967 17968 17969 17970 17971 17972 17973 17974 17975 17976 17977 17978 17979 17980 17981 17982 17983 17984 17985 17986 17987 17988 17989 17990 17991 17992 17993 17994 17995 17996 17997 17998 17999 18000 18001 | clock format 1162101600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.245 {time zone boundary case 2006-10-29 01:00:01} detroit { clock format 1162101601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.246 {time zone boundary case 2007-03-11 01:59:59} detroit { clock format 1173596399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.247 {time zone boundary case 2007-03-11 03:00:00} detroit { clock format 1173596400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.248 {time zone boundary case 2007-03-11 03:00:01} detroit { clock format 1173596401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.249 {time zone boundary case 2007-11-04 01:59:59} detroit { clock format 1194155999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.250 {time zone boundary case 2007-11-04 01:00:00} detroit { clock format 1194156000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.251 {time zone boundary case 2007-11-04 01:00:01} detroit { clock format 1194156001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.252 {time zone boundary case 2008-03-09 01:59:59} detroit { clock format 1205045999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.253 {time zone boundary case 2008-03-09 03:00:00} detroit { clock format 1205046000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.254 {time zone boundary case 2008-03-09 03:00:01} detroit { clock format 1205046001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.255 {time zone boundary case 2008-11-02 01:59:59} detroit { clock format 1225605599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.256 {time zone boundary case 2008-11-02 01:00:00} detroit { clock format 1225605600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.257 {time zone boundary case 2008-11-02 01:00:01} detroit { clock format 1225605601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.258 {time zone boundary case 2009-03-08 01:59:59} detroit { clock format 1236495599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.259 {time zone boundary case 2009-03-08 03:00:00} detroit { clock format 1236495600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.260 {time zone boundary case 2009-03-08 03:00:01} detroit { clock format 1236495601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.261 {time zone boundary case 2009-11-01 01:59:59} detroit { clock format 1257055199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.262 {time zone boundary case 2009-11-01 01:00:00} detroit { clock format 1257055200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.263 {time zone boundary case 2009-11-01 01:00:01} detroit { clock format 1257055201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.264 {time zone boundary case 2010-03-14 01:59:59} detroit { clock format 1268549999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.265 {time zone boundary case 2010-03-14 03:00:00} detroit { clock format 1268550000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.266 {time zone boundary case 2010-03-14 03:00:01} detroit { clock format 1268550001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.267 {time zone boundary case 2010-11-07 01:59:59} detroit { clock format 1289109599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.268 {time zone boundary case 2010-11-07 01:00:00} detroit { clock format 1289109600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.269 {time zone boundary case 2010-11-07 01:00:01} detroit { clock format 1289109601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.270 {time zone boundary case 2011-03-13 01:59:59} detroit { clock format 1299999599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.271 {time zone boundary case 2011-03-13 03:00:00} detroit { clock format 1299999600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.272 {time zone boundary case 2011-03-13 03:00:01} detroit { clock format 1299999601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.273 {time zone boundary case 2011-11-06 01:59:59} detroit { clock format 1320559199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.274 {time zone boundary case 2011-11-06 01:00:00} detroit { clock format 1320559200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.275 {time zone boundary case 2011-11-06 01:00:01} detroit { clock format 1320559201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.276 {time zone boundary case 2012-03-11 01:59:59} detroit { clock format 1331449199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.277 {time zone boundary case 2012-03-11 03:00:00} detroit { clock format 1331449200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.278 {time zone boundary case 2012-03-11 03:00:01} detroit { clock format 1331449201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.279 {time zone boundary case 2012-11-04 01:59:59} detroit { clock format 1352008799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.280 {time zone boundary case 2012-11-04 01:00:00} detroit { clock format 1352008800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.281 {time zone boundary case 2012-11-04 01:00:01} detroit { clock format 1352008801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.282 {time zone boundary case 2013-03-10 01:59:59} detroit { clock format 1362898799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.283 {time zone boundary case 2013-03-10 03:00:00} detroit { clock format 1362898800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.284 {time zone boundary case 2013-03-10 03:00:01} detroit { clock format 1362898801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.285 {time zone boundary case 2013-11-03 01:59:59} detroit { clock format 1383458399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.286 {time zone boundary case 2013-11-03 01:00:00} detroit { clock format 1383458400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.287 {time zone boundary case 2013-11-03 01:00:01} detroit { clock format 1383458401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.288 {time zone boundary case 2014-03-09 01:59:59} detroit { clock format 1394348399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.289 {time zone boundary case 2014-03-09 03:00:00} detroit { clock format 1394348400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.290 {time zone boundary case 2014-03-09 03:00:01} detroit { clock format 1394348401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.291 {time zone boundary case 2014-11-02 01:59:59} detroit { clock format 1414907999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.292 {time zone boundary case 2014-11-02 01:00:00} detroit { clock format 1414908000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.293 {time zone boundary case 2014-11-02 01:00:01} detroit { clock format 1414908001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.294 {time zone boundary case 2015-03-08 01:59:59} detroit { clock format 1425797999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.295 {time zone boundary case 2015-03-08 03:00:00} detroit { clock format 1425798000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.296 {time zone boundary case 2015-03-08 03:00:01} detroit { clock format 1425798001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.297 {time zone boundary case 2015-11-01 01:59:59} detroit { clock format 1446357599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.298 {time zone boundary case 2015-11-01 01:00:00} detroit { clock format 1446357600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.299 {time zone boundary case 2015-11-01 01:00:01} detroit { clock format 1446357601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.300 {time zone boundary case 2016-03-13 01:59:59} detroit { clock format 1457852399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.301 {time zone boundary case 2016-03-13 03:00:00} detroit { clock format 1457852400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.302 {time zone boundary case 2016-03-13 03:00:01} detroit { clock format 1457852401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.303 {time zone boundary case 2016-11-06 01:59:59} detroit { clock format 1478411999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.304 {time zone boundary case 2016-11-06 01:00:00} detroit { clock format 1478412000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.305 {time zone boundary case 2016-11-06 01:00:01} detroit { clock format 1478412001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.306 {time zone boundary case 2017-03-12 01:59:59} detroit { clock format 1489301999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.307 {time zone boundary case 2017-03-12 03:00:00} detroit { clock format 1489302000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.308 {time zone boundary case 2017-03-12 03:00:01} detroit { clock format 1489302001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.309 {time zone boundary case 2017-11-05 01:59:59} detroit { clock format 1509861599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.310 {time zone boundary case 2017-11-05 01:00:00} detroit { clock format 1509861600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.311 {time zone boundary case 2017-11-05 01:00:01} detroit { clock format 1509861601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.312 {time zone boundary case 2018-03-11 01:59:59} detroit { clock format 1520751599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.313 {time zone boundary case 2018-03-11 03:00:00} detroit { clock format 1520751600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.314 {time zone boundary case 2018-03-11 03:00:01} detroit { clock format 1520751601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.315 {time zone boundary case 2018-11-04 01:59:59} detroit { clock format 1541311199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.316 {time zone boundary case 2018-11-04 01:00:00} detroit { clock format 1541311200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.317 {time zone boundary case 2018-11-04 01:00:01} detroit { clock format 1541311201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.318 {time zone boundary case 2019-03-10 01:59:59} detroit { clock format 1552201199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.319 {time zone boundary case 2019-03-10 03:00:00} detroit { clock format 1552201200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.320 {time zone boundary case 2019-03-10 03:00:01} detroit { clock format 1552201201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.321 {time zone boundary case 2019-11-03 01:59:59} detroit { clock format 1572760799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.322 {time zone boundary case 2019-11-03 01:00:00} detroit { clock format 1572760800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.323 {time zone boundary case 2019-11-03 01:00:01} detroit { clock format 1572760801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.324 {time zone boundary case 2020-03-08 01:59:59} detroit { clock format 1583650799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.325 {time zone boundary case 2020-03-08 03:00:00} detroit { clock format 1583650800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.326 {time zone boundary case 2020-03-08 03:00:01} detroit { clock format 1583650801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.327 {time zone boundary case 2020-11-01 01:59:59} detroit { clock format 1604210399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.328 {time zone boundary case 2020-11-01 01:00:00} detroit { clock format 1604210400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.329 {time zone boundary case 2020-11-01 01:00:01} detroit { clock format 1604210401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.330 {time zone boundary case 2021-03-14 01:59:59} detroit { clock format 1615705199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.331 {time zone boundary case 2021-03-14 03:00:00} detroit { clock format 1615705200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.332 {time zone boundary case 2021-03-14 03:00:01} detroit { clock format 1615705201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.333 {time zone boundary case 2021-11-07 01:59:59} detroit { clock format 1636264799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.334 {time zone boundary case 2021-11-07 01:00:00} detroit { clock format 1636264800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.335 {time zone boundary case 2021-11-07 01:00:01} detroit { clock format 1636264801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.336 {time zone boundary case 2022-03-13 01:59:59} detroit { clock format 1647154799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.337 {time zone boundary case 2022-03-13 03:00:00} detroit { clock format 1647154800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.338 {time zone boundary case 2022-03-13 03:00:01} detroit { clock format 1647154801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.339 {time zone boundary case 2022-11-06 01:59:59} detroit { clock format 1667714399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.340 {time zone boundary case 2022-11-06 01:00:00} detroit { clock format 1667714400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.341 {time zone boundary case 2022-11-06 01:00:01} detroit { clock format 1667714401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.342 {time zone boundary case 2023-03-12 01:59:59} detroit { clock format 1678604399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.343 {time zone boundary case 2023-03-12 03:00:00} detroit { clock format 1678604400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.344 {time zone boundary case 2023-03-12 03:00:01} detroit { clock format 1678604401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.345 {time zone boundary case 2023-11-05 01:59:59} detroit { clock format 1699163999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.346 {time zone boundary case 2023-11-05 01:00:00} detroit { clock format 1699164000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.347 {time zone boundary case 2023-11-05 01:00:01} detroit { clock format 1699164001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.348 {time zone boundary case 2024-03-10 01:59:59} detroit { clock format 1710053999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.349 {time zone boundary case 2024-03-10 03:00:00} detroit { clock format 1710054000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.350 {time zone boundary case 2024-03-10 03:00:01} detroit { clock format 1710054001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.351 {time zone boundary case 2024-11-03 01:59:59} detroit { clock format 1730613599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.352 {time zone boundary case 2024-11-03 01:00:00} detroit { clock format 1730613600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.353 {time zone boundary case 2024-11-03 01:00:01} detroit { clock format 1730613601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.354 {time zone boundary case 2025-03-09 01:59:59} detroit { clock format 1741503599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.355 {time zone boundary case 2025-03-09 03:00:00} detroit { clock format 1741503600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.356 {time zone boundary case 2025-03-09 03:00:01} detroit { clock format 1741503601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.357 {time zone boundary case 2025-11-02 01:59:59} detroit { clock format 1762063199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.358 {time zone boundary case 2025-11-02 01:00:00} detroit { clock format 1762063200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.359 {time zone boundary case 2025-11-02 01:00:01} detroit { clock format 1762063201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.360 {time zone boundary case 2026-03-08 01:59:59} detroit { clock format 1772953199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.361 {time zone boundary case 2026-03-08 03:00:00} detroit { clock format 1772953200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.362 {time zone boundary case 2026-03-08 03:00:01} detroit { clock format 1772953201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.363 {time zone boundary case 2026-11-01 01:59:59} detroit { clock format 1793512799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.364 {time zone boundary case 2026-11-01 01:00:00} detroit { clock format 1793512800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.365 {time zone boundary case 2026-11-01 01:00:01} detroit { clock format 1793512801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.366 {time zone boundary case 2027-03-14 01:59:59} detroit { clock format 1805007599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.367 {time zone boundary case 2027-03-14 03:00:00} detroit { clock format 1805007600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.368 {time zone boundary case 2027-03-14 03:00:01} detroit { clock format 1805007601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.369 {time zone boundary case 2027-11-07 01:59:59} detroit { clock format 1825567199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.370 {time zone boundary case 2027-11-07 01:00:00} detroit { clock format 1825567200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.371 {time zone boundary case 2027-11-07 01:00:01} detroit { clock format 1825567201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.372 {time zone boundary case 2028-03-12 01:59:59} detroit { clock format 1836457199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.373 {time zone boundary case 2028-03-12 03:00:00} detroit { clock format 1836457200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.374 {time zone boundary case 2028-03-12 03:00:01} detroit { clock format 1836457201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.375 {time zone boundary case 2028-11-05 01:59:59} detroit { clock format 1857016799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.376 {time zone boundary case 2028-11-05 01:00:00} detroit { clock format 1857016800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.377 {time zone boundary case 2028-11-05 01:00:01} detroit { clock format 1857016801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.378 {time zone boundary case 2029-03-11 01:59:59} detroit { clock format 1867906799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.379 {time zone boundary case 2029-03-11 03:00:00} detroit { clock format 1867906800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.380 {time zone boundary case 2029-03-11 03:00:01} detroit { clock format 1867906801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.381 {time zone boundary case 2029-11-04 01:59:59} detroit { clock format 1888466399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.382 {time zone boundary case 2029-11-04 01:00:00} detroit { clock format 1888466400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.383 {time zone boundary case 2029-11-04 01:00:01} detroit { clock format 1888466401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.384 {time zone boundary case 2030-03-10 01:59:59} detroit { clock format 1899356399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.385 {time zone boundary case 2030-03-10 03:00:00} detroit { clock format 1899356400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.386 {time zone boundary case 2030-03-10 03:00:01} detroit { clock format 1899356401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.387 {time zone boundary case 2030-11-03 01:59:59} detroit { clock format 1919915999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.388 {time zone boundary case 2030-11-03 01:00:00} detroit { clock format 1919916000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.389 {time zone boundary case 2030-11-03 01:00:01} detroit { clock format 1919916001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.390 {time zone boundary case 2031-03-09 01:59:59} detroit { clock format 1930805999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.391 {time zone boundary case 2031-03-09 03:00:00} detroit { clock format 1930806000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.392 {time zone boundary case 2031-03-09 03:00:01} detroit { clock format 1930806001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.393 {time zone boundary case 2031-11-02 01:59:59} detroit { clock format 1951365599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.394 {time zone boundary case 2031-11-02 01:00:00} detroit { clock format 1951365600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.395 {time zone boundary case 2031-11-02 01:00:01} detroit { clock format 1951365601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.396 {time zone boundary case 2032-03-14 01:59:59} detroit { clock format 1962860399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.397 {time zone boundary case 2032-03-14 03:00:00} detroit { clock format 1962860400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.398 {time zone boundary case 2032-03-14 03:00:01} detroit { clock format 1962860401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.399 {time zone boundary case 2032-11-07 01:59:59} detroit { clock format 1983419999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.400 {time zone boundary case 2032-11-07 01:00:00} detroit { clock format 1983420000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.401 {time zone boundary case 2032-11-07 01:00:01} detroit { clock format 1983420001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.402 {time zone boundary case 2033-03-13 01:59:59} detroit { clock format 1994309999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.403 {time zone boundary case 2033-03-13 03:00:00} detroit { clock format 1994310000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.404 {time zone boundary case 2033-03-13 03:00:01} detroit { clock format 1994310001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.405 {time zone boundary case 2033-11-06 01:59:59} detroit { clock format 2014869599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.406 {time zone boundary case 2033-11-06 01:00:00} detroit { clock format 2014869600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.407 {time zone boundary case 2033-11-06 01:00:01} detroit { clock format 2014869601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.408 {time zone boundary case 2034-03-12 01:59:59} detroit { clock format 2025759599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.409 {time zone boundary case 2034-03-12 03:00:00} detroit { clock format 2025759600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.410 {time zone boundary case 2034-03-12 03:00:01} detroit { clock format 2025759601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.411 {time zone boundary case 2034-11-05 01:59:59} detroit { clock format 2046319199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.412 {time zone boundary case 2034-11-05 01:00:00} detroit { clock format 2046319200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.413 {time zone boundary case 2034-11-05 01:00:01} detroit { clock format 2046319201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.414 {time zone boundary case 2035-03-11 01:59:59} detroit { clock format 2057209199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.415 {time zone boundary case 2035-03-11 03:00:00} detroit { clock format 2057209200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.416 {time zone boundary case 2035-03-11 03:00:01} detroit { clock format 2057209201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.417 {time zone boundary case 2035-11-04 01:59:59} detroit { clock format 2077768799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.418 {time zone boundary case 2035-11-04 01:00:00} detroit { clock format 2077768800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.419 {time zone boundary case 2035-11-04 01:00:01} detroit { clock format 2077768801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.420 {time zone boundary case 2036-03-09 01:59:59} detroit { clock format 2088658799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.421 {time zone boundary case 2036-03-09 03:00:00} detroit { clock format 2088658800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.422 {time zone boundary case 2036-03-09 03:00:01} detroit { clock format 2088658801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.423 {time zone boundary case 2036-11-02 01:59:59} detroit { clock format 2109218399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.424 {time zone boundary case 2036-11-02 01:00:00} detroit { clock format 2109218400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.425 {time zone boundary case 2036-11-02 01:00:01} detroit { clock format 2109218401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.426 {time zone boundary case 2037-03-08 01:59:59} detroit { clock format 2120108399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.427 {time zone boundary case 2037-03-08 03:00:00} detroit { clock format 2120108400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.428 {time zone boundary case 2037-03-08 03:00:01} detroit { clock format 2120108401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.429 {time zone boundary case 2037-11-01 01:59:59} detroit { clock format 2140667999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.430 {time zone boundary case 2037-11-01 01:00:00} detroit { clock format 2140668000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.431 {time zone boundary case 2037-11-01 01:00:01} detroit { clock format 2140668001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.432 {time zone boundary case 2038-03-14 01:59:59} {detroit y2038} { clock format 2152162799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.433 {time zone boundary case 2038-03-14 03:00:00} {detroit y2038} { clock format 2152162800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.434 {time zone boundary case 2038-03-14 03:00:01} {detroit y2038} { clock format 2152162801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.435 {time zone boundary case 2038-11-07 01:59:59} {detroit y2038} { clock format 2172722399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.436 {time zone boundary case 2038-11-07 01:00:00} {detroit y2038} { clock format 2172722400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.437 {time zone boundary case 2038-11-07 01:00:01} {detroit y2038} { clock format 2172722401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.438 {time zone boundary case 2039-03-13 01:59:59} {detroit y2038} { clock format 2183612399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.439 {time zone boundary case 2039-03-13 03:00:00} {detroit y2038} { clock format 2183612400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.440 {time zone boundary case 2039-03-13 03:00:01} {detroit y2038} { clock format 2183612401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.441 {time zone boundary case 2039-11-06 01:59:59} {detroit y2038} { clock format 2204171999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.442 {time zone boundary case 2039-11-06 01:00:00} {detroit y2038} { clock format 2204172000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.443 {time zone boundary case 2039-11-06 01:00:01} {detroit y2038} { clock format 2204172001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.444 {time zone boundary case 2040-03-11 01:59:59} {detroit y2038} { clock format 2215061999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.445 {time zone boundary case 2040-03-11 03:00:00} {detroit y2038} { clock format 2215062000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.446 {time zone boundary case 2040-03-11 03:00:01} {detroit y2038} { clock format 2215062001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.447 {time zone boundary case 2040-11-04 01:59:59} {detroit y2038} { clock format 2235621599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.448 {time zone boundary case 2040-11-04 01:00:00} {detroit y2038} { clock format 2235621600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.449 {time zone boundary case 2040-11-04 01:00:01} {detroit y2038} { clock format 2235621601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.450 {time zone boundary case 2041-03-10 01:59:59} {detroit y2038} { clock format 2246511599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.451 {time zone boundary case 2041-03-10 03:00:00} {detroit y2038} { clock format 2246511600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.452 {time zone boundary case 2041-03-10 03:00:01} {detroit y2038} { clock format 2246511601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.453 {time zone boundary case 2041-11-03 01:59:59} {detroit y2038} { clock format 2267071199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.454 {time zone boundary case 2041-11-03 01:00:00} {detroit y2038} { clock format 2267071200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.455 {time zone boundary case 2041-11-03 01:00:01} {detroit y2038} { clock format 2267071201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.456 {time zone boundary case 2042-03-09 01:59:59} {detroit y2038} { clock format 2277961199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.457 {time zone boundary case 2042-03-09 03:00:00} {detroit y2038} { clock format 2277961200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.458 {time zone boundary case 2042-03-09 03:00:01} {detroit y2038} { clock format 2277961201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.459 {time zone boundary case 2042-11-02 01:59:59} {detroit y2038} { clock format 2298520799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.460 {time zone boundary case 2042-11-02 01:00:00} {detroit y2038} { clock format 2298520800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.461 {time zone boundary case 2042-11-02 01:00:01} {detroit y2038} { clock format 2298520801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.462 {time zone boundary case 2043-03-08 01:59:59} {detroit y2038} { clock format 2309410799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.463 {time zone boundary case 2043-03-08 03:00:00} {detroit y2038} { clock format 2309410800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.464 {time zone boundary case 2043-03-08 03:00:01} {detroit y2038} { clock format 2309410801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.465 {time zone boundary case 2043-11-01 01:59:59} {detroit y2038} { clock format 2329970399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.466 {time zone boundary case 2043-11-01 01:00:00} {detroit y2038} { clock format 2329970400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.467 {time zone boundary case 2043-11-01 01:00:01} {detroit y2038} { clock format 2329970401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.468 {time zone boundary case 2044-03-13 01:59:59} {detroit y2038} { clock format 2341465199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.469 {time zone boundary case 2044-03-13 03:00:00} {detroit y2038} { clock format 2341465200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.470 {time zone boundary case 2044-03-13 03:00:01} {detroit y2038} { clock format 2341465201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.471 {time zone boundary case 2044-11-06 01:59:59} {detroit y2038} { clock format 2362024799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.472 {time zone boundary case 2044-11-06 01:00:00} {detroit y2038} { clock format 2362024800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.473 {time zone boundary case 2044-11-06 01:00:01} {detroit y2038} { clock format 2362024801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.474 {time zone boundary case 2045-03-12 01:59:59} {detroit y2038} { clock format 2372914799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.475 {time zone boundary case 2045-03-12 03:00:00} {detroit y2038} { clock format 2372914800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.476 {time zone boundary case 2045-03-12 03:00:01} {detroit y2038} { clock format 2372914801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.477 {time zone boundary case 2045-11-05 01:59:59} {detroit y2038} { clock format 2393474399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.478 {time zone boundary case 2045-11-05 01:00:00} {detroit y2038} { clock format 2393474400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.479 {time zone boundary case 2045-11-05 01:00:01} {detroit y2038} { clock format 2393474401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.480 {time zone boundary case 2046-03-11 01:59:59} {detroit y2038} { clock format 2404364399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.481 {time zone boundary case 2046-03-11 03:00:00} {detroit y2038} { clock format 2404364400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.482 {time zone boundary case 2046-03-11 03:00:01} {detroit y2038} { clock format 2404364401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.483 {time zone boundary case 2046-11-04 01:59:59} {detroit y2038} { clock format 2424923999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.484 {time zone boundary case 2046-11-04 01:00:00} {detroit y2038} { clock format 2424924000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.485 {time zone boundary case 2046-11-04 01:00:01} {detroit y2038} { clock format 2424924001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.486 {time zone boundary case 2047-03-10 01:59:59} {detroit y2038} { clock format 2435813999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.487 {time zone boundary case 2047-03-10 03:00:00} {detroit y2038} { clock format 2435814000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.488 {time zone boundary case 2047-03-10 03:00:01} {detroit y2038} { clock format 2435814001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.489 {time zone boundary case 2047-11-03 01:59:59} {detroit y2038} { clock format 2456373599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.490 {time zone boundary case 2047-11-03 01:00:00} {detroit y2038} { clock format 2456373600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.491 {time zone boundary case 2047-11-03 01:00:01} {detroit y2038} { clock format 2456373601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.492 {time zone boundary case 2048-03-08 01:59:59} {detroit y2038} { clock format 2467263599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.493 {time zone boundary case 2048-03-08 03:00:00} {detroit y2038} { clock format 2467263600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.494 {time zone boundary case 2048-03-08 03:00:01} {detroit y2038} { clock format 2467263601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.495 {time zone boundary case 2048-11-01 01:59:59} {detroit y2038} { clock format 2487823199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.496 {time zone boundary case 2048-11-01 01:00:00} {detroit y2038} { clock format 2487823200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.497 {time zone boundary case 2048-11-01 01:00:01} {detroit y2038} { clock format 2487823201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.498 {time zone boundary case 2049-03-14 01:59:59} {detroit y2038} { clock format 2499317999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.499 {time zone boundary case 2049-03-14 03:00:00} {detroit y2038} { clock format 2499318000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.500 {time zone boundary case 2049-03-14 03:00:01} {detroit y2038} { clock format 2499318001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.501 {time zone boundary case 2049-11-07 01:59:59} {detroit y2038} { clock format 2519877599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.502 {time zone boundary case 2049-11-07 01:00:00} {detroit y2038} { clock format 2519877600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.503 {time zone boundary case 2049-11-07 01:00:01} {detroit y2038} { clock format 2519877601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.504 {time zone boundary case 2050-03-13 01:59:59} {detroit y2038} { clock format 2530767599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.505 {time zone boundary case 2050-03-13 03:00:00} {detroit y2038} { clock format 2530767600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.506 {time zone boundary case 2050-03-13 03:00:01} {detroit y2038} { clock format 2530767601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.507 {time zone boundary case 2050-11-06 01:59:59} {detroit y2038} { clock format 2551327199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.508 {time zone boundary case 2050-11-06 01:00:00} {detroit y2038} { clock format 2551327200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.509 {time zone boundary case 2050-11-06 01:00:01} {detroit y2038} { clock format 2551327201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.510 {time zone boundary case 2051-03-12 01:59:59} {detroit y2038} { clock format 2562217199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.511 {time zone boundary case 2051-03-12 03:00:00} {detroit y2038} { clock format 2562217200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.512 {time zone boundary case 2051-03-12 03:00:01} {detroit y2038} { clock format 2562217201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.513 {time zone boundary case 2051-11-05 01:59:59} {detroit y2038} { clock format 2582776799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.514 {time zone boundary case 2051-11-05 01:00:00} {detroit y2038} { clock format 2582776800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.515 {time zone boundary case 2051-11-05 01:00:01} {detroit y2038} { clock format 2582776801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.516 {time zone boundary case 2052-03-10 01:59:59} {detroit y2038} { clock format 2593666799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.517 {time zone boundary case 2052-03-10 03:00:00} {detroit y2038} { clock format 2593666800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.518 {time zone boundary case 2052-03-10 03:00:01} {detroit y2038} { clock format 2593666801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.519 {time zone boundary case 2052-11-03 01:59:59} {detroit y2038} { clock format 2614226399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.520 {time zone boundary case 2052-11-03 01:00:00} {detroit y2038} { clock format 2614226400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.521 {time zone boundary case 2052-11-03 01:00:01} {detroit y2038} { clock format 2614226401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.522 {time zone boundary case 2053-03-09 01:59:59} {detroit y2038} { clock format 2625116399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.523 {time zone boundary case 2053-03-09 03:00:00} {detroit y2038} { clock format 2625116400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.524 {time zone boundary case 2053-03-09 03:00:01} {detroit y2038} { clock format 2625116401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.525 {time zone boundary case 2053-11-02 01:59:59} {detroit y2038} { clock format 2645675999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.526 {time zone boundary case 2053-11-02 01:00:00} {detroit y2038} { clock format 2645676000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.527 {time zone boundary case 2053-11-02 01:00:01} {detroit y2038} { clock format 2645676001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.528 {time zone boundary case 2054-03-08 01:59:59} {detroit y2038} { clock format 2656565999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.529 {time zone boundary case 2054-03-08 03:00:00} {detroit y2038} { clock format 2656566000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.530 {time zone boundary case 2054-03-08 03:00:01} {detroit y2038} { clock format 2656566001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.531 {time zone boundary case 2054-11-01 01:59:59} {detroit y2038} { clock format 2677125599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.532 {time zone boundary case 2054-11-01 01:00:00} {detroit y2038} { clock format 2677125600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.533 {time zone boundary case 2054-11-01 01:00:01} {detroit y2038} { clock format 2677125601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.534 {time zone boundary case 2055-03-14 01:59:59} {detroit y2038} { clock format 2688620399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.535 {time zone boundary case 2055-03-14 03:00:00} {detroit y2038} { clock format 2688620400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.536 {time zone boundary case 2055-03-14 03:00:01} {detroit y2038} { clock format 2688620401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.537 {time zone boundary case 2055-11-07 01:59:59} {detroit y2038} { clock format 2709179999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.538 {time zone boundary case 2055-11-07 01:00:00} {detroit y2038} { clock format 2709180000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.539 {time zone boundary case 2055-11-07 01:00:01} {detroit y2038} { clock format 2709180001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.540 {time zone boundary case 2056-03-12 01:59:59} {detroit y2038} { clock format 2720069999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.541 {time zone boundary case 2056-03-12 03:00:00} {detroit y2038} { clock format 2720070000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.542 {time zone boundary case 2056-03-12 03:00:01} {detroit y2038} { clock format 2720070001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.543 {time zone boundary case 2056-11-05 01:59:59} {detroit y2038} { clock format 2740629599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.544 {time zone boundary case 2056-11-05 01:00:00} {detroit y2038} { clock format 2740629600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.545 {time zone boundary case 2056-11-05 01:00:01} {detroit y2038} { clock format 2740629601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.546 {time zone boundary case 2057-03-11 01:59:59} {detroit y2038} { clock format 2751519599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.547 {time zone boundary case 2057-03-11 03:00:00} {detroit y2038} { clock format 2751519600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.548 {time zone boundary case 2057-03-11 03:00:01} {detroit y2038} { clock format 2751519601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.549 {time zone boundary case 2057-11-04 01:59:59} {detroit y2038} { clock format 2772079199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.550 {time zone boundary case 2057-11-04 01:00:00} {detroit y2038} { clock format 2772079200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.551 {time zone boundary case 2057-11-04 01:00:01} {detroit y2038} { clock format 2772079201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.552 {time zone boundary case 2058-03-10 01:59:59} {detroit y2038} { clock format 2782969199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.553 {time zone boundary case 2058-03-10 03:00:00} {detroit y2038} { clock format 2782969200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.554 {time zone boundary case 2058-03-10 03:00:01} {detroit y2038} { clock format 2782969201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.555 {time zone boundary case 2058-11-03 01:59:59} {detroit y2038} { clock format 2803528799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.556 {time zone boundary case 2058-11-03 01:00:00} {detroit y2038} { clock format 2803528800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.557 {time zone boundary case 2058-11-03 01:00:01} {detroit y2038} { clock format 2803528801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.558 {time zone boundary case 2059-03-09 01:59:59} {detroit y2038} { clock format 2814418799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.559 {time zone boundary case 2059-03-09 03:00:00} {detroit y2038} { clock format 2814418800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.560 {time zone boundary case 2059-03-09 03:00:01} {detroit y2038} { clock format 2814418801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.561 {time zone boundary case 2059-11-02 01:59:59} {detroit y2038} { clock format 2834978399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.562 {time zone boundary case 2059-11-02 01:00:00} {detroit y2038} { clock format 2834978400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.563 {time zone boundary case 2059-11-02 01:00:01} {detroit y2038} { clock format 2834978401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.564 {time zone boundary case 2060-03-14 01:59:59} {detroit y2038} { clock format 2846473199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.565 {time zone boundary case 2060-03-14 03:00:00} {detroit y2038} { clock format 2846473200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.566 {time zone boundary case 2060-03-14 03:00:01} {detroit y2038} { clock format 2846473201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.567 {time zone boundary case 2060-11-07 01:59:59} {detroit y2038} { clock format 2867032799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.568 {time zone boundary case 2060-11-07 01:00:00} {detroit y2038} { clock format 2867032800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.569 {time zone boundary case 2060-11-07 01:00:01} {detroit y2038} { clock format 2867032801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.570 {time zone boundary case 2061-03-13 01:59:59} {detroit y2038} { clock format 2877922799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.571 {time zone boundary case 2061-03-13 03:00:00} {detroit y2038} { clock format 2877922800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.572 {time zone boundary case 2061-03-13 03:00:01} {detroit y2038} { clock format 2877922801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.573 {time zone boundary case 2061-11-06 01:59:59} {detroit y2038} { clock format 2898482399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.574 {time zone boundary case 2061-11-06 01:00:00} {detroit y2038} { clock format 2898482400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.575 {time zone boundary case 2061-11-06 01:00:01} {detroit y2038} { clock format 2898482401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.576 {time zone boundary case 2062-03-12 01:59:59} {detroit y2038} { clock format 2909372399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.577 {time zone boundary case 2062-03-12 03:00:00} {detroit y2038} { clock format 2909372400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.578 {time zone boundary case 2062-03-12 03:00:01} {detroit y2038} { clock format 2909372401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.579 {time zone boundary case 2062-11-05 01:59:59} {detroit y2038} { clock format 2929931999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.580 {time zone boundary case 2062-11-05 01:00:00} {detroit y2038} { clock format 2929932000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.581 {time zone boundary case 2062-11-05 01:00:01} {detroit y2038} { clock format 2929932001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.582 {time zone boundary case 2063-03-11 01:59:59} {detroit y2038} { clock format 2940821999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.583 {time zone boundary case 2063-03-11 03:00:00} {detroit y2038} { clock format 2940822000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.584 {time zone boundary case 2063-03-11 03:00:01} {detroit y2038} { clock format 2940822001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.585 {time zone boundary case 2063-11-04 01:59:59} {detroit y2038} { clock format 2961381599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.586 {time zone boundary case 2063-11-04 01:00:00} {detroit y2038} { clock format 2961381600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.587 {time zone boundary case 2063-11-04 01:00:01} {detroit y2038} { clock format 2961381601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.588 {time zone boundary case 2064-03-09 01:59:59} {detroit y2038} { clock format 2972271599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.589 {time zone boundary case 2064-03-09 03:00:00} {detroit y2038} { clock format 2972271600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.590 {time zone boundary case 2064-03-09 03:00:01} {detroit y2038} { clock format 2972271601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.591 {time zone boundary case 2064-11-02 01:59:59} {detroit y2038} { clock format 2992831199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.592 {time zone boundary case 2064-11-02 01:00:00} {detroit y2038} { clock format 2992831200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.593 {time zone boundary case 2064-11-02 01:00:01} {detroit y2038} { clock format 2992831201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.594 {time zone boundary case 2065-03-08 01:59:59} {detroit y2038} { clock format 3003721199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.595 {time zone boundary case 2065-03-08 03:00:00} {detroit y2038} { clock format 3003721200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.596 {time zone boundary case 2065-03-08 03:00:01} {detroit y2038} { clock format 3003721201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.597 {time zone boundary case 2065-11-01 01:59:59} {detroit y2038} { clock format 3024280799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.598 {time zone boundary case 2065-11-01 01:00:00} {detroit y2038} { clock format 3024280800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.599 {time zone boundary case 2065-11-01 01:00:01} {detroit y2038} { clock format 3024280801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.600 {time zone boundary case 2066-03-14 01:59:59} {detroit y2038} { clock format 3035775599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.601 {time zone boundary case 2066-03-14 03:00:00} {detroit y2038} { clock format 3035775600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.602 {time zone boundary case 2066-03-14 03:00:01} {detroit y2038} { clock format 3035775601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.603 {time zone boundary case 2066-11-07 01:59:59} {detroit y2038} { clock format 3056335199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.604 {time zone boundary case 2066-11-07 01:00:00} {detroit y2038} { clock format 3056335200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.605 {time zone boundary case 2066-11-07 01:00:01} {detroit y2038} { clock format 3056335201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.606 {time zone boundary case 2067-03-13 01:59:59} {detroit y2038} { clock format 3067225199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.607 {time zone boundary case 2067-03-13 03:00:00} {detroit y2038} { clock format 3067225200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.608 {time zone boundary case 2067-03-13 03:00:01} {detroit y2038} { clock format 3067225201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.609 {time zone boundary case 2067-11-06 01:59:59} {detroit y2038} { clock format 3087784799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.610 {time zone boundary case 2067-11-06 01:00:00} {detroit y2038} { clock format 3087784800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.611 {time zone boundary case 2067-11-06 01:00:01} {detroit y2038} { clock format 3087784801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.612 {time zone boundary case 2068-03-11 01:59:59} {detroit y2038} { clock format 3098674799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.613 {time zone boundary case 2068-03-11 03:00:00} {detroit y2038} { clock format 3098674800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.614 {time zone boundary case 2068-03-11 03:00:01} {detroit y2038} { clock format 3098674801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.615 {time zone boundary case 2068-11-04 01:59:59} {detroit y2038} { clock format 3119234399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.616 {time zone boundary case 2068-11-04 01:00:00} {detroit y2038} { clock format 3119234400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.617 {time zone boundary case 2068-11-04 01:00:01} {detroit y2038} { clock format 3119234401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.618 {time zone boundary case 2069-03-10 01:59:59} {detroit y2038} { clock format 3130124399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.619 {time zone boundary case 2069-03-10 03:00:00} {detroit y2038} { clock format 3130124400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.620 {time zone boundary case 2069-03-10 03:00:01} {detroit y2038} { clock format 3130124401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.621 {time zone boundary case 2069-11-03 01:59:59} {detroit y2038} { clock format 3150683999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.622 {time zone boundary case 2069-11-03 01:00:00} {detroit y2038} { clock format 3150684000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.623 {time zone boundary case 2069-11-03 01:00:01} {detroit y2038} { clock format 3150684001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.624 {time zone boundary case 2070-03-09 01:59:59} {detroit y2038} { clock format 3161573999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.625 {time zone boundary case 2070-03-09 03:00:00} {detroit y2038} { clock format 3161574000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.626 {time zone boundary case 2070-03-09 03:00:01} {detroit y2038} { clock format 3161574001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.627 {time zone boundary case 2070-11-02 01:59:59} {detroit y2038} { clock format 3182133599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.628 {time zone boundary case 2070-11-02 01:00:00} {detroit y2038} { clock format 3182133600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.629 {time zone boundary case 2070-11-02 01:00:01} {detroit y2038} { clock format 3182133601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.630 {time zone boundary case 2071-03-08 01:59:59} {detroit y2038} { clock format 3193023599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.631 {time zone boundary case 2071-03-08 03:00:00} {detroit y2038} { clock format 3193023600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.632 {time zone boundary case 2071-03-08 03:00:01} {detroit y2038} { clock format 3193023601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.633 {time zone boundary case 2071-11-01 01:59:59} {detroit y2038} { clock format 3213583199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.634 {time zone boundary case 2071-11-01 01:00:00} {detroit y2038} { clock format 3213583200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.635 {time zone boundary case 2071-11-01 01:00:01} {detroit y2038} { clock format 3213583201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.636 {time zone boundary case 2072-03-13 01:59:59} {detroit y2038} { clock format 3225077999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.637 {time zone boundary case 2072-03-13 03:00:00} {detroit y2038} { clock format 3225078000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.638 {time zone boundary case 2072-03-13 03:00:01} {detroit y2038} { clock format 3225078001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.639 {time zone boundary case 2072-11-06 01:59:59} {detroit y2038} { clock format 3245637599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.640 {time zone boundary case 2072-11-06 01:00:00} {detroit y2038} { clock format 3245637600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.641 {time zone boundary case 2072-11-06 01:00:01} {detroit y2038} { clock format 3245637601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.642 {time zone boundary case 2073-03-12 01:59:59} {detroit y2038} { clock format 3256527599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.643 {time zone boundary case 2073-03-12 03:00:00} {detroit y2038} { clock format 3256527600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.644 {time zone boundary case 2073-03-12 03:00:01} {detroit y2038} { clock format 3256527601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.645 {time zone boundary case 2073-11-05 01:59:59} {detroit y2038} { clock format 3277087199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.646 {time zone boundary case 2073-11-05 01:00:00} {detroit y2038} { clock format 3277087200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.647 {time zone boundary case 2073-11-05 01:00:01} {detroit y2038} { clock format 3277087201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.648 {time zone boundary case 2074-03-11 01:59:59} {detroit y2038} { clock format 3287977199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.649 {time zone boundary case 2074-03-11 03:00:00} {detroit y2038} { clock format 3287977200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.650 {time zone boundary case 2074-03-11 03:00:01} {detroit y2038} { clock format 3287977201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.651 {time zone boundary case 2074-11-04 01:59:59} {detroit y2038} { clock format 3308536799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.652 {time zone boundary case 2074-11-04 01:00:00} {detroit y2038} { clock format 3308536800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.653 {time zone boundary case 2074-11-04 01:00:01} {detroit y2038} { clock format 3308536801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.654 {time zone boundary case 2075-03-10 01:59:59} {detroit y2038} { clock format 3319426799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.655 {time zone boundary case 2075-03-10 03:00:00} {detroit y2038} { clock format 3319426800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.656 {time zone boundary case 2075-03-10 03:00:01} {detroit y2038} { clock format 3319426801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.657 {time zone boundary case 2075-11-03 01:59:59} {detroit y2038} { clock format 3339986399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.658 {time zone boundary case 2075-11-03 01:00:00} {detroit y2038} { clock format 3339986400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.659 {time zone boundary case 2075-11-03 01:00:01} {detroit y2038} { clock format 3339986401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.660 {time zone boundary case 2076-03-08 01:59:59} {detroit y2038} { clock format 3350876399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.661 {time zone boundary case 2076-03-08 03:00:00} {detroit y2038} { clock format 3350876400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.662 {time zone boundary case 2076-03-08 03:00:01} {detroit y2038} { clock format 3350876401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.663 {time zone boundary case 2076-11-01 01:59:59} {detroit y2038} { clock format 3371435999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.664 {time zone boundary case 2076-11-01 01:00:00} {detroit y2038} { clock format 3371436000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.665 {time zone boundary case 2076-11-01 01:00:01} {detroit y2038} { clock format 3371436001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.666 {time zone boundary case 2077-03-14 01:59:59} {detroit y2038} { clock format 3382930799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.667 {time zone boundary case 2077-03-14 03:00:00} {detroit y2038} { clock format 3382930800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.668 {time zone boundary case 2077-03-14 03:00:01} {detroit y2038} { clock format 3382930801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.669 {time zone boundary case 2077-11-07 01:59:59} {detroit y2038} { clock format 3403490399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.670 {time zone boundary case 2077-11-07 01:00:00} {detroit y2038} { clock format 3403490400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.671 {time zone boundary case 2077-11-07 01:00:01} {detroit y2038} { clock format 3403490401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.672 {time zone boundary case 2078-03-13 01:59:59} {detroit y2038} { clock format 3414380399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.673 {time zone boundary case 2078-03-13 03:00:00} {detroit y2038} { clock format 3414380400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.674 {time zone boundary case 2078-03-13 03:00:01} {detroit y2038} { clock format 3414380401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.675 {time zone boundary case 2078-11-06 01:59:59} {detroit y2038} { clock format 3434939999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.676 {time zone boundary case 2078-11-06 01:00:00} {detroit y2038} { clock format 3434940000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.677 {time zone boundary case 2078-11-06 01:00:01} {detroit y2038} { clock format 3434940001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.678 {time zone boundary case 2079-03-12 01:59:59} {detroit y2038} { clock format 3445829999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.679 {time zone boundary case 2079-03-12 03:00:00} {detroit y2038} { clock format 3445830000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.680 {time zone boundary case 2079-03-12 03:00:01} {detroit y2038} { clock format 3445830001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.681 {time zone boundary case 2079-11-05 01:59:59} {detroit y2038} { clock format 3466389599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.682 {time zone boundary case 2079-11-05 01:00:00} {detroit y2038} { clock format 3466389600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.683 {time zone boundary case 2079-11-05 01:00:01} {detroit y2038} { clock format 3466389601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.684 {time zone boundary case 2080-03-10 01:59:59} {detroit y2038} { clock format 3477279599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.685 {time zone boundary case 2080-03-10 03:00:00} {detroit y2038} { clock format 3477279600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.686 {time zone boundary case 2080-03-10 03:00:01} {detroit y2038} { clock format 3477279601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.687 {time zone boundary case 2080-11-03 01:59:59} {detroit y2038} { clock format 3497839199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.688 {time zone boundary case 2080-11-03 01:00:00} {detroit y2038} { clock format 3497839200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.689 {time zone boundary case 2080-11-03 01:00:01} {detroit y2038} { clock format 3497839201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.690 {time zone boundary case 2081-03-09 01:59:59} {detroit y2038} { clock format 3508729199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.691 {time zone boundary case 2081-03-09 03:00:00} {detroit y2038} { clock format 3508729200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.692 {time zone boundary case 2081-03-09 03:00:01} {detroit y2038} { clock format 3508729201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.693 {time zone boundary case 2081-11-02 01:59:59} {detroit y2038} { clock format 3529288799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.694 {time zone boundary case 2081-11-02 01:00:00} {detroit y2038} { clock format 3529288800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.695 {time zone boundary case 2081-11-02 01:00:01} {detroit y2038} { clock format 3529288801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.696 {time zone boundary case 2082-03-08 01:59:59} {detroit y2038} { clock format 3540178799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.697 {time zone boundary case 2082-03-08 03:00:00} {detroit y2038} { clock format 3540178800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.698 {time zone boundary case 2082-03-08 03:00:01} {detroit y2038} { clock format 3540178801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.699 {time zone boundary case 2082-11-01 01:59:59} {detroit y2038} { clock format 3560738399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.700 {time zone boundary case 2082-11-01 01:00:00} {detroit y2038} { clock format 3560738400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.701 {time zone boundary case 2082-11-01 01:00:01} {detroit y2038} { clock format 3560738401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.702 {time zone boundary case 2083-03-14 01:59:59} {detroit y2038} { clock format 3572233199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.703 {time zone boundary case 2083-03-14 03:00:00} {detroit y2038} { clock format 3572233200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.704 {time zone boundary case 2083-03-14 03:00:01} {detroit y2038} { clock format 3572233201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.705 {time zone boundary case 2083-11-07 01:59:59} {detroit y2038} { clock format 3592792799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.706 {time zone boundary case 2083-11-07 01:00:00} {detroit y2038} { clock format 3592792800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.707 {time zone boundary case 2083-11-07 01:00:01} {detroit y2038} { clock format 3592792801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.708 {time zone boundary case 2084-03-12 01:59:59} {detroit y2038} { clock format 3603682799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.709 {time zone boundary case 2084-03-12 03:00:00} {detroit y2038} { clock format 3603682800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.710 {time zone boundary case 2084-03-12 03:00:01} {detroit y2038} { clock format 3603682801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.711 {time zone boundary case 2084-11-05 01:59:59} {detroit y2038} { clock format 3624242399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.712 {time zone boundary case 2084-11-05 01:00:00} {detroit y2038} { clock format 3624242400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.713 {time zone boundary case 2084-11-05 01:00:01} {detroit y2038} { clock format 3624242401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.714 {time zone boundary case 2085-03-11 01:59:59} {detroit y2038} { clock format 3635132399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.715 {time zone boundary case 2085-03-11 03:00:00} {detroit y2038} { clock format 3635132400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.716 {time zone boundary case 2085-03-11 03:00:01} {detroit y2038} { clock format 3635132401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.717 {time zone boundary case 2085-11-04 01:59:59} {detroit y2038} { clock format 3655691999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.718 {time zone boundary case 2085-11-04 01:00:00} {detroit y2038} { clock format 3655692000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.719 {time zone boundary case 2085-11-04 01:00:01} {detroit y2038} { clock format 3655692001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.720 {time zone boundary case 2086-03-10 01:59:59} {detroit y2038} { clock format 3666581999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.721 {time zone boundary case 2086-03-10 03:00:00} {detroit y2038} { clock format 3666582000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.722 {time zone boundary case 2086-03-10 03:00:01} {detroit y2038} { clock format 3666582001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.723 {time zone boundary case 2086-11-03 01:59:59} {detroit y2038} { clock format 3687141599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.724 {time zone boundary case 2086-11-03 01:00:00} {detroit y2038} { clock format 3687141600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.725 {time zone boundary case 2086-11-03 01:00:01} {detroit y2038} { clock format 3687141601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.726 {time zone boundary case 2087-03-09 01:59:59} {detroit y2038} { clock format 3698031599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.727 {time zone boundary case 2087-03-09 03:00:00} {detroit y2038} { clock format 3698031600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.728 {time zone boundary case 2087-03-09 03:00:01} {detroit y2038} { clock format 3698031601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.729 {time zone boundary case 2087-11-02 01:59:59} {detroit y2038} { clock format 3718591199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.730 {time zone boundary case 2087-11-02 01:00:00} {detroit y2038} { clock format 3718591200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.731 {time zone boundary case 2087-11-02 01:00:01} {detroit y2038} { clock format 3718591201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.732 {time zone boundary case 2088-03-14 01:59:59} {detroit y2038} { clock format 3730085999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.733 {time zone boundary case 2088-03-14 03:00:00} {detroit y2038} { clock format 3730086000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.734 {time zone boundary case 2088-03-14 03:00:01} {detroit y2038} { clock format 3730086001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.735 {time zone boundary case 2088-11-07 01:59:59} {detroit y2038} { clock format 3750645599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.736 {time zone boundary case 2088-11-07 01:00:00} {detroit y2038} { clock format 3750645600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.737 {time zone boundary case 2088-11-07 01:00:01} {detroit y2038} { clock format 3750645601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.738 {time zone boundary case 2089-03-13 01:59:59} {detroit y2038} { clock format 3761535599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.739 {time zone boundary case 2089-03-13 03:00:00} {detroit y2038} { clock format 3761535600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.740 {time zone boundary case 2089-03-13 03:00:01} {detroit y2038} { clock format 3761535601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.741 {time zone boundary case 2089-11-06 01:59:59} {detroit y2038} { clock format 3782095199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.742 {time zone boundary case 2089-11-06 01:00:00} {detroit y2038} { clock format 3782095200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.743 {time zone boundary case 2089-11-06 01:00:01} {detroit y2038} { clock format 3782095201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.744 {time zone boundary case 2090-03-12 01:59:59} {detroit y2038} { clock format 3792985199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.745 {time zone boundary case 2090-03-12 03:00:00} {detroit y2038} { clock format 3792985200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.746 {time zone boundary case 2090-03-12 03:00:01} {detroit y2038} { clock format 3792985201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.747 {time zone boundary case 2090-11-05 01:59:59} {detroit y2038} { clock format 3813544799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.748 {time zone boundary case 2090-11-05 01:00:00} {detroit y2038} { clock format 3813544800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.749 {time zone boundary case 2090-11-05 01:00:01} {detroit y2038} { clock format 3813544801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.750 {time zone boundary case 2091-03-11 01:59:59} {detroit y2038} { clock format 3824434799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.751 {time zone boundary case 2091-03-11 03:00:00} {detroit y2038} { clock format 3824434800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.752 {time zone boundary case 2091-03-11 03:00:01} {detroit y2038} { clock format 3824434801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.753 {time zone boundary case 2091-11-04 01:59:59} {detroit y2038} { clock format 3844994399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.754 {time zone boundary case 2091-11-04 01:00:00} {detroit y2038} { clock format 3844994400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.755 {time zone boundary case 2091-11-04 01:00:01} {detroit y2038} { clock format 3844994401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.756 {time zone boundary case 2092-03-09 01:59:59} {detroit y2038} { clock format 3855884399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.757 {time zone boundary case 2092-03-09 03:00:00} {detroit y2038} { clock format 3855884400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.758 {time zone boundary case 2092-03-09 03:00:01} {detroit y2038} { clock format 3855884401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.759 {time zone boundary case 2092-11-02 01:59:59} {detroit y2038} { clock format 3876443999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.760 {time zone boundary case 2092-11-02 01:00:00} {detroit y2038} { clock format 3876444000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.761 {time zone boundary case 2092-11-02 01:00:01} {detroit y2038} { clock format 3876444001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.762 {time zone boundary case 2093-03-08 01:59:59} {detroit y2038} { clock format 3887333999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.763 {time zone boundary case 2093-03-08 03:00:00} {detroit y2038} { clock format 3887334000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.764 {time zone boundary case 2093-03-08 03:00:01} {detroit y2038} { clock format 3887334001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.765 {time zone boundary case 2093-11-01 01:59:59} {detroit y2038} { clock format 3907893599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.766 {time zone boundary case 2093-11-01 01:00:00} {detroit y2038} { clock format 3907893600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.767 {time zone boundary case 2093-11-01 01:00:01} {detroit y2038} { clock format 3907893601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.768 {time zone boundary case 2094-03-14 01:59:59} {detroit y2038} { clock format 3919388399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.769 {time zone boundary case 2094-03-14 03:00:00} {detroit y2038} { clock format 3919388400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.770 {time zone boundary case 2094-03-14 03:00:01} {detroit y2038} { clock format 3919388401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.771 {time zone boundary case 2094-11-07 01:59:59} {detroit y2038} { clock format 3939947999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.772 {time zone boundary case 2094-11-07 01:00:00} {detroit y2038} { clock format 3939948000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.773 {time zone boundary case 2094-11-07 01:00:01} {detroit y2038} { clock format 3939948001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.774 {time zone boundary case 2095-03-13 01:59:59} {detroit y2038} { clock format 3950837999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.775 {time zone boundary case 2095-03-13 03:00:00} {detroit y2038} { clock format 3950838000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.776 {time zone boundary case 2095-03-13 03:00:01} {detroit y2038} { clock format 3950838001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.777 {time zone boundary case 2095-11-06 01:59:59} {detroit y2038} { clock format 3971397599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.778 {time zone boundary case 2095-11-06 01:00:00} {detroit y2038} { clock format 3971397600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.779 {time zone boundary case 2095-11-06 01:00:01} {detroit y2038} { clock format 3971397601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.780 {time zone boundary case 2096-03-11 01:59:59} {detroit y2038} { clock format 3982287599 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.781 {time zone boundary case 2096-03-11 03:00:00} {detroit y2038} { clock format 3982287600 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.782 {time zone boundary case 2096-03-11 03:00:01} {detroit y2038} { clock format 3982287601 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.783 {time zone boundary case 2096-11-04 01:59:59} {detroit y2038} { clock format 4002847199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.784 {time zone boundary case 2096-11-04 01:00:00} {detroit y2038} { clock format 4002847200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.785 {time zone boundary case 2096-11-04 01:00:01} {detroit y2038} { clock format 4002847201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.786 {time zone boundary case 2097-03-10 01:59:59} {detroit y2038} { clock format 4013737199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.787 {time zone boundary case 2097-03-10 03:00:00} {detroit y2038} { clock format 4013737200 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.788 {time zone boundary case 2097-03-10 03:00:01} {detroit y2038} { clock format 4013737201 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.789 {time zone boundary case 2097-11-03 01:59:59} {detroit y2038} { clock format 4034296799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.790 {time zone boundary case 2097-11-03 01:00:00} {detroit y2038} { clock format 4034296800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.791 {time zone boundary case 2097-11-03 01:00:01} {detroit y2038} { clock format 4034296801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.792 {time zone boundary case 2098-03-09 01:59:59} {detroit y2038} { clock format 4045186799 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.793 {time zone boundary case 2098-03-09 03:00:00} {detroit y2038} { clock format 4045186800 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.794 {time zone boundary case 2098-03-09 03:00:01} {detroit y2038} { clock format 4045186801 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.795 {time zone boundary case 2098-11-02 01:59:59} {detroit y2038} { clock format 4065746399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.796 {time zone boundary case 2098-11-02 01:00:00} {detroit y2038} { clock format 4065746400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.797 {time zone boundary case 2098-11-02 01:00:01} {detroit y2038} { clock format 4065746401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} test clock-5.798 {time zone boundary case 2099-03-08 01:59:59} {detroit y2038} { clock format 4076636399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0500 EST} test clock-5.799 {time zone boundary case 2099-03-08 03:00:00} {detroit y2038} { clock format 4076636400 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:00 -0400 EDT} test clock-5.800 {time zone boundary case 2099-03-08 03:00:01} {detroit y2038} { clock format 4076636401 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {03:00:01 -0400 EDT} test clock-5.801 {time zone boundary case 2099-11-01 01:59:59} {detroit y2038} { clock format 4097195999 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:59:59 -0400 EDT} test clock-5.802 {time zone boundary case 2099-11-01 01:00:00} {detroit y2038} { clock format 4097196000 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:00 -0500 EST} test clock-5.803 {time zone boundary case 2099-11-01 01:00:01} {detroit y2038} { clock format 4097196001 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} # END testcases5 # Test input conversions. test clock-6.0 {input of seconds} { |
︙ | ︙ | |||
35325 35326 35327 35328 35329 35330 35331 | unset oldTZ } else { unset env(TZ) } } \ -result {-0500} | | < < < | < < < < < < < < < < < < < < < | 35327 35328 35329 35330 35331 35332 35333 35334 35335 35336 35337 35338 35339 35340 35341 35342 | unset oldTZ } else { unset env(TZ) } } \ -result {-0500} # 43.1 was a bad test - mktime returning -1 is an error according to posix. test clock-44.1 {regression test - time zone name containing hyphen } \ -setup { if { [info exists env(TZ)] } { set oldTZ $env(TZ) } set env(TZ) US/East-Indiana } \ |
︙ | ︙ | |||
35370 35371 35372 35373 35374 35375 35376 35377 35378 35379 35380 35381 35382 35383 35384 35385 35386 35387 | -result {12:34:56-0500} test clock-45.1 {regression test - time zone containing only two digits} \ -body { clock scan 1985-04-12T10:15:30+04 -format %Y-%m-%dT%H:%M:%S%Z } \ -result 482134530 # cleanup namespace delete ::testClock ::tcl::clock::ClearCaches ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 35354 35355 35356 35357 35358 35359 35360 35361 35362 35363 35364 35365 35366 35367 35368 35369 35370 35371 35372 35373 35374 35375 35376 35377 35378 35379 35380 35381 35382 35383 35384 35385 35386 35387 35388 35389 35390 35391 35392 35393 35394 35395 35396 35397 35398 35399 35400 35401 35402 35403 35404 35405 35406 35407 35408 35409 35410 35411 35412 35413 35414 35415 35416 35417 35418 35419 35420 35421 35422 35423 35424 35425 35426 35427 35428 35429 35430 35431 35432 35433 35434 35435 35436 35437 35438 35439 35440 35441 35442 35443 35444 35445 35446 35447 35448 35449 35450 35451 35452 35453 35454 35455 35456 35457 35458 35459 35460 35461 35462 35463 35464 35465 35466 35467 35468 35469 35470 35471 35472 35473 35474 35475 35476 35477 35478 35479 35480 35481 35482 35483 35484 35485 35486 | -result {12:34:56-0500} test clock-45.1 {regression test - time zone containing only two digits} \ -body { clock scan 1985-04-12T10:15:30+04 -format %Y-%m-%dT%H:%M:%S%Z } \ -result 482134530 test clock-46.1 {regression test - month zero} \ -body { clock scan 2004-00-00 -format %Y-%m-%d } -result [clock scan 2003-11-30 -format %Y-%m-%d] test clock-46.2 {regression test - month zero} \ -body { clock scan 20040000 } -result [clock scan 2003-11-30 -format %Y-%m-%d] test clock-46.3 {regression test - month thirteen} \ -body { clock scan 2004-13-01 -format %Y-%m-%d } -result [clock scan 2005-01-01 -format %Y-%m-%d] test clock-46.4 {regression test - month thirteen} \ -body { clock scan 20041301 } -result [clock scan 2005-01-01 -format %Y-%m-%d] test clock-47.1 {regression test - four-digit time} { clock scan 0012 } [clock scan 0012 -format %H%M] test clock-47.2 {regression test - four digit time} { clock scan 0039 } [clock scan 0039 -format %H%M] test clock-48.1 {Bug 1185933: 'i' destroyed by clock init} -setup { interp create child } -body { interp eval child { set i 12345 clock format 0 list [catch { set i } result] $result } } -cleanup { interp delete child } -result {0 12345} test clock-49.1 {regression test - localtime with negative arg (Bug 1237907)} \ -body { list [catch { clock format -86400 -timezone :localtime -format %Y } result] $result } \ -match regexp \ -result {0 1969|1 {localtime failed \(clock value may be too large/small to represent\)}} test clock-49.2 {regression test - missing time zone file (Bug 1237907)} \ -constraints win \ -setup { # override the registry so that the test takes place in New York time namespace eval ::tcl::clock { namespace import -force ::testClock::registry } if { [info exists env(TZ)] } { set oldTZ $env(TZ) unset env(TZ) } if { [info exists env(TCL_TZ)] } { set oldTclTZ $env(TCL_TZ) unset env(TCL_TZ) } # make it so New York time is a missing file dict set ::tcl::clock::WinZoneInfo \ {-18000 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} \ :No/Such/File ::tcl::clock::ClearCaches } \ -body { list [::tcl::clock::GuessWindowsTimeZone] \ [clock format 0 -locale system -format "%X %Z"] \ [clock format -86400 -format "%Y"] } \ -cleanup { # restore the registry and environment namespace eval ::tcl::clock { rename registry {} } if { [info exists oldTclTZ] } { set env(TCL_TZ) $oldTclTZ } if { [info exists oldTZ] } { set env(TZ) $oldTZ } # put New York back on the map dict set ::tcl::clock::WinZoneInfo \ {-18000 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} \ :America/New_York ::tcl::clock::ClearCaches } \ -result {<-0500>+05:00:00<-0400>+04:00:00,M4.1.0/02:00:00,M10.5.0/02:00:00 { 7:00:00 PM -0500} 1969} test clock-50.1 {format / scan -1 as a local time} { if {[catch { clock scan \ [clock format -1 -format %Y%m%d%H%M%S -timezone :localtime] \ -format %Y%m%d%H%M%S -timezone :localtime } result]} { if { [regexp " too large" $result] } { set result -1 } } set result } -1 test clock-50.2 {format / scan -2 as a local time} { if {[catch { clock scan \ [clock format -2 -format %Y%m%d%H%M%S -timezone :localtime] \ -format %Y%m%d%H%M%S -timezone :localtime } result]} { if { [regexp " too large" $result] } { set result -2 } } set result } -2 # cleanup namespace delete ::testClock ::tcl::clock::ClearCaches ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to tests/cmdIL.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for the procedures in the # file tclCmdIL.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | # This file contains a collection of tests for the procedures in the # file tclCmdIL.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: cmdIL.test,v 1.23.2.2 2005/07/12 20:37:06 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] test cmdIL-1.1 {Tcl_LsortObjCmd procedure} { list [catch {lsort} msg] $msg } {1 {wrong # args: should be "lsort ?options? list"}} test cmdIL-1.2 {Tcl_LsortObjCmd procedure} { list [catch {lsort -foo {1 3 2 5}} msg] $msg } {1 {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, or -unique}} test cmdIL-1.3 {Tcl_LsortObjCmd procedure, default options} { lsort {d e c b a \{ d35 d300} } {a b c d d300 d35 e \{} test cmdIL-1.4 {Tcl_LsortObjCmd procedure, -ascii option} { lsort -integer -ascii {d e c b a d35 d300} } {a b c d d300 d35 e} test cmdIL-1.5 {Tcl_LsortObjCmd procedure, -command option} { |
︙ | ︙ | |||
55 56 57 58 59 60 61 | lsort -decreasing -increasing {d e c b a d35 d300} } {a b c d d300 d35 e} test cmdIL-1.11 {Tcl_LsortObjCmd procedure, -index option} { list [catch {lsort -index {1 3 2 5}} msg] $msg } {1 {"-index" option must be followed by list index}} test cmdIL-1.12 {Tcl_LsortObjCmd procedure, -index option} { list [catch {lsort -index foo {1 3 2 5}} msg] $msg | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | lsort -decreasing -increasing {d e c b a d35 d300} } {a b c d d300 d35 e} test cmdIL-1.11 {Tcl_LsortObjCmd procedure, -index option} { list [catch {lsort -index {1 3 2 5}} msg] $msg } {1 {"-index" option must be followed by list index}} test cmdIL-1.12 {Tcl_LsortObjCmd procedure, -index option} { list [catch {lsort -index foo {1 3 2 5}} msg] $msg } {1 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}} test cmdIL-1.13 {Tcl_LsortObjCmd procedure, -index option} { lsort -index end -integer {{2 25} {10 20 50 100} {3 16 42} 1} } {1 {2 25} {3 16 42} {10 20 50 100}} test cmdIL-1.14 {Tcl_LsortObjCmd procedure, -index option} { lsort -index 1 -integer {{1 25 100} {3 16 42} {10 20 50}} } {{3 16 42} {10 20 50} {1 25 100}} test cmdIL-1.15 {Tcl_LsortObjCmd procedure, -integer option} { |
︙ | ︙ | |||
379 380 381 382 383 384 385 386 387 388 389 390 391 392 | } [list ` AA c CC] test cmdIL-4.32 {DictionaryCompare procedure, chars between Z and a in ASCII} { lsort -dictionary [list AA c CC `] } [list ` AA c CC] test cmdIL-4.33 {DictionaryCompare procedure, chars between Z and a in ASCII} { lsort -dictionary [list AA ! c CC `] } [list ! ` AA c CC] test cmdIL-5.1 {lsort with list style index} { lsort -ascii -decreasing -index {0 1} { {{Jim Alpha} 20000410} {{Joe Bravo} 19990320} {{Jacky Charlie} 19390911} } | > > > > > > | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 | } [list ` AA c CC] test cmdIL-4.32 {DictionaryCompare procedure, chars between Z and a in ASCII} { lsort -dictionary [list AA c CC `] } [list ` AA c CC] test cmdIL-4.33 {DictionaryCompare procedure, chars between Z and a in ASCII} { lsort -dictionary [list AA ! c CC `] } [list ! ` AA c CC] test cmdIL-4.34 {SortCompare procedure, -ascii option with -nocase option} { lsort -ascii -nocase {d e c b a d35 d300 100 20} } {100 20 a b c d d300 d35 e} test cmdIL-4.35 {SortCompare procedure, -ascii option with -nocase option} { lsort -ascii -nocase {d E c B a D35 d300 100 20} } {100 20 a B c d d300 D35 E} test cmdIL-5.1 {lsort with list style index} { lsort -ascii -decreasing -index {0 1} { {{Jim Alpha} 20000410} {{Joe Bravo} 19990320} {{Jacky Charlie} 19390911} } |
︙ | ︙ |
Changes to tests/compExpr-old.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # # 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. # | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # # 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: compExpr-old.test,v 1.11.2.4 2005/08/15 18:14:01 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { testConstraint testmathfunctions 0 } else { testConstraint testmathfunctions 1 } # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues binary scan [binary format dd -1.0 1.0] c* c switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ ieeeValues(-Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ ieeeValues(+Normal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ ieeeValues(+Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 } default { return 0 } } } ::tcltest::testConstraint ieeeFloatingPoint [testIEEE] # procedures used below proc put_hello_char {c} { global a append a [format %c $c] return $c } |
︙ | ︙ | |||
63 64 65 66 67 68 69 | "!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \ [string range $c 1 end]]} } proc do_twelve_days {} { global xxx set xxx "" 12days 1 1 1 | | > > | 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | "!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \ [string range $c 1 end]]} } proc do_twelve_days {} { global xxx set xxx "" 12days 1 1 1 set result [string length $xxx] unset xxx return $result } # start of tests catch {unset a b i x} test compExpr-old-1.1 {TclCompileExprCmd: no expression} { |
︙ | ︙ | |||
139 140 141 142 143 144 145 | set msg } {syntax error in expression "7*2foo": extra tokens at end of expression} test compExpr-old-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} { expr {0001} } 1 test compExpr-old-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1 | | > | | < < | < > < | | | 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 | set msg } {syntax error in expression "7*2foo": extra tokens at end of expression} test compExpr-old-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} { expr {0001} } 1 test compExpr-old-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1 test compExpr-old-3.2 {CompileCondExpr: error in lor expr} -body { catch {expr x||3} msg set msg } -match glob \ -result {syntax error in expression "x||3": * preceding $*} test compExpr-old-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44 test compExpr-old-3.4 {CompileCondExpr: error compiling true arm} { catch {expr 3>2?2***3:66} msg set msg } {syntax error in expression "3>2?2***3:66": unexpected operator *} test compExpr-old-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66 test compExpr-old-3.6 {CompileCondExpr: error compiling false arm} { catch {expr 2>3?44:2***3} msg set msg } {syntax error in expression "2>3?44:2***3": unexpected operator *} test compExpr-old-3.7 {CompileCondExpr: long arms & nested cond exprs} { hello_world } {Hello world} test compExpr-old-3.8 {CompileCondExpr: long arms & nested cond exprs} unix { # Fails with a stack overflow on threaded Windows builds do_twelve_days } 2358 test compExpr-old-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1 test compExpr-old-4.2 {CompileLorExpr: error in land expr} -body { catch {expr x&&3} msg set msg } -match glob -result {syntax error in expression "x&&3": * preceding $*} test compExpr-old-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1 test compExpr-old-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1 test compExpr-old-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1 test compExpr-old-4.6 {CompileLorExpr: error compiling lor arm} { catch {expr 2***3||4.0} msg set msg } {syntax error in expression "2***3||4.0": unexpected operator *} |
︙ | ︙ | |||
190 191 192 193 194 195 196 | test compExpr-old-4.9 {CompileLorExpr: long lor arm} { set a "abcdefghijkl" set i 7 expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} } 1 test compExpr-old-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23 | | | | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 | test compExpr-old-4.9 {CompileLorExpr: long lor arm} { set a "abcdefghijkl" set i 7 expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} } 1 test compExpr-old-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23 test compExpr-old-5.2 {CompileLandExpr: error in bitor expr} -body { catch {expr x|3} msg set msg } -match glob -result {syntax error in expression "x|3": * preceding $*} test compExpr-old-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0 test compExpr-old-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0 test compExpr-old-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1 test compExpr-old-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1 test compExpr-old-5.7 {CompileLandExpr: error compiling land arm} { catch {expr 2***3&&4.0} msg set msg |
︙ | ︙ | |||
216 217 218 219 220 221 222 | test compExpr-old-5.10 {CompileLandExpr: long land arms} { set a "abcdefghijkl" set i 7 expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]} } 1 test compExpr-old-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3 | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | > > > | | | | | | | 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 | test compExpr-old-5.10 {CompileLandExpr: long land arms} { set a "abcdefghijkl" set i 7 expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]} } 1 test compExpr-old-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3 test compExpr-old-6.2 {CompileBitXorExpr: error in bitand expr} -body { catch {expr x|3} msg set msg } -match glob -result {syntax error in expression "x|3": * preceding $*} test compExpr-old-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20 test compExpr-old-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19 test compExpr-old-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7 test compExpr-old-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8 test compExpr-old-6.7 {CompileBitXorExpr: error compiling bitxor arm} { catch {expr 2***3|6} msg set msg } {syntax error in expression "2***3|6": unexpected operator *} test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { catch {expr 2^x} msg set msg } -match glob -result {syntax error in expression "2^x": * preceding $*} test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg } {1 {can't use floating-point value as operand of "^"}} test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "^"}} test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 test compExpr-old-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1 test compExpr-old-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0 test compExpr-old-7.5 {CompileBitAndExpr: error in equality expr} -body { catch {expr x==3} msg set msg } -match glob -result {syntax error in expression "x==3": * preceding $*} test compExpr-old-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3 test compExpr-old-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82 test compExpr-old-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2 test compExpr-old-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7 test compExpr-old-7.10 {CompileBitAndExpr: error compiling bitand arm} { catch {expr 2***3&6} msg set msg } {syntax error in expression "2***3&6": unexpected operator *} test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { catch {expr 2&x} msg set msg } -match glob -result {syntax error in expression "2&x": * preceding $*} test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg } {1 {can't use floating-point value as operand of "&"}} test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "&"}} test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1 test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1 test compExpr-old-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1 test compExpr-old-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0 test compExpr-old-8.5 {CompileEqualityExpr: error in relational expr} -body { catch {expr x>3} msg set msg } -match glob -result {syntax error in expression "x>3": * preceding $*} test compExpr-old-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0 test compExpr-old-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1 test compExpr-old-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1 test compExpr-old-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1 test compExpr-old-8.10 {CompileEqualityExpr: error compiling equality arm} { catch {expr 2***3==6} msg set msg } {syntax error in expression "2***3==6": unexpected operator *} test compExpr-old-8.11 {CompileEqualityExpr: error compiling equality arm} -body { catch {expr 2!=x} msg set msg } -match glob -result {syntax error in expression "2!=x": * preceding $*} test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 # The following test is different for 32-bit versus 64-bit # architectures because LONG_MIN is different testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] test compExpr-old-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit { expr {1<<63} } -9223372036854775808 test compExpr-old-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit { expr {1<<31} } -2147483648 test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} -body { catch {expr x>>3} msg set msg } -match glob -result {syntax error in expression "x>>3": * preceding $*} test compExpr-old-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1 test compExpr-old-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1 test compExpr-old-9.9 {CompileRelationalExpr: error compiling relational arm} { catch {expr 2***3>6} msg set msg } {syntax error in expression "2***3>6": unexpected operator *} test compExpr-old-9.10 {CompileRelationalExpr: error compiling relational arm} -body { catch {expr 2<x} msg set msg } -match glob -result {syntax error in expression "2<x": * preceding $*} test compExpr-old-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2 test compExpr-old-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253 test compExpr-old-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1 test compExpr-old-10.4 {CompileShiftExpr: just add expr} {expr 1-0123} -82 test compExpr-old-10.5 {CompileShiftExpr: error in add expr} -body { catch {expr x+3} msg set msg } -match glob -result {syntax error in expression "x+3": * preceding $*} test compExpr-old-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31 test compExpr-old-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936 test compExpr-old-10.8 {CompileShiftExpr: error compiling shift arm} { catch {expr 2***3>>6} msg set msg } {syntax error in expression "2***3>>6": unexpected operator *} test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body { catch {expr 2<<x} msg set msg } -match glob -result {syntax error in expression "2<<x": * preceding $*} test compExpr-old-10.10 {CompileShiftExpr: runtime error} { list [catch {expr {24.0>>43}} msg] $msg } {1 {can't use floating-point value as operand of ">>"}} test compExpr-old-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "<<"}} test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 test compExpr-old-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1 test compExpr-old-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6 test compExpr-old-11.5 {CompileAddExpr: error in multiply expr} -body { catch {expr x*3} msg set msg } -match glob -result {syntax error in expression "x*3": * preceding $*} test compExpr-old-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258 test compExpr-old-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239 test compExpr-old-11.8 {CompileAddExpr: error compiling add arm} { catch {expr 2***3+6} msg set msg } {syntax error in expression "2***3+6": unexpected operator *} test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} -body { catch {expr 2-x} msg set msg } -match glob -result {syntax error in expression "2-x": * preceding $*} test compExpr-old-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg } {1 {can't use non-numeric string as operand of "+"}} test compExpr-old-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "-"}} test compExpr-old-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} test compExpr-old-11.13a {CompileAddExpr: runtime error} ieeeFloatingPoint { list [catch {expr {2.3/0.0}} msg] $msg } {0 Inf} test compExpr-old-11.13b {CompileAddExpr: runtime error} !ieeeFloatingPoint { list [catch {expr {2.3/0.0}} msg] $msg } {1 {divide by zero}} test compExpr-old-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5 test compExpr-old-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5 test compExpr-old-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0 test compExpr-old-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936 test compExpr-old-12.5 {CompileMultiplyExpr: error in unary expr} -body { catch {expr ~x} msg set msg } -match glob -result {syntax error in expression "~x": * preceding $*} test compExpr-old-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765 test compExpr-old-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2 test compExpr-old-12.8 {CompileMultiplyExpr: error compiling multiply arm} { catch {expr 2*3%%6} msg set msg } {syntax error in expression "2*3%%6": unexpected operator %} test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body { catch {expr 2*x} msg set msg } -match glob -result {syntax error in expression "2*x": * preceding $*} test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg } {1 {can't use non-numeric string as operand of "*"}} test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "/"}} test compExpr-old-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 test compExpr-old-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 83 test compExpr-old-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36 test compExpr-old-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0 test compExpr-old-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0 test compExpr-old-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1 test compExpr-old-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0 test compExpr-old-13.8 {CompileUnaryExpr: error compiling unary expr} -body { catch {expr ~x} msg set msg } -match glob -result {syntax error in expression "~x": * preceding $*} test compExpr-old-13.9 {CompileUnaryExpr: error compiling unary expr} { catch {expr !1.x} msg set msg } {syntax error in expression "!1.x": extra tokens at end of expression} test compExpr-old-13.10 {CompileUnaryExpr: runtime error} { list [catch {expr {~"xx"}} msg] $msg } {1 {can't use non-numeric string as operand of "~"}} |
︙ | ︙ | |||
525 526 527 528 529 530 531 | } 2.71828 test compExpr-old-14.26 {CompilePrimaryExpr: math function primary} { format %.6g [expr pow(2.0+0.1,3.0+0.1)] } 9.97424 test compExpr-old-14.27 {CompilePrimaryExpr: error in math function primary} -body { catch {expr sinh::(2.0)} msg set errorInfo | | | 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 | } 2.71828 test compExpr-old-14.26 {CompilePrimaryExpr: math function primary} { format %.6g [expr pow(2.0+0.1,3.0+0.1)] } 9.97424 test compExpr-old-14.27 {CompilePrimaryExpr: error in math function primary} -body { catch {expr sinh::(2.0)} msg set errorInfo } -match glob -result {syntax error in expression "sinh::(2.0)": * function arguments* while *ing "expr sinh::(2.0)"} test compExpr-old-14.28 {CompilePrimaryExpr: subexpression primary} { expr 2+(3*4) } 14 test compExpr-old-14.29 {CompilePrimaryExpr: error in subexpression primary} -body { catch {expr 2+(3*[set])} msg |
︙ | ︙ | |||
557 558 559 560 561 562 563 | } -match glob -result {syntax error in expression "@": character not legal in expressions while *ing "expr @"} test compExpr-old-15.1 {CompileMathFuncCall: missing parenthesis} -body { catch {expr sinh2.0)} msg set errorInfo | | | | | | | 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 | } -match glob -result {syntax error in expression "@": character not legal in expressions while *ing "expr @"} test compExpr-old-15.1 {CompileMathFuncCall: missing parenthesis} -body { catch {expr sinh2.0)} msg set errorInfo } -match glob -result {syntax error in expression "sinh2.0)": * preceding $* while *ing "expr sinh2.0)"} test compExpr-old-15.2 {CompileMathFuncCall: unknown math function} -body { catch {expr whazzathuh(1)} msg set errorInfo } -match glob -result {* "*whazzathuh" while *ing "expr whazzathuh(1)"} test compExpr-old-15.3 {CompileMathFuncCall: too many arguments} -body { catch {expr sin(1,2,3)} msg set errorInfo } -match glob -result {too many arguments for math function* while *ing "expr sin(1,2,3)"} test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} -body { catch {expr sin()} msg set errorInfo } -match glob -result {too few arguments for math function* while *ing "expr sin()"} test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body { catch {expr pow(1)} msg set errorInfo } -match glob -result {too few arguments for math function* while *ing "expr pow(1)"} test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body { catch {expr sin(1} msg set errorInfo } -match glob -result {syntax error in expression "sin(1": missing close parenthesis at end of function call while *ing |
︙ | ︙ |
Changes to tests/compExpr.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for the procedures in the # file tclCompExpr.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | # This file contains a collection of tests for the procedures in the # file tclCompExpr.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: compExpr.test,v 1.8.2.1 2005/03/15 19:41:45 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { testConstraint testmathfunctions 0 } else { testConstraint testmathfunctions 1 } catch {unset a} test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} { expr 1+2 } 3 test compExpr-1.2 {TclCompileExpr procedure, error parsing expr} { list [catch {expr 1+2+} msg] $msg } {1 {syntax error in expression "1+2+": premature end of expression}} test compExpr-1.3 {TclCompileExpr procedure, error compiling expr} -body { list [catch {expr "foo(123)"} msg] $msg } -match glob -result {1 {* "*foo"}} test compExpr-1.4 {TclCompileExpr procedure, expr has no operators} { set a {000123} expr {$a} } 83 test compExpr-2.1 {CompileSubExpr procedure, TCL_TOKEN_WORD parse token} { catch {unset a} |
︙ | ︙ | |||
90 91 92 93 94 95 96 | } {0 1} test compExpr-2.14 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, op found} { expr {5*6} } 30 test compExpr-2.15 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function found} { format %.6g [expr {sin(2.0)}] } 0.909297 | | | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | } {0 1} test compExpr-2.14 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, op found} { expr {5*6} } 30 test compExpr-2.15 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function found} { format %.6g [expr {sin(2.0)}] } 0.909297 test compExpr-2.16 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, math function not found} -body { list [catch {expr {fred(2.0)}} msg] $msg } -match glob -result {1 {* "*fred"}} test compExpr-2.17 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { expr {4*2} } 8 test compExpr-2.18 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { expr {4/2} } 2 test compExpr-2.19 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator} { |
︙ | ︙ | |||
285 286 287 288 289 290 291 | test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} { list [catch {expr {1? 15 : [expr *2]}} msg] $msg } {0 15} test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { format %.6g [expr atan2(1.0, 2.0)] } 0.463648 | | | | | | | | | | 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 | test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} { list [catch {expr {1? 15 : [expr *2]}} msg] $msg } {0 15} test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { format %.6g [expr atan2(1.0, 2.0)] } 0.463648 test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body { list [catch {expr {do_it()}} msg] $msg } -match glob -result {1 {* "*do_it"}} test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions { expr 3*T1()-1 } 368 test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions { expr T2()*3 } 1035 test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body { list [catch {expr {atan2(1.0)}} msg] $msg } -match glob -result {1 {too few arguments for math function*}} test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} { format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))] } 9.97424 test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} { list [catch {expr {sinh(2.*)}} msg] $msg } {1 {syntax error in expression "sinh(2.*)": unexpected close parenthesis}} test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} -body { list [catch {expr {sinh(2.0, 3.0)}} msg] $msg } -match glob -result {1 {too many arguments for math function*}} test compExpr-5.9 {CompileMathFuncCall procedure, too many arguments} -body { list [catch {expr {0 <= rand(5.2)}} msg] $msg } -match glob -result {1 {too many arguments for math function*}} test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} { list [catch {expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3} msg] $msg } {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012...": extra tokens at end of expression}} # cleanup catch {unset a} catch {unset b} ::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 | # 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.34.2.3 2005/05/05 17:56:15 kennykb Exp $ package require tcltest 2 namespace import -force ::tcltest::* testConstraint exec [llength [info commands exec]] testConstraint memory [llength [info commands memory]] testConstraint testevalex [llength [info commands testevalex]] |
︙ | ︙ | |||
232 233 234 235 236 237 238 | proc p {} { # shared object - Interp result && Var 'r' set r [list foobar] # command that will add error to result lindex a bogus } list [catch {p} msg] $msg | | | | | | | | | 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 | proc p {} { # shared object - Interp result && Var 'r' set r [list foobar] # command that will add error to result lindex a bogus } list [catch {p} msg] $msg } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { proc p {} { set r [list foobar] ; string index a bogus } list [catch {p} msg] $msg } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { proc p {} { set r [list foobar] ; string index a 09 } list [catch {p} msg] $msg } {1 {bad index "09": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { proc p {} { set r [list foobar] ; array set var {one two many} } list [catch {p} msg] $msg } {1 {list must have an even number of elements}} test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { proc p {} { set r [list foobar] ; incr foo } list [catch {p} msg] $msg } {1 {can't read "foo": no such variable}} test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { proc p {} { set r [list foobar] ; incr foo bogus } list [catch {p} msg] $msg } {1 {expected integer but got "bogus"}} test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { proc p {} { set r [list foobar] ; expr !a } list [catch {p} msg] $msg } -match glob -result {1 {syntax error in expression "!a": * preceding $*}} test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { proc p {} { set r [list foobar] ; expr {!a} } list [catch {p} msg] $msg } -match glob -result {1 {syntax error in expression "!a": * preceding $*}} test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { proc p {} { set r [list foobar] ; llength "\{" } list [catch {p} msg] $msg } {1 {unmatched open brace in list}} # # Special section for tests of tclLiteral.c |
︙ | ︙ | |||
316 317 318 319 320 321 322 | test compile-12.3 {check for a buffer overrun} -body { proc crash {} { puts $array([expr {a+2}]) } crash } -returnCodes error -cleanup { rename crash {} | | | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 | test compile-12.3 {check for a buffer overrun} -body { proc crash {} { puts $array([expr {a+2}]) } crash } -returnCodes error -cleanup { rename crash {} } -match glob -result {syntax error in expression "a+2": * preceding $*} test compile-12.4 {TclCleanupLiteralTable segfault} -body { # Tcl Bug 1001997 # Here, we're trying to test a case that causes a crash in # TclCleanupLiteralTable. The conditions that we're trying to # establish are: # - TclCleanupLiteralTable is attempting to clean up a bytecode # object in the literal table. |
︙ | ︙ | |||
582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 | } } } -cleanup { namespace delete x } -returnCodes ok -result {syntax {}{}} } ;# End of noComp loop # cleanup catch {rename p ""} catch {namespace delete test_ns_compile} catch {unset x} catch {unset y} catch {unset a} ::tcltest::cleanupTests return | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 | } } } -cleanup { namespace delete x } -returnCodes ok -result {syntax {}{}} } ;# End of noComp loop # These tests are messy because it wrecks the interpreter it runs in! # They demonstrate issues arising from [FRQ 1101710] test compile-17.1 {Command interpretation binding for compiled code} -constraints knownBug -setup { set i [interp create] } -body { $i eval { if 1 { expr [ proc expr args {return substituted} format {[subst compiled]} ] } } } -cleanup { interp delete $i } -result substituted test compile-17.2 {Command interpretation binding for non-compiled code} -setup { set i [interp create] } -body { $i eval { if 1 { [subst expr] [ proc expr args {return substituted} format {[subst compiled]} ] } } } -cleanup { interp delete $i } -result substituted # 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/dict.test.
1 2 3 4 5 6 7 8 9 10 11 | # This test file covers the dictionary object type and the dict # command used to work with values of that type. # # 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) 2003 Donal K. Fellows # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # This test file covers the dictionary object type and the dict # command used to work with values of that type. # # 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) 2003 Donal K. Fellows # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: dict.test,v 1.12.2.2 2005/08/18 21:19:17 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # Used for constraining memory leak tests |
︙ | ︙ | |||
302 303 304 305 306 307 308 309 310 311 312 313 314 315 | test dict-11.15 {dict incr command: write failure} { catch {unset dictVar} set dictVar(block) {} set result [list [catch {dict incr dictVar a} msg] $msg] catch {unset dictVar} set result } {1 {can't set "dictVar": variable is array}} test dict-12.1 {dict lappend command} { set dictv {a a} dict lappend dictv a } {a a} test dict-12.2 {dict lappend command} { set dictv {a a} | > > > > > > > > > > > > > > > > > > | 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 | test dict-11.15 {dict incr command: write failure} { catch {unset dictVar} set dictVar(block) {} set result [list [catch {dict incr dictVar a} msg] $msg] catch {unset dictVar} set result } {1 {can't set "dictVar": variable is array}} test dict-11.16 {dict incr command: compilation} { proc dicttest {} { set v {a 0 b 0 c 0} dict incr v a dict incr v b 1 dict incr v c 2 dict incr v d 3 list [dict get $v a] [dict get $v b] [dict get $v c] [dict get $v d] } dicttest } {1 1 2 3} test dict-11.17 {dict incr command: compilation} { proc dicttest {} { set dictv {a 1} dict incr dictv a 2 } dicttest } {a 3} test dict-12.1 {dict lappend command} { set dictv {a a} dict lappend dictv a } {a a} test dict-12.2 {dict lappend command} { set dictv {a a} |
︙ | ︙ | |||
507 508 509 510 511 512 513 514 515 516 517 518 519 520 | lappend result : foreach k $result { catch {lappend result $accum($k)} } catch {unset accum} set result } {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,} # There's probably a lot more tests to add here. Really ought to use # a coverage tool for this job... test dict-15.1 {dict set command} { set dictVar {} dict set dictVar a x } {a x} | > > > > > > > > > > > | 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 | lappend result : foreach k $result { catch {lappend result $accum($k)} } catch {unset accum} set result } {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,} test dict-14.16 {dict for command in compilation context} { proc dicttest {} { set res {x x x x x x} dict for {k v} {a 0 b 1 c 2 d 3 e 4 f 5} { lset res $v $k continue } return $res } dicttest } {a b c d e f} # There's probably a lot more tests to add here. Really ought to use # a coverage tool for this job... test dict-15.1 {dict set command} { set dictVar {} dict set dictVar a x } {a x} |
︙ | ︙ | |||
964 965 966 967 968 969 970 971 972 973 974 975 976 977 | test dict-21.12 {dict update command} { set a {b c d e} dict update a b v1 d v2 f v3 { set v3 g } getOrder $a b d f } {b c d e f g 3} test dict-22.1 {dict with command} -body { dict with } -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"} test dict-22.2 {dict with command} -body { dict with v } -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"} | > > > > > > > > > > > > > | 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 | test dict-21.12 {dict update command} { set a {b c d e} dict update a b v1 d v2 f v3 { set v3 g } getOrder $a b d f } {b c d e f g 3} test dict-21.13 {dict update command: compilation} { proc dicttest {d} { while 1 { dict update d a alpha b beta { set beta $alpha unset alpha break } } return $d } getOrder [dicttest {a 1 c 2}] b c } {b 1 c 2 2} test dict-22.1 {dict with command} -body { dict with } -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"} test dict-22.2 {dict with command} -body { dict with v } -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"} |
︙ | ︙ |
Changes to tests/encoding.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for tclEncoding.c # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # This file contains a collection of tests for tclEncoding.c # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: encoding.test,v 1.21.2.1 2005/04/25 21:37:28 kennykb Exp $ package require tcltest 2 namespace import -force ::tcltest::* proc toutf {args} { global x lappend x "toutf $args" |
︙ | ︙ | |||
551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 | close $fb # Difference should be empty. set diff } {} } } file delete {expand}[glob -directory [temporaryDirectory] *.chars *.tcltestout] # ===> Cut here <=== # EscapeFreeProc, GetTableEncoding, unilen # are fully tested by the rest of this file # cleanup ::tcltest::cleanupTests return | > > > > > > > > > > > > > | 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 | close $fb # Difference should be empty. set diff } {} } } testConstraint testgetdefenc [llength [info commands testgetdefenc]] test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints { testgetdefenc } -setup { set origDir [testgetdefenc] testsetdefenc slappy } -body { testgetdefenc } -cleanup { testsetdefenc $origDir } -result slappy file delete {expand}[glob -directory [temporaryDirectory] *.chars *.tcltestout] # ===> Cut here <=== # 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 | # 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.20.2.2 2005/10/08 13:44:38 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # Some tests require the "exec" command. |
︙ | ︙ | |||
72 73 74 75 76 77 78 | set names [lsort [array names env]] if {$tcl_platform(platform) == "windows"} { lrem names HOME lrem names COMSPEC lrem names ComSpec lrem names "" } | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | set names [lsort [array names env]] if {$tcl_platform(platform) == "windows"} { lrem names HOME lrem names COMSPEC lrem names ComSpec lrem names "" } foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY SHLIB_PATH DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH __CF_USER_TEXT_ENCODING } { lrem names $name } foreach p $names { puts "$p=$env($p)" } exit } printenv] |
︙ | ︙ | |||
102 103 104 105 106 107 108 | set env2($name) $env($name) unset env($name) } # Added the following lines so that child tcltest can actually find its # library if the initial tcltest is run from a non-standard place. # ('saved' env vars) | | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | set env2($name) $env($name) unset env($name) } # Added the following lines so that child tcltest can actually find its # library if the initial tcltest is run from a non-standard place. # ('saved' env vars) foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH} { if {[info exists env2($name)]} { set env($name) $env2($name); } } test env-2.1 {adding environment variables} {exec} { getenv |
︙ | ︙ | |||
228 229 230 231 232 233 234 235 236 237 238 239 240 241 | set result } {1 a 1} test env-5.5 {corner cases - cannot have null entries on Windows} {win} { set env() a catch {set env()} } {1} # Restore the environment variables at the end of the test. foreach name [array names env] { unset env($name) } foreach name [array names env2] { | > > > > > > > | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 | set result } {1 a 1} test env-5.5 {corner cases - cannot have null entries on Windows} {win} { set env() a catch {set env()} } {1} test env-6.1 {corner cases - add lots of env variables} {} { set size [array size env] for {set i 0} {$i < 100} {incr i} { set env(BOGUS$i) $i } expr {[array size env] - $size} } 100 # Restore the environment variables at the end of the test. foreach name [array names env] { unset env($name) } foreach name [array names env2] { |
︙ | ︙ |
Changes to tests/error.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: error, catch # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Commands covered: error, catch # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: error.test,v 1.12.2.1 2005/08/02 18:16:23 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } proc foo {} { |
︙ | ︙ | |||
64 65 66 67 68 69 70 | } 1 test error-1.7 {simple errors from commands} { catch {catch a b c d} b set b } {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} | | > > > > | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | } 1 test error-1.7 {simple errors from commands} { catch {catch a b c d} b set b } {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} test error-1.8 {simple errors from commands} { # This test is non-portable: it generates a memory fault on # machines like DEC Alphas (infinite recursion overflows # stack?) # # That claims sounds like a bug to be fixed rather than a portability # problem. Anyhow, I believe it's out of date (bug's been fixed) so # this test is re-enabled. proc p {} { uplevel 1 catch p error } p } 0 |
︙ | ︙ |
Changes to tests/eval.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: eval # # 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: eval # # 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: eval.test,v 1.6.2.1 2005/09/09 18:48:40 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } test eval-1.1 {single argument} { |
︙ | ︙ | |||
53 54 55 56 57 58 59 60 61 62 63 | \"error \"test error\"\" (\"eval\" body line 3) invoked from within \"eval { set a 1 error \"test error\" }\"" # cleanup ::tcltest::cleanupTests return | > > > > > > > > > > > > > > > > > > > > > > > | 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 | \"error \"test error\"\" (\"eval\" body line 3) invoked from within \"eval { set a 1 error \"test error\" }\"" test eval-3.1 {eval and pure lists} { eval [list list 1 2 3 4 5] } {1 2 3 4 5} test eval-3.2 {concatenating eval and pure lists} { eval [list list 1] [list 2 3 4 5] } {1 2 3 4 5} test eval-3.3 {eval and canonical lists} { set cmd [list list 1 2 3 4 5] # Force existance of utf-8 rep set dummy($cmd) $cmd unset dummy($cmd) eval $cmd } {1 2 3 4 5} test eval-3.4 {concatenating eval and canonical lists} { set cmd [list list 1] set cmd2 [list 2 3 4 5] # Force existance of utf-8 rep set dummy($cmd) $cmd set dummy($cmd2) $cmd2 unset dummy($cmd) dummy($cmd2) eval $cmd $cmd2 } {1 2 3 4 5} # cleanup ::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 | # 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.22.2.1 2005/08/02 18:16:23 dgp 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]] |
︙ | ︙ | |||
595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 | 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 } unset -nocomplain path ::tcltest::cleanupTests return | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | set fout [open $path(fooblah) w] puts $fout "contents" close $fout set res [list [catch {exec cat $path(fooblah)} msg] $msg] removeFile $f set res } {0 contents} # Note that this test cannot be adapted to work on Windows; that platform has # no kernel support for an analog of O_APPEND. test exec-19.1 {exec >> uses O_APPEND} { -constraints {exec unix} -setup { set tmpfile [makeFile {0} tmpfile.exec-19.1] } -body { # Note that we have to allow for the current contents of the # temporary file, which is why the result is 14 and not 12 exec /bin/sh -c \ {for a in 1 2 3; do sleep 1; echo $a; done} >>$tmpfile & exec /bin/sh -c \ {for a in a b c; do sleep 1; echo $a; done} >>$tmpfile & # The above two shell invokations take about 3 seconds to # finish, so allow 5s (in case the machine is busy) after 5000 # Check that no bytes have got lost through mixups with # overlapping appends, which is only guaranteed to work when # we set O_APPEND on the file descriptor in the [exec >>...] file size $tmpfile } -cleanup { removeFile $tmpfile } -result 14 } # cleanup foreach file {script gorp.file gorp.file2 echo cat wc sh sleep exit err} { removeFile $file } unset -nocomplain path ::tcltest::cleanupTests return |
Changes to tests/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 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 | # 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.22.2.11 2005/10/08 13:44:38 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { testConstraint testmathfunctions 0 } else { testConstraint testmathfunctions 1 } # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues binary scan [binary format dd -1.0 1.0] c* c switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ ieeeValues(-Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ ieeeValues(+Normal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ ieeeValues(+Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 } default { return 0 } } } ::tcltest::testConstraint ieeeFloatingPoint [testIEEE] # First, test all of the integer operators individually. test expr-old-1.1 {integer operators} {expr -4} -4 test expr-old-1.2 {integer operators} {expr -(1+4)} -5 test expr-old-1.3 {integer operators} {expr ~3} -4 test expr-old-1.4 {integer operators} {expr !2} 0 test expr-old-1.5 {integer operators} {expr !0} 1 |
︙ | ︙ | |||
87 88 89 90 91 92 93 | [expr {0 || $x}] [expr {$x || 0}] } {1 1 1 1} # Check the floating-point operators individually, along with # automatic conversion to integers where needed. test expr-old-2.1 {floating-point operators} {expr -4.2} -4.2 | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | [expr {0 || $x}] [expr {$x || 0}] } {1 1 1 1} # Check the floating-point operators individually, along with # automatic conversion to integers where needed. test expr-old-2.1 {floating-point operators} {expr -4.2} -4.2 test expr-old-2.2 {floating-point operators} {expr -(1.125+4.25)} -5.375 test expr-old-2.3 {floating-point operators} {expr +5.7} 5.7 test expr-old-2.4 {floating-point operators} {expr +--+-62.0} -62.0 test expr-old-2.5 {floating-point operators} {expr !2.1} 0 test expr-old-2.6 {floating-point operators} {expr !0.0} 1 test expr-old-2.7 {floating-point operators} {expr 4.2*6.3} 26.46 test expr-old-2.8 {floating-point operators} {expr 36.0/12.0} 3.0 test expr-old-2.9 {floating-point operators} {expr 27/4.0} 6.75 |
︙ | ︙ | |||
190 191 192 193 194 195 196 | test expr-old-4.22 {string operators} {expr {"abd" ne "abd"}} 0 test expr-old-4.23 {string operators} {expr {"" eq "abd"}} 0 test expr-old-4.24 {string operators} {expr {"" eq ""}} 1 test expr-old-4.25 {string operators} {expr {"abd" ne ""}} 1 test expr-old-4.26 {string operators} {expr {"" ne ""}} 0 test expr-old-4.27 {string operators} {expr {"longerstring" eq "shorter"}} 0 test expr-old-4.28 {string operators} {expr {"longerstring" ne "shorter"}} 1 | < < < < | | | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | test expr-old-4.22 {string operators} {expr {"abd" ne "abd"}} 0 test expr-old-4.23 {string operators} {expr {"" eq "abd"}} 0 test expr-old-4.24 {string operators} {expr {"" eq ""}} 1 test expr-old-4.25 {string operators} {expr {"abd" ne ""}} 1 test expr-old-4.26 {string operators} {expr {"" ne ""}} 0 test expr-old-4.27 {string operators} {expr {"longerstring" eq "shorter"}} 0 test expr-old-4.28 {string operators} {expr {"longerstring" ne "shorter"}} 1 test expr-old-4.29 {string operators} {expr {"0" == "+"}} 0 test expr-old-4.30 {string operators} {expr {"0" == "-"}} 0 test expr-old-4.31 {string operators} {expr {1?"foo":"bar"}} foo test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar # Operators that aren't legal on string operands. test expr-old-5.1 {illegal string operations} { list [catch {expr {-"a"}} msg] $msg |
︙ | ︙ | |||
424 425 426 427 428 429 430 | test expr-old-25.12 {type conversions} {expr 2>"ab"} 0 test expr-old-25.13 {type conversions} {expr {2>" "}} 1 test expr-old-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1 test expr-old-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0 test expr-old-25.16 {type conversions} {expr 2+2.5} 4.5 test expr-old-25.17 {type conversions} {expr 2+2.5} 4.5 test expr-old-25.18 {type conversions} {expr 2.0e2} 200.0 | | | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 | test expr-old-25.12 {type conversions} {expr 2>"ab"} 0 test expr-old-25.13 {type conversions} {expr {2>" "}} 1 test expr-old-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1 test expr-old-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0 test expr-old-25.16 {type conversions} {expr 2+2.5} 4.5 test expr-old-25.17 {type conversions} {expr 2+2.5} 4.5 test expr-old-25.18 {type conversions} {expr 2.0e2} 200.0 test expr-old-25.19 {type conversions} {expr 2.0e15} 2000000000000000.0 test expr-old-25.20 {type conversions} {expr 10.0} 10.0 # Various error conditions. test expr-old-26.1 {error conditions} { list [catch {expr 2+"a"} msg] $msg } {1 {can't use non-numeric string as operand of "+"}} |
︙ | ︙ | |||
458 459 460 461 462 463 464 | } {1 {syntax error in expression "2+(4": looking for close parenthesis}} test expr-old-26.8 {error conditions} { list [catch {expr 2/0} msg] $msg $errorCode } {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} test expr-old-26.9 {error conditions} { list [catch {expr 2%0} msg] $msg $errorCode } {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} | | > > > | | | | | | | | | 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 | } {1 {syntax error in expression "2+(4": looking for close parenthesis}} test expr-old-26.8 {error conditions} { list [catch {expr 2/0} msg] $msg $errorCode } {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} test expr-old-26.9 {error conditions} { list [catch {expr 2%0} msg] $msg $errorCode } {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} test expr-old-26.10a {error conditions} !ieeeFloatingPoint { list [catch {expr 2.0/0.0} msg] $msg $errorCode } {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} test expr-old-26.10b {error conditions} ieeeFloatingPoint { list [catch {expr 2.0/0.0} msg] $msg } {0 Inf} test expr-old-26.11 {error conditions} { list [catch {expr 2#} msg] $msg } {1 {syntax error in expression "2#": extra tokens at end of expression}} test expr-old-26.12 {error conditions} -body { list [catch {expr a.b} msg] $msg } -match glob -result {1 {syntax error in expression "a.b": * preceding $*}} test expr-old-26.13 {error conditions} { list [catch {expr {"a"/"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "/"}} test expr-old-26.14 {error conditions} { list [catch {expr 2:3} msg] $msg } {1 {syntax error in expression "2:3": extra tokens at end of expression}} test expr-old-26.15 {error conditions} -body { list [catch {expr a@b} msg] $msg } -match glob -result {1 {syntax error in expression "a@b": * preceding $*}} test expr-old-26.16 {error conditions} { list [catch {expr a[b} msg] $msg } {1 {missing close-bracket}} test expr-old-26.17 {error conditions} -body { list [catch {expr a`b} msg] $msg } -match glob -result {1 {syntax error in expression "a`b": * preceding $*}} test expr-old-26.18 {error conditions} { list [catch {expr \"a\"\{b} msg] $msg } {1 syntax\ error\ in\ expression\ \"\"a\"\{b\":\ extra\ tokens\ at\ end\ of\ expression} test expr-old-26.19 {error conditions} -body { list [catch {expr a} msg] $msg } -match glob -result {1 {syntax error in expression "a": * preceding $*}} test expr-old-26.20 {error conditions} { list [catch expr msg] $msg } {1 {wrong # args: should be "expr arg ?arg ...?"}} # Cancelled evaluation. test expr-old-27.1 {cancelled evaluation} { |
︙ | ︙ | |||
535 536 537 538 539 540 541 | test expr-old-27.9 {cancelled evaluation} { list [catch {expr {1 || ("string" * ("x" && "y"))}} msg] $msg } {0 1} test expr-old-27.10 {cancelled evaluation} { set x -1.0 list [catch {expr {($x > 0) ? round(log($x)) : 0}} msg] $msg } {0 0} | | | | | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 | test expr-old-27.9 {cancelled evaluation} { list [catch {expr {1 || ("string" * ("x" && "y"))}} msg] $msg } {0 1} test expr-old-27.10 {cancelled evaluation} { set x -1.0 list [catch {expr {($x > 0) ? round(log($x)) : 0}} msg] $msg } {0 0} test expr-old-27.11 {cancelled evaluation} -body { list [catch {expr {0 && foo}} msg] $msg } -match glob -result {1 {syntax error in expression "0 && foo": * preceding $*}} test expr-old-27.12 {cancelled evaluation} -body { list [catch {expr {0 ? 1 : foo}} msg] $msg } -match glob -result {1 {syntax error in expression "0 ? 1 : foo": * preceding $*}} # Tcl_ExprBool as used in "if" statements test expr-old-28.1 {Tcl_ExprBoolean usage} { set a 1 if {2} {set a 2} set a |
︙ | ︙ | |||
723 724 725 726 727 728 729 | test expr-old-32.23 {math functions in expressions} { format %.6g [expr abs(-4)] } {4} test expr-old-32.24 {math functions in expressions} { format %.6g [expr abs(66)] } {66} | < < < | | | | | | < | | 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 | test expr-old-32.23 {math functions in expressions} { format %.6g [expr abs(-4)] } {4} test expr-old-32.24 {math functions in expressions} { format %.6g [expr abs(66)] } {66} test expr-old-32.25a {math functions in expressions} { list [catch {expr abs(0x8000000000000000)} msg] $msg } {1 {integer value too large to represent}} test expr-old-32.25b {math functions in expressions} { expr abs(0x80000000) } 2147483648 test expr-old-32.26 {math functions in expressions} { expr double(1) } {1.0} test expr-old-32.27 {math functions in expressions} { expr double(1.1) } {1.1} |
︙ | ︙ | |||
795 796 797 798 799 800 801 | } 246 test expr-old-32.44 {math functions in expressions} testmathfunctions { expr T2()*3 } 1035 test expr-old-32.45 {math functions in expressions} { expr (0 <= rand()) && (rand() < 1) } {1} | | | | | | 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 | } 246 test expr-old-32.44 {math functions in expressions} testmathfunctions { expr T2()*3 } 1035 test expr-old-32.45 {math functions in expressions} { expr (0 <= rand()) && (rand() < 1) } {1} test expr-old-32.46 {math functions in expressions} -body { list [catch {expr rand(24)} msg] $msg } -match glob -result {1 {too many arguments for math function*}} test expr-old-32.47 {math functions in expressions} -body { list [catch {expr srand()} msg] $msg } -match glob -result {1 {too few arguments for math function*}} test expr-old-32.48 {math functions in expressions} { list [catch {expr srand(3.79)} msg] $msg } {1 {can't use floating-point value as argument to srand}} test expr-old-32.49 {math functions in expressions} { list [catch {expr srand("")} msg] $msg } {1 {argument to math function didn't have numeric value}} test expr-old-32.50 {math functions in expressions} { |
︙ | ︙ | |||
837 838 839 840 841 842 843 | test expr-old-33.3 {conversions and fancy args to math functions} { expr hypot ( 3 , (3.0 + 1.0) ) } 5.0 test expr-old-33.4 {conversions and fancy args to math functions} { format %.6g [expr cos(acos(0.1))] } 0.1 | | | | | | | | | | | | | | | > > > > > > | > | | | 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 | test expr-old-33.3 {conversions and fancy args to math functions} { expr hypot ( 3 , (3.0 + 1.0) ) } 5.0 test expr-old-33.4 {conversions and fancy args to math functions} { format %.6g [expr cos(acos(0.1))] } 0.1 test expr-old-34.1 {errors in math functions} -body { list [catch {expr func_2(1.0)} msg] $msg } -match glob -result {1 {* "*func_2"}} test expr-old-34.2 {errors in math functions} -body { list [catch {expr func|(1.0)} msg] $msg } -match glob -result {1 {syntax error in expression "func|(1.0)": * preceding $*}} test expr-old-34.3 {errors in math functions} { list [catch {expr {hypot("a b", 2.0)}} msg] $msg } {1 {expected floating-point number but got "a b"}} test expr-old-34.4 {errors in math functions} { list [catch {expr hypot(1.0 2.0)} msg] $msg } {1 {syntax error in expression "hypot(1.0 2.0)": missing close parenthesis at end of function call}} test expr-old-34.5 {errors in math functions} { list [catch {expr hypot(1.0, 2.0} msg] $msg } {1 {syntax error in expression "hypot(1.0, 2.0": missing close parenthesis at end of function call}} test expr-old-34.6 {errors in math functions} { list [catch {expr hypot(1.0 ,} msg] $msg } {1 {syntax error in expression "hypot(1.0 ,": premature end of expression}} test expr-old-34.7 {errors in math functions} -body { list [catch {expr hypot(1.0)} msg] $msg } -match glob -result {1 {too few arguments for math function*}} test expr-old-34.8 {errors in math functions} -body { list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg } -match glob -result {1 {too many arguments for math function*}} test expr-old-34.9 {errors in math functions} { list [catch {expr acos(-2.0)} msg] $msg $errorCode } {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}} test expr-old-34.10 {errors in math functions} { list [catch {expr pow(-3, 1000001)} msg] $msg } {0 -Inf} test expr-old-34.11a {errors in math functions} !ieeeFloatingPoint { list [catch {expr pow(3, 1000001)} msg] $msg $errorCode } {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} test expr-old-34.11b {errors in math functions} ieeeFloatingPoint { list [catch {expr pow(3, 1000001)} msg] $msg } {0 Inf} test expr-old-34.12a {errors in math functions} !ieeeFloatingPoint { list [catch {expr -14.0*exp(100000)} msg] $msg $errorCode } {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} test expr-old-34.12b {errors in math functions} ieeeFloatingPoint { list [catch {expr -14.0*exp(100000)} msg] $msg } {0 -Inf} test expr-old-34.13 {errors in math functions} { list [catch {expr int(1.0e30)} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test expr-old-34.14 {errors in math functions} { list [catch {expr int(-1.0e30)} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test expr-old-34.15 {errors in math functions} { list [catch {expr round(1.0e30)} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test expr-old-34.16 {errors in math functions} { list [catch {expr round(-1.0e30)} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test expr-old-34.17 {errors in math functions} -constraints testmathfunctions \ -body { list [catch {expr T1(4)} msg] $msg } -match glob -result {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 |
︙ | ︙ | |||
911 912 913 914 915 916 917 | set x { +22} list [catch {expr {$x+1}} msg] $msg } {0 23} test expr-old-36.6 {ExprLooksLikeInt procedure} { set x { -22} list [catch {expr {$x+1}} msg] $msg } {0 -21} | | | | | | 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 | set x { +22} list [catch {expr {$x+1}} msg] $msg } {0 23} test expr-old-36.6 {ExprLooksLikeInt procedure} { set x { -22} list [catch {expr {$x+1}} msg] $msg } {0 -21} test expr-old-36.7 {ExprLooksLikeInt procedure} { list [catch {expr nan} msg] $msg } {1 {domain error: argument not in valid range}} test expr-old-36.8 {ExprLooksLikeInt procedure} { list [catch {expr 78e1} msg] $msg } {0 780.0} test expr-old-36.9 {ExprLooksLikeInt procedure} { list [catch {expr 24E1} msg] $msg } {0 240.0} test expr-old-36.10 {ExprLooksLikeInt procedure} -body { expr 78e } -returnCodes error -match glob -result {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 "+"}} |
︙ | ︙ | |||
954 955 956 957 958 959 960 961 962 963 | } {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 "+"}} testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprstring [llength [info commands testexprstring]] test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} testexprlong { | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } {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 "+"}} testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] testConstraint longIs32bit [expr {int(0x80000000) < 0}] test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} testexprlong { testexprlong 4+1 } {This is a result: 5} #Check for [Bug 1109484] test expr-old-37.2 {Tcl_ExprLong handles wide ints gracefully} testexprlong { testexprlong wide(1)+2 } {This is a result: 3} test expr-old-37.3 {Tcl_ExprLong on the empty string} testexprlong { testexprlong "" } {This is a result: 0} test expr-old-37.4 {Tcl_ExprLong coerces doubles} testexprlong { testexprlong 3+.14159 } {This is a result: 3} test expr-old-37.5 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { testexprlong 0x80000000 } {This is a result: -2147483648} test expr-old-37.6 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { testexprlong 0xffffffff } {This is a result: -1} test expr-old-37.7 {Tcl_ExprLong handles overflows} \ -constraints {testexprlong longIs32bit} \ -match glob \ -body { list [catch {testexprlong 0x100000000} result] $result } \ -result {1 {integer value too large to represent*}} test expr-old-37.8 {Tcl_ExprLong handles overflows} testexprlong { testexprlong -0x80000000 } {This is a result: -2147483648} test expr-old-37.9 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { testexprlong -0xffffffff } {This is a result: 1} test expr-old-37.10 {Tcl_ExprLong handles overflows} \ -constraints {testexprlong longIs32bit} \ -match glob \ -body { list [catch {testexprlong -0x100000000} result] $result } \ -result {1 {integer value too large to represent*}} test expr-old-37.11 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { testexprlong 2147483648. } {This is a result: -2147483648} test expr-old-37.12 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { testexprlong 4294967295. } {This is a result: -1} test expr-old-37.13 {Tcl_ExprLong handles overflows} \ -constraints {testexprlong longIs32bit} \ -match glob \ -body { list [catch {testexprlong 4294967296.} result] $result } \ -result {1 {integer value too large to represent*}} test expr-old-37.14 {Tcl_ExprLong handles overflows} testexprlong { testexprlong -2147483648. } {This is a result: -2147483648} test expr-old-37.15 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { testexprlong -4294967295. } {This is a result: 1} test expr-old-37.16 {Tcl_ExprLong handles overflows} \ -constraints {testexprlong longIs32bit} \ -match glob \ -body { list [catch {testexprlong 4294967296.} result] $result } \ -result {1 {integer value too large to represent*}} test expr-old-37.17 {Check that Tcl_ExprDouble doesn't modify interpreter result if no error} testexprdouble { testexprdouble 4.+1. } {This is a result: 5.0} #Check for [Bug 1109484] test expr-old-37.18 {Tcl_ExprDouble on the empty string} testexprdouble { testexprdouble "" } {This is a result: 0.0} test expr-old-37.19 {Tcl_ExprDouble coerces wides} testexprdouble { testexprdouble 1[string repeat 0 17] } {This is a result: 1e+17} test expr-old-37.20 {Tcl_ExprDouble coerces bignums} testexprdouble { testexprdouble 1[string repeat 0 38] } {This is a result: 1e+38} test expr-old-37.21 {Tcl_ExprDouble handles overflows} testexprdouble { testexprdouble 17976931348623157[string repeat 0 292]. } {This is a result: 1.7976931348623157e+308} test expr-old-37.22 {Tcl_ExprDouble handles overflows that look like int} \ testexprdouble { testexprdouble 17976931348623157[string repeat 0 292] } {This is a result: 1.7976931348623157e+308} test expr-old-37.23 {Tcl_ExprDouble handles overflows} \ ieeeFloatingPoint&&testexprdouble { testexprdouble 17976931348623165[string repeat 0 292]. } {This is a result: Inf} test expr-old-37.24 {Tcl_ExprDouble handles overflows that look like int} \ ieeeFloatingPoint&&testexprdouble { testexprdouble 17976931348623165[string repeat 0 292] } {This is a result: Inf} test expr-old-37.25 {Tcl_ExprDouble and NaN} \ ieeeFloatingPoint&&testexprdouble { list [catch {testexprdouble 0.0/0.0} result] $result } {1 {floating point value is Not a Number}} test expr-old-38.1 {Verify Tcl_ExprString's basic operation} testexprstring { list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \ [catch {testexprstring "1+"} msg] $msg } {5 10.2 1 {syntax error in expression "1+": premature end of expression}} test expr-old-38.2 {Tcl_ExprString} testexprstring { # This one is "magical" testexprstring {} } 0 test expr-old-38.3 {Tcl_ExprString} -constraints testexprstring -body { testexprstring { } } -returnCodes error -match glob -result * # # Test for bug #908375: rounding numbers that do not fit in a # long but do fit in a wide # test expr-old-39.1 {Rounding with wide result} { set x 1.0e10 set y [expr $x + 0.1] catch { set x [list [expr {$x == round($y)}] [expr $x == -round(-$y)]] } set x } {1 1} unset -nocomplain x y # # TIP #255 min and max math functions # test expr-old-40.1 {min math function} -body { expr {min(0)} } -result 0 test expr-old-40.2 {min math function} -body { expr {min(0.0)} } -result 0.0 test expr-old-40.3 {min math function} -body { list [catch {expr {min()}} msg] $msg } -result {1 {too few arguments to math function "min"}} test expr-old-40.4 {min math function} -body { expr {min(wide(-1) << 30, 4.5, -10)} } -result [expr {wide(-1) << 30}] test expr-old-40.5 {min math function} -body { list [catch {expr {min("a", 0)}} msg] $msg } -result {1 {argument to math function didn't have numeric value}} test expr-old-40.6 {min math function} -body { expr {min(300, "0xFF")} } -result 255 test expr-old-41.1 {max math function} -body { expr {max(0)} } -result 0 test expr-old-41.2 {max math function} -body { expr {max(0.0)} } -result 0.0 test expr-old-41.3 {max math function} -body { list [catch {expr {max()}} msg] $msg } -result {1 {too few arguments to math function "max"}} test expr-old-41.4 {max math function} -body { expr {max(wide(1) << 30, 4.5, -10)} } -result [expr {wide(1) << 30}] test expr-old-41.5 {max math function} -body { list [catch {expr {max("a", 0)}} msg] $msg } -result {1 {argument to math function didn't have numeric value}} test expr-old-41.6 {max math function} -body { expr {max(200, "0xFF")} } -result 255 # Special test for Pentium arithmetic bug of 1994: if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { puts "Warning: this machine contains a defective Pentium processor" puts "that performs arithmetic incorrectly. I recommend that you" puts "call Intel customer service immediately at 1-800-628-8686" puts "to request a replacement processor." } # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to tests/expr.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: expr # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 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 | # 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.30.2.24 2005/08/29 18:38:45 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } testConstraint testmathfunctions [expr { ([catch {expr T1()} msg] != 1) || ($msg ne {unknown math function "T1"}) }] # Determine if "long int" type is a 32 bit number and if the wide # type is a 64 bit number on this machine. testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] testConstraint wideIs64bit \ [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues binary scan [binary format dd -1.0 1.0] c* c switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ ieeeValues(-Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ ieeeValues(+Normal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ ieeeValues(+Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ ieeeValues(NaN) binary scan \x00\x00\x00\x00\x00\x00\xf8\xff d \ ieeeValues(-NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) binary scan \xff\xf8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-NaN) set ieeeValues(littleEndian) 0 return 1 } default { return 0 } } } testConstraint ieeeFloatingPoint [testIEEE] # procedures used below proc put_hello_char {c} { global a append a [format %c $c] return $c } |
︙ | ︙ | |||
59 60 61 62 63 64 65 | "!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \ [string range $c 1 end]]} } proc do_twelve_days {} { global xxx set xxx "" 12days 1 1 1 | | > > | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | "!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \ [string range $c 1 end]]} } proc do_twelve_days {} { global xxx set xxx "" 12days 1 1 1 set result [string length $xxx] unset xxx return $result } # start of tests catch {unset a b i x} test expr-1.1 {TclCompileExprCmd: no expression} { |
︙ | ︙ | |||
140 141 142 143 144 145 146 | set msg } {syntax error in expression "7*2foo": extra tokens at end of expression} test expr-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} { expr {0001} } 1 test expr-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1 | | | | < < | < > < | | > > > > > > > > > | | | 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 | set msg } {syntax error in expression "7*2foo": extra tokens at end of expression} test expr-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} { expr {0001} } 1 test expr-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1 test expr-3.2 {CompileCondExpr: error in lor expr} -body { catch {expr x||3} msg set msg } -match glob -result {syntax error in expression "x||3": * preceding $*} test expr-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44 test expr-3.4 {CompileCondExpr: error compiling true arm} { catch {expr 3>2?2***3:66} msg set msg } {syntax error in expression "3>2?2***3:66": unexpected operator *} test expr-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66 test expr-3.6 {CompileCondExpr: error compiling false arm} { catch {expr 2>3?44:2***3} msg set msg } {syntax error in expression "2>3?44:2***3": unexpected operator *} test expr-3.7 {CompileCondExpr: long arms & nested cond exprs} { hello_world } {Hello world} test expr-3.8 {CompileCondExpr: long arms & nested cond exprs} unix { # Fails with a stack overflow on threaded Windows builds do_twelve_days } 2358 test expr-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1 test expr-4.2 {CompileLorExpr: error in land expr} -body { catch {expr x&&3} msg set msg } -match glob -result {syntax error in expression "x&&3": *preceding $*} test expr-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1 test expr-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1 test expr-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1 test expr-4.6 {CompileLorExpr: error compiling lor arm} { catch {expr 2***3||4.0} msg set msg } {syntax error in expression "2***3||4.0": unexpected operator *} test expr-4.7 {CompileLorExpr: error compiling lor arm} { catch {expr 1.3||2***3} msg set msg } {syntax error in expression "1.3||2***3": unexpected operator *} test expr-4.8 {CompileLorExpr: error compiling lor arms} { list [catch {expr {"a"||"b"}} msg] $msg } {1 {expected boolean value but got "a"}} test expr-4.9 {CompileLorExpr: long lor arm} { set a "abcdefghijkl" set i 7 expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} } 1 test expr-4.10 {CompileLorExpr: error compiling ! operand} { list [catch {expr {!"a"}} msg] $msg } {1 {can't use non-numeric string as operand of "!"}} test expr-4.11 {CompileLorExpr: error compiling land arms} { list [catch {expr {"a"||0}} msg] $msg } {1 {expected boolean value but got "a"}} test expr-4.12 {CompileLorExpr: error compiling land arms} { list [catch {expr {0||"a"}} msg] $msg } {1 {expected boolean value but got "a"}} test expr-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23 test expr-5.2 {CompileLandExpr: error in bitor expr} -body { catch {expr x|3} msg set msg } -match glob -result {syntax error in expression "x|3": * preceding $*} test expr-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0 test expr-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0 test expr-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1 test expr-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1 test expr-5.7 {CompileLandExpr: error compiling land arm} { catch {expr 2***3&&4.0} msg set msg |
︙ | ︙ | |||
217 218 219 220 221 222 223 | test expr-5.10 {CompileLandExpr: long land arms} { set a "abcdefghijkl" set i 7 expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]} } 1 test expr-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3 | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < | | | < | | | < | | | | | | | | | | | | | > > > | | | | | | | 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 | test expr-5.10 {CompileLandExpr: long land arms} { set a "abcdefghijkl" set i 7 expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]} } 1 test expr-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3 test expr-6.2 {CompileBitXorExpr: error in bitand expr} -body { catch {expr x|3} msg set msg } -match glob -result {syntax error in expression "x|3": * preceding $*} test expr-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20 test expr-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19 test expr-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7 test expr-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8 test expr-6.7 {CompileBitXorExpr: error compiling bitxor arm} { catch {expr 2***3|6} msg set msg } {syntax error in expression "2***3|6": unexpected operator *} test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { catch {expr 2^x} msg set msg } -match glob -result {syntax error in expression "2^x": * preceding $**} test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg } {1 {can't use floating-point value as operand of "^"}} test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "^"}} test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1 test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0 test expr-7.5 {CompileBitAndExpr: error in equality expr} -body { catch {expr x==3} msg set msg } -match glob -result {syntax error in expression "x==3": * preceding $*} test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3 test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82 test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2 test expr-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7 test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} { catch {expr 2***3&6} msg set msg } {syntax error in expression "2***3&6": unexpected operator *} test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { catch {expr 2&x} msg set msg } -match glob -result {syntax error in expression "2&x": * preceding $*} test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg } {1 {can't use floating-point value as operand of "&"}} test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "&"}} test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0 test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0 test expr-7.20 {CompileBitAndExpr: error in equality expr} -body { catch {expr xne3} msg set msg } -match glob -result {syntax error in expression "xne3": * preceding $*} test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1 test expr-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1 test expr-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1 test expr-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0 test expr-8.5 {CompileEqualityExpr: error in relational expr} -body { catch {expr x>3} msg set msg } -match glob -result {syntax error in expression "x>3": * preceding $*} test expr-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0 test expr-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1 test expr-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1 test expr-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1 test expr-8.10 {CompileEqualityExpr: error compiling equality arm} { catch {expr 2***3==6} msg set msg } {syntax error in expression "2***3==6": unexpected operator *} test expr-8.11 {CompileEqualityExpr: error compiling equality arm} -body { catch {expr 2!=x} msg set msg } -match glob -result {syntax error in expression "2!=x": * preceding $*} test expr-8.12 {CompileBitAndExpr: equality expr} {expr {"a"eq"a"}} 1 test expr-8.13 {CompileBitAndExpr: equality expr} {expr {"\374" eq "�"}} 1 test expr-8.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0 test expr-8.15 {CompileBitAndExpr: equality expr} {expr 2.0eq2} 0 test expr-8.16 {CompileBitAndExpr: equality expr} {expr 3.2ne2.2} 1 test expr-8.17 {CompileBitAndExpr: equality expr} {expr 01eq1} 0 test expr-8.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0 test expr-8.19 {CompileBitAndExpr: equality expr} {expr {"abc" ne "abd"}} 1 test expr-8.20 {CompileBitAndExpr: error in equality expr} -body { catch {expr x ne3} msg set msg } -match glob -result {syntax error in expression "x ne3": * preceding $*} test expr-8.21 {CompileBitAndExpr: error in equality expr} -body { # These should be ""ed to avoid the error catch {expr a eq b} msg set msg } -match glob -result {syntax error in expression "a eq b": * preceding $*} test expr-8.22 {CompileBitAndExpr: error in equality expr} { catch {expr {false eqfalse}} msg set msg } {syntax error in expression "false eqfalse": extra tokens at end of expression} test expr-8.23 {CompileBitAndExpr: error in equality expr} { catch {expr {false nefalse}} msg set msg } {syntax error in expression "false nefalse": extra tokens at end of expression} test expr-8.24 {CompileEqualityExpr: simple equality exprs} { set x 12398712938788234 expr {$x == 100} } 0 test expr-8.25 {CompileEqualityExpr: simple equality exprs} { expr {"0x12 " == "0x12"} } 1 test expr-8.26 {CompileEqualityExpr: simple equality exprs} { expr {"0x12 " eq "0x12"} } 0 test expr-8.27 {CompileEqualityExpr: simple equality exprs} { expr {"1.0e100000000" == "0.0"} } 0 test expr-8.28 {CompileEqualityExpr: just relational expr} { expr {"0y" == "0x0"} } 0 test expr-8.29 {CompileEqualityExpr: just relational expr} { # Compare original strings from variables. set v1 "0y" set v2 "0x12" expr {$v1 < $v2} } 0 test expr-8.30 {CompileEqualityExpr: simple equality exprs} { expr {"fake" != "bob"} } 1 test expr-8.31 {expr edge cases} { list [catch {expr {1e}} err] $err } {1 {syntax error in expression "1e": extra tokens at end of expression}} test expr-8.32 {expr edge cases} { list [catch {expr {1E}} err] $err } {1 {syntax error in expression "1E": extra tokens at end of expression}} test expr-8.33 {expr edge cases} { list [catch {expr {1e+}} err] $err } {1 {syntax error in expression "1e+": extra tokens at end of expression}} test expr-8.34 {expr edge cases} { list [catch {expr {1E+}} err] $err } {1 {syntax error in expression "1E+": extra tokens at end of expression}} test expr-8.35 {expr edge cases} { list [catch {expr {1ea}} err] $err } {1 {syntax error in expression "1ea": extra tokens at end of expression}} test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit { expr {1<<63} } -9223372036854775808 test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit { expr {1<<31} } -2147483648 test expr-9.6 {CompileRelationalExpr: error in shift expr} -body { catch {expr x>>3} msg set msg } -match glob -result {syntax error in expression "x>>3": * preceding $*} test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1 test expr-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1 test expr-9.9 {CompileRelationalExpr: error compiling relational arm} { catch {expr 2***3>6} msg set msg } {syntax error in expression "2***3>6": unexpected operator *} test expr-9.10 {CompileRelationalExpr: error compiling relational arm} -body { catch {expr 2<x} msg set msg } -match glob -result {syntax error in expression "2<x": * preceding $*} test expr-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2 test expr-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253 test expr-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1 test expr-10.4 {CompileShiftExpr: just add expr} {expr 1-0123} -82 test expr-10.5 {CompileShiftExpr: error in add expr} -body { catch {expr x+3} msg set msg } -match glob -result {syntax error in expression "x+3": * preceding $*} test expr-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31 test expr-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936 test expr-10.8 {CompileShiftExpr: error compiling shift arm} { catch {expr 2***3>>6} msg set msg } {syntax error in expression "2***3>>6": unexpected operator *} test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body { catch {expr 2<<x} msg set msg } -match glob -result {syntax error in expression "2<<x": * preceding $*} test expr-10.10 {CompileShiftExpr: runtime error} { list [catch {expr {24.0>>43}} msg] $msg } {1 {can't use floating-point value as operand of ">>"}} test expr-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "<<"}} test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1 test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6 test expr-11.5 {CompileAddExpr: error in multiply expr} -body { catch {expr x*3} msg set msg } -match glob -result {syntax error in expression "x*3": * preceding $*} test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258 test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239 test expr-11.8 {CompileAddExpr: error compiling add arm} { catch {expr 2***3+6} msg set msg } {syntax error in expression "2***3+6": unexpected operator *} test expr-11.9 {CompileAddExpr: error compiling add arm} -body { catch {expr 2-x} msg set msg } -match glob -result {syntax error in expression "2-x": * preceding $*} test expr-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg } {1 {can't use non-numeric string as operand of "+"}} test expr-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "-"}} test expr-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} test expr-11.13a {CompileAddExpr: runtime error} !ieeeFloatingPoint { list [catch {expr {2.3/0.0}} msg] $msg } {1 {divide by zero}} test expr-11.13b {CompileAddExpr: runtime error} ieeeFloatingPoint { list [catch {expr {2.3/0.0}} msg] $msg } {0 Inf} test expr-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5 test expr-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5 test expr-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0 test expr-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936 test expr-12.5 {CompileMultiplyExpr: error in unary expr} -body { catch {expr ~x} msg set msg } -match glob -result {syntax error in expression "~x": * preceding $*} test expr-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765 test expr-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2 test expr-12.8 {CompileMultiplyExpr: error compiling multiply arm} { catch {expr 2*3%%6} msg set msg } {syntax error in expression "2*3%%6": unexpected operator %} test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body { catch {expr 2*x} msg set msg } -match glob -result {syntax error in expression "2*x": * preceding $*} test expr-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg } {1 {can't use non-numeric string as operand of "*"}} test expr-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "/"}} test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 83 test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36 test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0 test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0 test expr-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1 test expr-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0 test expr-13.8 {CompileUnaryExpr: error compiling unary expr} -body { catch {expr ~x} msg set msg } -match glob -result {syntax error in expression "~x": * preceding $*} test expr-13.9 {CompileUnaryExpr: error compiling unary expr} { catch {expr !1.x} msg set msg } {syntax error in expression "!1.x": extra tokens at end of expression} test expr-13.10 {CompileUnaryExpr: runtime error} { list [catch {expr {~"xx"}} msg] $msg } {1 {can't use non-numeric string as operand of "~"}} |
︙ | ︙ | |||
561 562 563 564 565 566 567 | } 2.71828 test expr-14.26 {CompilePrimaryExpr: math function primary} { format %.6g [expr pow(2.0+0.1,3.0+0.1)] } 9.97424 test expr-14.27 {CompilePrimaryExpr: error in math function primary} -body { catch {expr sinh::(2.0)} msg set errorInfo | | | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 | } 2.71828 test expr-14.26 {CompilePrimaryExpr: math function primary} { format %.6g [expr pow(2.0+0.1,3.0+0.1)] } 9.97424 test expr-14.27 {CompilePrimaryExpr: error in math function primary} -body { catch {expr sinh::(2.0)} msg set errorInfo } -match glob -result {syntax error in expression "sinh::(2.0)": * function arguments* while *ing "expr sinh::(2.0)"} test expr-14.28 {CompilePrimaryExpr: subexpression primary} { expr 2+(3*4) } 14 test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} -body { catch {expr 2+(3*[set])} msg |
︙ | ︙ | |||
593 594 595 596 597 598 599 | } -match glob -result {syntax error in expression "@": character not legal in expressions while *ing "expr @"} test expr-15.1 {CompileMathFuncCall: missing parenthesis} -body { catch {expr sinh2.0)} msg set errorInfo | | | | | | | 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 | } -match glob -result {syntax error in expression "@": character not legal in expressions while *ing "expr @"} test expr-15.1 {CompileMathFuncCall: missing parenthesis} -body { catch {expr sinh2.0)} msg set errorInfo } -match glob -result {syntax error in expression "sinh2.0)": * preceding $* while *ing "expr sinh2.0)"} test expr-15.2 {CompileMathFuncCall: unknown math function} -body { catch {expr whazzathuh(1)} msg set errorInfo } -match glob -result {* "*whazzathuh" while *ing "expr whazzathuh(1)"} test expr-15.3 {CompileMathFuncCall: too many arguments} -body { catch {expr sin(1,2,3)} msg set errorInfo } -match glob -result {too many arguments for math function* while *ing "expr sin(1,2,3)"} test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} -body { catch {expr sin()} msg set errorInfo } -match glob -result {too few arguments for math function* while *ing "expr sin()"} test expr-15.5 {CompileMathFuncCall: too few arguments} -body { catch {expr pow(1)} msg set errorInfo } -match glob -result {too few arguments for math function* while *ing "expr pow(1)"} test expr-15.6 {CompileMathFuncCall: missing ')'} -body { catch {expr sin(1} msg set errorInfo } -match glob -result {syntax error in expression "sin(1": missing close parenthesis at end of function call while *ing |
︙ | ︙ | |||
774 775 776 777 778 779 780 781 782 | test expr-21.6 {non-numeric boolean literals} {expr yes } yes 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. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < | | | | | | | | | | | | | 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 | test expr-21.6 {non-numeric boolean literals} {expr yes } yes 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 expr-21.13 {non-numeric boolean literals} { list [catch {expr !truef} err] $err } {1 {syntax error in expression "!truef": the word "truef" requires a preceding $ if it's a variable or function arguments if it's a function}} test expr-21.14 {non-numeric boolean literals} { list [catch {expr !"truef"} err] $err } {1 {can't use non-numeric string as operand of "!"}} test expr-21.15 {non-numeric boolean variables} { set v truef list [catch {expr {!$v}} err] $err } {1 {can't use non-numeric string as operand of "!"}} test expr-21.16 {non-numeric boolean variables} { set v "true " list [catch {expr {!$v}} err] $err } {1 {can't use non-numeric string as operand of "!"}} test expr-21.17 {non-numeric boolean variables} { set v "tru" list [catch {expr {!$v}} err] $err } {0 0} test expr-21.18 {non-numeric boolean variables} { set v "fal" list [catch {expr {!$v}} err] $err } {0 1} test expr-21.19 {non-numeric boolean variables} { set v "y" list [catch {expr {!$v}} err] $err } {0 0} test expr-21.20 {non-numeric boolean variables} { set v "of" list [catch {expr {!$v}} err] $err } {0 1} test expr-21.21 {non-numeric boolean variables} { set v "o" list [catch {expr {!$v}} err] $err } {1 {can't use non-numeric string as operand of "!"}} test expr-21.22 {non-numeric boolean variables} { set v "" list [catch {expr {!$v}} err] $err } {1 {can't use empty string as operand of "!"}} # Test for non-numeric float handling. test expr-22.1 {non-numeric floats} { 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} !ieeeFloatingPoint { 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} { 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} !ieeeFloatingPoint { 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} { list [catch {expr NaN} msg] $msg } {1 {domain error: argument not in valid range}} test expr-22.6 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr Inf} msg] $msg } {1 {floating-point value too large to represent}} test expr-22.7 {non-numeric floats} { 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} !ieeeFloatingPoint { list [catch {expr {1 / Inf}} msg] $msg } {1 {can't use infinite floating-point value as operand of "/"}} # Make sure [Bug 761471] stays fixed. test expr-22.9 {non-numeric floats: shared object equality and NaN} { set x NaN expr {$x == $x} } 0 # Tests for exponentiation handling test expr-23.1 {CompileExponentialExpr: just exponential expr} {expr 4**2} 16 test expr-23.2 {CompileExponentialExpr: just exponential expr} {expr 0xff**2} 65025 test expr-23.3 {CompileExponentialExpr: just exponential expr} {expr -1**2} 1 test expr-23.4 {CompileExponentialExpr: just exponential expr} {expr 18**07} 612220032 test expr-23.5 {CompileExponentialExpr: error in exponential expr} -body { catch {expr x**3} msg set msg } -match glob -result {syntax error in expression "x**3": * preceding $*} test expr-23.6 {CompileExponentialExpr: simple expo exprs} {expr 0xff**0x3} 16581375 test expr-23.7 {CompileExponentialExpr: error compiling expo arm} { catch {expr (-3-)**6} msg set msg } {syntax error in expression "(-3-)**6": unexpected close parenthesis} test expr-23.8 {CompileExponentialExpr: error compiling expo arm} -body { catch {expr 2**x} msg set msg } -match glob -result {syntax error in expression "2**x": * preceding $*} test expr-23.9 {CompileExponentialExpr: runtime error} { list [catch {expr {24.0**"xx"}} msg] $msg } {1 {can't use non-numeric string as operand of "**"}} test expr-23.10 {CompileExponentialExpr: runtime error} { list [catch {expr {"a"**2}} msg] $msg } {1 {can't use non-numeric string as operand of "**"}} test expr-23.11 {CompileExponentialExpr: runtime error} { |
︙ | ︙ | |||
864 865 866 867 868 869 870 871 872 873 874 875 876 | test expr-23.27 {INST_EXPON: special cases} {expr {wide(-2)**wide(0)}} 1 test expr-23.28 {INST_EXPON: special cases} {expr {wide(-1)**wide(1)}} -1 test expr-23.29 {INST_EXPON: special cases} {expr {wide(-1)**wide(0)}} 1 test expr-23.30 {INST_EXPON: special cases} {expr {wide(-1)**wide(2)}} 1 test expr-23.31 {INST_EXPON: special cases} {expr {wide(-1)**wide(-1)}} -1 test expr-23.32 {INST_EXPON: special cases} {expr {wide(1)**wide(1234567)}} 1 test expr-23.33 {INST_EXPON: special cases} {expr {wide(2)**wide(-2)}} 0 # Some compilers get this wrong; ensure that we work around it correctly test expr-24.1 {expr edge cases; shifting} {expr int(5)>>32} 0 test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0 test expr-24.3 {expr edge cases; shifting} {expr wide(5)>>32} 0 test expr-24.4 {expr edge cases; shifting} {expr wide(5)>>63} 0 | > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 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 | test expr-23.27 {INST_EXPON: special cases} {expr {wide(-2)**wide(0)}} 1 test expr-23.28 {INST_EXPON: special cases} {expr {wide(-1)**wide(1)}} -1 test expr-23.29 {INST_EXPON: special cases} {expr {wide(-1)**wide(0)}} 1 test expr-23.30 {INST_EXPON: special cases} {expr {wide(-1)**wide(2)}} 1 test expr-23.31 {INST_EXPON: special cases} {expr {wide(-1)**wide(-1)}} -1 test expr-23.32 {INST_EXPON: special cases} {expr {wide(1)**wide(1234567)}} 1 test expr-23.33 {INST_EXPON: special cases} {expr {wide(2)**wide(-2)}} 0 test expr-23.34 {INST_EXPON: special cases} {expr {2**0}} 1 test expr-23.35 {INST_EXPON: special cases} {expr {wide(2)**0}} 1 # Some compilers get this wrong; ensure that we work around it correctly test expr-24.1 {expr edge cases; shifting} {expr int(5)>>32} 0 test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0 test expr-24.3 {expr edge cases; shifting} {expr wide(5)>>32} 0 test expr-24.4 {expr edge cases; shifting} {expr wide(5)>>63} 0 test expr-24.5 {expr edge cases; shifting} longIs32bit {expr int(5)<<32} 0 test expr-24.6 {expr edge cases; shifting} longIs32bit {expr int(5)<<63} 0 test expr-24.7 {expr edge cases; shifting} {expr wide(5)<<32} 21474836480 test expr-24.8 {expr edge cases; shifting} {expr wide(10)<<63} 0 test expr-24.9 {expr edge cases; shifting} {expr 5>>32} 0 # List membership tests test expr-25.1 {'in' operator} {expr {"a" in "a b c"}} 1 test expr-25.2 {'in' operator} {expr {"a" in "b a c"}} 1 test expr-25.3 {'in' operator} {expr {"a" in "b c a"}} 1 test expr-25.4 {'in' operator} {expr {"a" in ""}} 0 test expr-25.5 {'in' operator} {expr {"" in {a b c ""}}} 1 test expr-25.6 {'in' operator} {expr {"" in "a b c"}} 0 test expr-25.7 {'in' operator} {expr {"" in ""}} 0 test expr-26.1 {'ni' operator} {expr {"a" ni "a b c"}} 0 test expr-26.2 {'ni' operator} {expr {"a" ni "b a c"}} 0 test expr-26.3 {'ni' operator} {expr {"a" ni "b c a"}} 0 test expr-26.4 {'ni' operator} {expr {"a" ni ""}} 1 test expr-26.5 {'ni' operator} {expr {"" ni {a b c ""}}} 0 test expr-26.6 {'ni' operator} {expr {"" ni "a b c"}} 1 test expr-26.7 {'ni' operator} {expr {"" ni ""}} 1 foreach op {< <= == != > >=} { proc test$op {a b} [list expr "\$a $op \$b"] } test expr-27.1 {expr - correct ordering - not compiled} ieeeFloatingPoint { set problems {} # Ordering should be: -Infinity < -Normal < Subnormal < -0 # < +0 < +Subnormal < +Normal < +Infinity # with equality within each class. set names { -Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity } set weights { -3 -2 -1 0 0 1 2 3 } foreach name1 $names weight1 $weights { foreach name2 $names weight2 $weights { foreach op {< <= == != >= >} { set shouldBe [expr "$weight1 $op $weight2"] set is [expr "\$ieeeValues($name1) $op \$ieeeValues($name2)"] if { $is != $shouldBe } { append problems $name1 { } $op { } $name2 \ ":result is " $is ", should be $shouldBe" \n } } } } set problems } {} test expr-27.2 {expr - correct ordering - compiled} ieeeFloatingPoint { set problems {} # Ordering should be: -Infinity < -Normal < Subnormal < -0 # < +0 < +Subnormal < +Normal < +Infinity # with equality within each class. set names { -Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity } set weights { -3 -2 -1 0 0 1 2 3 } foreach name1 $names weight1 $weights { foreach name2 $names weight2 $weights { foreach op {< <= == != >= >} { set shouldBe [expr "$weight1 $op $weight2"] set is [test$op $ieeeValues($name1) $ieeeValues($name2)] if { $is != $shouldBe } { append problems $name1 { } $op { } $name2 \ ":result is " $is ", should be $shouldBe" \n } } } } set problems } {} test expr-27.3 {expr - NaN is unordered - not compiled} { set problems {} set names { -Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity NaN } foreach name1 $names { foreach op {< <= == != >= >} sb {0 0 0 1 0 0} { if "(\$ieeeValues($name1) $op \$ieeeValues(NaN)) != $sb " { append problems $name1 { } $op { } NaN \ ": result is 1, should be $sb" \n } if "(\$ieeeValues(NaN) $op \$ieeeValues($name1)) != $sb" { append problems NaN { } $op { } $name1 \ ": result is 1, should be $sb" \n } } } set problems } {} test expr-27.4 {expr - NaN is unordered - compiled} { set problems {} set names { -Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity NaN } foreach name1 $names { foreach op {< <= == != >= >} sb {0 0 0 1 0 0} { if { [test$op $ieeeValues($name1) $ieeeValues(NaN)] != $sb } { append problems $ieeeValues($name1) { } $op { } $ieeeValues(NaN) \ ": result is 1, should be $sb" \n } if { [test$op $ieeeValues(NaN) $ieeeValues($name1)] != $sb } { append problems NaN { } $op { } $ieeeValues($name1) \ ": result is 1, should be $sb" \n } } } set problems } {} proc convertToDouble { x } { variable ieeeValues binary scan [binary format d $x] c* bytes set result 0x if { $ieeeValues(littleEndian) } { for { set i 7 } { $i >= 0 } { incr i -1 } { append result [format %02x [expr { [lindex $bytes $i] & 0xff }]] } } else { foreach byte $bytes { append result [format %02x [expr { $byte & 0xff }]] } } return $result } test expr-28.1 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d ALL 0 E0 OK 00000000000000 E-1023 convertToDouble 0E0 } 0x0000000000000000 test expr-28.2 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d ALL -0 E0 OK -0000000000000 E-1023 convertToDouble -0E0 } 0x8000000000000000 test expr-28.3 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d ALL 1 E0 OK 10000000000000 E0 convertToDouble 1E0 } 0x3ff0000000000000 test expr-28.4 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d ALL 15 E-1 OK 18000000000000 E0 convertToDouble 15E-1 } 0x3ff8000000000000 test expr-28.5 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d ALL 125 E-2 OK 14000000000000 E0 convertToDouble 125E-2 } 0x3ff4000000000000 test expr-28.6 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d ALL 1125 E-3 OK 12000000000000 E0 convertToDouble 1125E-3 } 0x3ff2000000000000 test expr-28.7 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d ALL 10625 E-4 OK 11000000000000 E0 convertToDouble 10625E-4 } 0x3ff1000000000000 test expr-28.8 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d ALL 103125 E-5 OK 10800000000000 E0 convertToDouble 103125E-5 } 0x3ff0800000000000 test expr-28.9 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d ALL 1015625 E-6 OK 10400000000000 E0 convertToDouble 1015625E-6 } 0x3ff0400000000000 test expr-28.10 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d ALL 10078125 E-7 OK 10200000000000 E0 convertToDouble 10078125E-7 } 0x3ff0200000000000 test expr-28.11 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d ALL 100390625 E-8 OK 10100000000000 E0 convertToDouble 100390625E-8 } 0x3ff0100000000000 test expr-28.12 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee ALL 1001953125 E-9 OK 10080000000000 E0 convertToDouble 1001953125E-9 } 0x3ff0080000000000 test expr-28.13 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee ALL 10009765625 E-10 OK 10040000000000 E0 convertToDouble 10009765625E-10 } 0x3ff0040000000000 test expr-28.14 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee ALL 100048828125 E-11 OK 10020000000000 E0 convertToDouble 100048828125E-11 } 0x3ff0020000000000 test expr-28.15 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee ALL 1000244140625 E-12 OK 10010000000000 E0 convertToDouble 1000244140625E-12 } 0x3ff0010000000000 test expr-28.16 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee ALL 10001220703125 E-13 OK 10008000000000 E0 convertToDouble 10001220703125E-13 } 0x3ff0008000000000 test expr-28.17 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee ALL 100006103515625 E-14 OK 10004000000000 E0 convertToDouble 100006103515625E-14 } 0x3ff0004000000000 test expr-28.18 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee ALL 1000030517578125 E-15 OK 10002000000000 E0 convertToDouble 1000030517578125E-15 } 0x3ff0002000000000 test expr-28.19 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee ALL 10000152587890625 E-16 OK 10001000000000 E0 convertToDouble 10000152587890625E-16 } 0x3ff0001000000000 test expr-28.20 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8 E153 x 1317e5ef3ab327_0000000001& E511 convertToDouble +8E153 } 0x5fe317e5ef3ab327 test expr-28.21 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -1 E153 x -1317e5ef3ab327_0000000001& E508 convertToDouble -1E153 } 0xdfb317e5ef3ab327 test expr-28.22 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +9 E306 x 19a2028368022e_00000000001& E1019 convertToDouble +9E306 } 0x7fa9a2028368022e test expr-28.23 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -2 E153 x -1317e5ef3ab327_0000000001& E509 convertToDouble -2E153 } 0xdfc317e5ef3ab327 test expr-28.24 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7 E-304 x 1eb8e84fa0b278_00000000001& E-1008 convertToDouble +7E-304 } 0x00feb8e84fa0b278 test expr-28.25 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3 E-49 x -1c0f92a6276c9d_000000001& E-162 convertToDouble -3E-49 } 0xb5dc0f92a6276c9d test expr-28.26 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7 E-303 x 13339131c46f8b_00000000001& E-1004 convertToDouble +7E-303 } 0x0133339131c46f8b test expr-28.27 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -6 E-49 x -1c0f92a6276c9d_000000001& E-161 convertToDouble -6E-49 } 0xb5ec0f92a6276c9d test expr-28.28 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +9 E43 x 102498ea6df0c3_11111111110& E146 convertToDouble +9E43 } 0x49102498ea6df0c4 test expr-28.29 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -9 E44 x -142dbf25096cf4_1111111110& E149 convertToDouble -9E44 } 0xc9442dbf25096cf5 test expr-28.30 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8 E303 x 1754e31cd072d9_1111111110& E1009 convertToDouble +8E303 } 0x7f0754e31cd072da test expr-28.31 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -1 E303 x -1754e31cd072d9_1111111110& E1006 convertToDouble -1E303 } 0xfed754e31cd072da test expr-28.32 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7 E-287 x 1551603777f798_111111110& E-951 convertToDouble +7E-287 } 0x048551603777f799 test expr-28.33 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -2 E-204 x -1410d9f9b2f7f2_11111110& E-677 convertToDouble -2E-204 } 0x95a410d9f9b2f7f3 test expr-28.34 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +2 E-205 x 100d7b2e28c65b_11111110& E-680 convertToDouble +2E-205 } 0x15700d7b2e28c65c test expr-28.35 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -9 E-47 x -10711fed5b19a3_11111110& E-153 convertToDouble -9E-47 } 0xb660711fed5b19a4 test expr-28.36 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +34 E195 x 1d1c26db7d0dae_000000000001& E652 convertToDouble +34E195 } 0x68bd1c26db7d0dae test expr-28.37 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -68 E195 x -1d1c26db7d0dae_000000000001& E653 convertToDouble -68E195 } 0xe8cd1c26db7d0dae test expr-28.38 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +85 E194 x 1d1c26db7d0dae_000000000001& E650 convertToDouble +85E194 } 0x689d1c26db7d0dae test expr-28.39 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -67 E97 x -139ac1ce2cc95f_000000000001& E328 convertToDouble -67E97 } 0xd4739ac1ce2cc95f test expr-28.40 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +93 E-234 x 127b2e4f210075_0000000000000001& E-771 convertToDouble +93E-234 } 0x0fc27b2e4f210075 test expr-28.41 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -19 E-87 x -12e5f5dfa4fe9d_00000000000001& E-285 convertToDouble -19E-87 } 0xae22e5f5dfa4fe9d test expr-28.42 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +38 E-87 x 12e5f5dfa4fe9d_00000000000001& E-284 convertToDouble +38E-87 } 0x2e32e5f5dfa4fe9d test expr-28.43 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -38 E-88 x -1e3cbc9907fdc8_00000000000001& E-288 convertToDouble -38E-88 } 0xadfe3cbc9907fdc8 test expr-28.44 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -69 E220 x -1e8aa8823a5db3_11111111110& E736 convertToDouble -69E220 } 0xedfe8aa8823a5db4 test expr-28.45 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +18 E43 x 102498ea6df0c3_11111111110& E147 convertToDouble +18E43 } 0x49202498ea6df0c4 test expr-28.46 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -36 E43 x -102498ea6df0c3_11111111110& E148 convertToDouble -36E43 } 0xc9302498ea6df0c4 test expr-28.47 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +61 E-99 x 10ad836f269a16_11111111111110& E-323 convertToDouble +61E-99 } 0x2bc0ad836f269a17 test expr-28.48 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -43 E-92 x -1c0794d9d40e95_111111111111110& E-301 convertToDouble -43E-92 } 0xad2c0794d9d40e96 test expr-28.49 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +86 E-92 x 1c0794d9d40e95_111111111111110& E-300 convertToDouble +86E-92 } 0x2d3c0794d9d40e96 test expr-28.50 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -51 E-74 x -1cd5bee57763e5_1111111111111110& E-241 convertToDouble -51E-74 } 0xb0ecd5bee57763e6 test expr-28.51 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +283 E85 x 16c309024bab4b_00000000000000001& E290 convertToDouble +283E85 } 0x5216c309024bab4b test expr-28.52 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -566 E85 x -16c309024bab4b_00000000000000001& E291 convertToDouble -566E85 } 0xd226c309024bab4b test expr-28.53 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +589 E187 x 1526be9c22eb17_00000000000000001& E630 convertToDouble +589E187 } 0x675526be9c22eb17 test expr-28.54 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -839 E143 x -1ae03f245703e2_000000000000001& E484 convertToDouble -839E143 } 0xde3ae03f245703e2 test expr-28.55 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -744 E-234 x -127b2e4f210075_0000000000000001& E-768 convertToDouble -744E-234 } 0x8ff27b2e4f210075 test expr-28.56 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +930 E-235 x 127b2e4f210075_0000000000000001& E-771 convertToDouble +930E-235 } 0x0fc27b2e4f210075 test expr-28.57 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -186 E-234 x -127b2e4f210075_0000000000000001& E-770 convertToDouble -186E-234 } 0x8fd27b2e4f210075 test expr-28.58 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +604 E175 x 17d93193f78fc5_1111111111111111110& E590 convertToDouble +604E175 } 0x64d7d93193f78fc6 test expr-28.59 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -302 E175 x -17d93193f78fc5_1111111111111111110& E589 convertToDouble -302E175 } 0xe4c7d93193f78fc6 test expr-28.60 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +755 E174 x 17d93193f78fc5_1111111111111111110& E587 convertToDouble +755E174 } 0x64a7d93193f78fc6 test expr-28.61 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -151 E175 x -17d93193f78fc5_1111111111111111110& E588 convertToDouble -151E175 } 0xe4b7d93193f78fc6 test expr-28.62 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +662 E-213 x 1bdb90e62a8cbc_1111111111111110& E-699 convertToDouble +662E-213 } 0x144bdb90e62a8cbd test expr-28.63 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -408 E-74 x -1cd5bee57763e5_1111111111111110& E-238 convertToDouble -408E-74 } 0xb11cd5bee57763e6 test expr-28.64 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +510 E-75 x 1cd5bee57763e5_1111111111111110& E-241 convertToDouble +510E-75 } 0x30ecd5bee57763e6 test expr-28.65 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +6782 E55 x 159bd3ad46e346_0000000000000000001& E195 convertToDouble +6782E55 } 0x4c259bd3ad46e346 test expr-28.66 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -2309 E92 x -1bac6f7d64d119_000000000000000001& E316 convertToDouble -2309E92 } 0xd3bbac6f7d64d119 test expr-28.67 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7963 E34 x 1df4170f0fdecc_00000000000000000001& E125 convertToDouble +7963E34 } 0x47cdf4170f0fdecc test expr-28.68 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3391 E55 x -159bd3ad46e346_0000000000000000001& E194 convertToDouble -3391E55 } 0xcc159bd3ad46e346 test expr-28.69 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7903 E-96 x 107c2d27a5b989_0000000000000000001& E-306 convertToDouble +7903E-96 } 0x2cd07c2d27a5b989 test expr-28.70 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -7611 E-226 x -119b8744033457_0000000000000000001& E-738 convertToDouble -7611E-226 } 0x91d19b8744033457 test expr-28.71 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +4907 E-196 x 11e90a8711440f_000000000000000001& E-639 convertToDouble +4907E-196 } 0x1801e90a8711440f test expr-28.72 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -5547 E-311 x -13f190452a29f4_000000000000000001& E-1021 convertToDouble -5547E-311 } 0x8023f190452a29f4 test expr-28.73 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +5311 E241 x 1f1ce3c887c25f_11111111111111111110& E812 convertToDouble +5311E241 } 0x72bf1ce3c887c260 test expr-28.74 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -5311 E243 x -184e91f4aa0fda_11111111111111111110& E819 convertToDouble -5311E243 } 0xf3284e91f4aa0fdb test expr-28.75 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +5311 E242 x 13720e5d54d97b_11111111111111111110& E816 convertToDouble +5311E242 } 0x72f3720e5d54d97c test expr-28.76 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +9269 E-45 x 19d69455a53bd8_111111111111111111110& E-137 convertToDouble +9269E-45 } 0x3769d69455a53bd9 test expr-28.77 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -8559 E-289 x -104a81d35952fe_11111111111111111110& E-947 convertToDouble -8559E-289 } 0x84c04a81d35952ff test expr-28.78 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8699 E-276 x 12d2df246ecd2c_1111111111111111111110& E-904 convertToDouble +8699E-276 } 0x0772d2df246ecd2d test expr-28.79 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -8085 E-64 x -14c98fce16152d_1111111111111111110& E-200 convertToDouble -8085E-64 } 0xb374c98fce16152e test expr-28.80 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +74819 E201 x 1dd455061eb3f1_0000000000000000000001& E683 convertToDouble +74819E201 } 0x6aadd455061eb3f1 test expr-28.81 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -82081 E41 x -170105df3d47cb_000000000000000000000000001& E152 convertToDouble -82081E41 } 0xc9770105df3d47cb test expr-28.82 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +51881 E37 x 17d2950dc76da4_000000000000000000001& E138 convertToDouble +51881E37 } 0x4897d2950dc76da4 test expr-28.83 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -55061 E157 x -1394fc0f33536c_000000000000000000001& E537 convertToDouble -55061E157 } 0xe18394fc0f33536c test expr-28.84 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +77402 E-215 x 10492a4a8a37fd_0000000000000000000000001& E-698 convertToDouble +77402E-215 } 0x1450492a4a8a37fd test expr-28.85 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -33891 E-92 x -1592f9932c06bd_00000000000000000000001& E-291 convertToDouble -33891E-92 } 0xadc592f9932c06bd test expr-28.86 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +38701 E-215 x 10492a4a8a37fd_0000000000000000000000001& E-699 convertToDouble +38701E-215 } 0x1440492a4a8a37fd test expr-28.87 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -82139 E-76 x -1d0681489839d5_00000000000000000000001& E-237 convertToDouble -82139E-76 } 0xb12d0681489839d5 test expr-28.88 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +75859 E25 x 132645e1ba93ef_11111111111111111111110& E99 convertToDouble +75859E25 } 0x46232645e1ba93f0 test expr-28.89 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +89509 E140 x 16f02bee68670c_1111111111111111111110& E481 convertToDouble +89509E140 } 0x5e06f02bee68670d test expr-28.90 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -57533 E287 x -1272ed2307f569_1111111111111111111110& E969 convertToDouble -57533E287 } 0xfc8272ed2307f56a test expr-28.91 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +46073 E-32 x 12405b773fbdf2_11111111111111111111110& E-91 convertToDouble +46073E-32 } 0x3a42405b773fbdf3 test expr-28.92 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -92146 E-32 x -12405b773fbdf2_11111111111111111111110& E-90 convertToDouble -92146E-32 } 0xba52405b773fbdf3 test expr-28.93 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +83771 E-74 x 17206bfc4ccabd_11111111111111111111110& E-230 convertToDouble +83771E-74 } 0x3197206bfc4ccabe test expr-28.94 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -34796 E-276 x -12d2df246ecd2c_1111111111111111111110& E-902 convertToDouble -34796E-276 } 0x8792d2df246ecd2d test expr-28.95 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +584169 E229 x 1d657059dc79aa_00000000000000000000000000001& E779 convertToDouble +584169E229 } 0x70ad657059dc79aa test expr-28.96 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +164162 E41 x 170105df3d47cb_000000000000000000000000001& E153 convertToDouble +164162E41 } 0x49870105df3d47cb test expr-28.97 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -328324 E41 x -170105df3d47cb_000000000000000000000000001& E154 convertToDouble -328324E41 } 0xc9970105df3d47cb test expr-28.98 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +209901 E-11 x 119b96f36ec68b_00000000000000000000000001& E-19 convertToDouble +209901E-11 } 0x3ec19b96f36ec68b test expr-28.99 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -419802 E-11 x -119b96f36ec68b_00000000000000000000000001& E-18 convertToDouble -419802E-11 } 0xbed19b96f36ec68b test expr-28.100 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +940189 E-112 x 1b99d6240c1a28_00000000000000000000000001& E-353 convertToDouble +940189E-112 } 0x29eb99d6240c1a28 test expr-28.101 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -892771 E-213 x -125818c7294f27_0000000000000000000000000001& E-688 convertToDouble -892771E-213 } 0x94f25818c7294f27 test expr-28.102 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +757803 E120 x 11e968b555bb80_11111111111111111111111111110& E418 convertToDouble +757803E120 } 0x5a11e968b555bb81 test expr-28.103 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -252601 E120 x -17e1e0f1c7a4ab_11111111111111111111111111110& E416 convertToDouble -252601E120 } 0xd9f7e1e0f1c7a4ac test expr-28.104 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +252601 E121 x 1dda592e398dd6_1111111111111111111111111110& E419 convertToDouble +252601E121 } 0x5a2dda592e398dd7 test expr-28.105 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -505202 E120 x -17e1e0f1c7a4ab_11111111111111111111111111110& E417 convertToDouble -505202E120 } 0xda07e1e0f1c7a4ac test expr-28.106 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +970811 E-264 x 1dda6b965c9629_11111111111111111111111110& E-858 convertToDouble +970811E-264 } 0x0a5dda6b965c962a test expr-28.107 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -654839 E-60 x -100e7db3b3f241_111111111111111111111111110& E-180 convertToDouble -654839E-60 } 0xb4b00e7db3b3f242 test expr-28.108 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +289767 E-178 x 1caad28f23a100_11111111111111111111111110& E-574 convertToDouble +289767E-178 } 0x1c1caad28f23a101 test expr-28.109 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -579534 E-178 x -1caad28f23a100_11111111111111111111111110& E-573 convertToDouble -579534E-178 } 0x9c2caad28f23a101 test expr-28.110 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -8823691 E130 x -1e597c0b94b7ae_00000000000000000000000000000001& E454 convertToDouble -8823691E130 } 0xdc5e597c0b94b7ae test expr-28.111 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +9346704 E229 x 1d657059dc79aa_00000000000000000000000000001& E783 convertToDouble +9346704E229 } 0x70ed657059dc79aa test expr-28.112 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -1168338 E229 x -1d657059dc79aa_00000000000000000000000000001& E780 convertToDouble -1168338E229 } 0xf0bd657059dc79aa test expr-28.113 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -6063369 E-136 x -1ae6148e3902b3_000000000000000000000000000001& E-430 convertToDouble -6063369E-136 } 0xa51ae6148e3902b3 test expr-28.114 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +3865421 E-225 x 15d4fe53afec65_00000000000000000000000000001& E-726 convertToDouble +3865421E-225 } 0x1295d4fe53afec65 test expr-28.115 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -5783893 E-127 x -17e5902ce0e151_000000000000000000000000000000001& E-400 convertToDouble -5783893E-127 } 0xa6f7e5902ce0e151 test expr-28.116 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +2572231 E223 x 10f73be1dff9ac_111111111111111111111111111110& E762 convertToDouble +2572231E223 } 0x6f90f73be1dff9ad test expr-28.117 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -5144462 E223 x -10f73be1dff9ac_111111111111111111111111111110& E763 convertToDouble -5144462E223 } 0xefa0f73be1dff9ad test expr-28.118 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +1817623 E109 x 1d85f96f3fe659_11111111111111111111111111110& E382 convertToDouble +1817623E109 } 0x57dd85f96f3fe65a test expr-28.119 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +6431543 E-97 x 14f6493f34a0bc_11111111111111111111111111110& E-300 convertToDouble +6431543E-97 } 0x2d34f6493f34a0bd test expr-28.120 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -5444097 E-21 x -18849dd33c95ae_11111111111111111111111111110& E-48 convertToDouble -5444097E-21 } 0xbcf8849dd33c95af test expr-28.121 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8076999 E-121 x 1fd332f7e2e3b2_11111111111111111111111111110& E-380 convertToDouble +8076999E-121 } 0x283fd332f7e2e3b3 test expr-28.122 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -9997649 E-270 x -1425e9d29e558d_1111111111111111111111111110& E-874 convertToDouble -9997649E-270 } 0x895425e9d29e558e test expr-28.123 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +50609263 E157 x 1193aff1f1c8e3_000000000000000000000000000000001& E547 convertToDouble +50609263E157 } 0x622193aff1f1c8e3 test expr-28.124 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +70589528 E130 x 1e597c0b94b7ae_00000000000000000000000000000001& E457 convertToDouble +70589528E130 } 0x5c8e597c0b94b7ae test expr-28.125 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -88236910 E129 x -1e597c0b94b7ae_00000000000000000000000000000001& E454 convertToDouble -88236910E129 } 0xdc5e597c0b94b7ae test expr-28.126 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +87575437 E-310 x 1805c19e680456_0000000000000000000000000000000000001& E-1004 convertToDouble +87575437E-310 } 0x013805c19e680456 test expr-28.127 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -23135572 E-127 x -17e5902ce0e151_000000000000000000000000000000001& E-398 convertToDouble -23135572E-127 } 0xa717e5902ce0e151 test expr-28.128 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +85900881 E177 x 14375b2214e1b4_111111111111111111111111111111110& E614 convertToDouble +85900881E177 } 0x6654375b2214e1b5 test expr-28.129 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -84863171 E113 x -1a4a8e56474b8b_111111111111111111111111111111110& E401 convertToDouble -84863171E113 } 0xd90a4a8e56474b8c test expr-28.130 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +68761586 E232 x 1a662c350f37f2_1111111111111111111111111111110& E796 convertToDouble +68761586E232 } 0x71ba662c350f37f3 test expr-28.131 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -50464069 E286 x -1948dd06de561e_1111111111111111111111111111110& E975 convertToDouble -50464069E286 } 0xfce948dd06de561f test expr-28.132 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +27869147 E-248 x 1dbbac6f83a820_111111111111111111111111111111111110& E-800 convertToDouble +27869147E-248 } 0x0dfdbbac6f83a821 test expr-28.133 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -55738294 E-248 x -1dbbac6f83a820_111111111111111111111111111111111110& E-799 convertToDouble -55738294E-248 } 0x8e0dbbac6f83a821 test expr-28.134 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +70176353 E-53 x 100683a21de854_1111111111111111111111111111111110& E-150 convertToDouble +70176353E-53 } 0x36900683a21de855 test expr-28.135 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -80555086 E-32 x -1f29ca0ff893b0_111111111111111111111111111111110& E-81 convertToDouble -80555086E-32 } 0xbaef29ca0ff893b1 test expr-28.136 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -491080654 E121 x -1c569e968e0944_00000000000000000000000000000000000000001& E430 convertToDouble -491080654E121 } 0xdadc569e968e0944 test expr-28.137 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +526250918 E287 x 14997a298b2f2e_0000000000000000000000000000000000001& E982 convertToDouble +526250918E287 } 0x7d54997a298b2f2e test expr-28.138 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -245540327 E121 x -1c569e968e0944_00000000000000000000000000000000000000001& E429 convertToDouble -245540327E121 } 0xdacc569e968e0944 test expr-28.139 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -175150874 E-310 x -1805c19e680456_0000000000000000000000000000000000001& E-1003 convertToDouble -175150874E-310 } 0x814805c19e680456 test expr-28.140 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +350301748 E-310 x 1805c19e680456_0000000000000000000000000000000000001& E-1002 convertToDouble +350301748E-310 } 0x015805c19e680456 test expr-28.141 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -437877185 E-311 x -1805c19e680456_0000000000000000000000000000000000001& E-1005 convertToDouble -437877185E-311 } 0x812805c19e680456 test expr-28.142 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +458117166 E52 x 16ce94febdc7a4_1111111111111111111111111111111111110& E201 convertToDouble +458117166E52 } 0x4c86ce94febdc7a5 test expr-28.143 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -916234332 E52 x -16ce94febdc7a4_1111111111111111111111111111111111110& E202 convertToDouble -916234332E52 } 0xcc96ce94febdc7a5 test expr-28.144 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +229058583 E52 x 16ce94febdc7a4_1111111111111111111111111111111111110& E200 convertToDouble +229058583E52 } 0x4c76ce94febdc7a5 test expr-28.145 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -525789935 E98 x -16ecdc2a58fc64_11111111111111111111111111111111110& E354 convertToDouble -525789935E98 } 0xd616ecdc2a58fc65 test expr-28.146 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +282926897 E-227 x 1ff5a70d3d2fee_1111111111111111111111111111111111110& E-727 convertToDouble +282926897E-227 } 0x128ff5a70d3d2fef test expr-28.147 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -565853794 E-227 x -1ff5a70d3d2fee_1111111111111111111111111111111111110& E-726 convertToDouble -565853794E-227 } 0x929ff5a70d3d2fef test expr-28.148 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +667284113 E-240 x 109355f8050c01_111111111111111111111111111111111110& E-768 convertToDouble +667284113E-240 } 0x0ff09355f8050c02 test expr-28.149 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -971212611 E-126 x -1397d3c9745d2e_111111111111111111111111111111111111110& E-389 convertToDouble -971212611E-126 } 0xa7a397d3c9745d2f test expr-28.150 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +9981396317 E-182 x 18afe10a2a66aa_0000000000000000000000000000000000000001& E-572 convertToDouble +9981396317E-182 } 0x1c38afe10a2a66aa test expr-28.151 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -5035231965 E-156 x -101891fc4717fd_00000000000000000000000000000000000001& E-486 convertToDouble -5035231965E-156 } 0xa1901891fc4717fd test expr-28.152 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8336960483 E-153 x 1a06a1024b95e1_000000000000000000000000000000000000001& E-476 convertToDouble +8336960483E-153 } 0x223a06a1024b95e1 test expr-28.153 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -8056371144 E-155 x -101891fc4717fd_00000000000000000000000000000000000001& E-482 convertToDouble -8056371144E-155 } 0xa1d01891fc4717fd test expr-28.154 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +6418488827 E79 x 1021f14ed7b3f9_11111111111111111111111111111111111111110& E295 convertToDouble +6418488827E79 } 0x526021f14ed7b3fa test expr-28.155 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3981006983 E252 x -102ebaf189d5f1_1111111111111111111111111111111111111110& E869 convertToDouble -3981006983E252 } 0xf6402ebaf189d5f2 test expr-28.156 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7962013966 E252 x 102ebaf189d5f1_1111111111111111111111111111111111111110& E870 convertToDouble +7962013966E252 } 0x76502ebaf189d5f2 test expr-28.157 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -4713898551 E261 x -11d8813536e0df_11111111111111111111111111111111111110& E899 convertToDouble -4713898551E261 } 0xf821d8813536e0e0 test expr-28.158 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8715380633 E-58 x 14614c3219891e_11111111111111111111111111111111111111110& E-160 convertToDouble +8715380633E-58 } 0x35f4614c3219891f test expr-28.159 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -9078555839 E-109 x -1fc575867314ed_111111111111111111111111111111111111111111110& E-330 convertToDouble -9078555839E-109 } 0xab5fc575867314ee test expr-28.160 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +9712126110 E-127 x 1397d3c9745d2e_111111111111111111111111111111111111110& E-389 convertToDouble +9712126110E-127 } 0x27a397d3c9745d2f test expr-28.161 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +42333842451 E201 x 10189a26df575f_000000000000000000000000000000000000000000001& E703 convertToDouble +42333842451E201 } 0x6be0189a26df575f test expr-28.162 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -84667684902 E201 x -10189a26df575f_000000000000000000000000000000000000000000001& E704 convertToDouble -84667684902E201 } 0xebf0189a26df575f test expr-28.163 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +23792120709 E-315 x 10b517dc5d3212_00000000000000000000000000000000000000001& E-1012 convertToDouble +23792120709E-315 } 0x00b0b517dc5d3212 test expr-28.164 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -78564021519 E-227 x -1155515fd37265_00000000000000000000000000000000000000000001& E-718 convertToDouble -78564021519E-227 } 0x931155515fd37265 test expr-28.165 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +71812054883 E-188 x 1747b46d78c6fe_00000000000000000000000000000000000000001& E-589 convertToDouble +71812054883E-188 } 0x1b2747b46d78c6fe test expr-28.166 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -30311163631 E-116 x -163ef6f560afe7_00000000000000000000000000000000000000001& E-351 convertToDouble -30311163631E-116 } 0xaa063ef6f560afe7 test expr-28.167 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +71803914657 E292 x 10c0c44cdc2c05_11111111111111111111111111111111111111111110& E1006 convertToDouble +71803914657E292 } 0x7ed0c0c44cdc2c06 test expr-28.168 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +36314223356 E-109 x 1fc575867314ed_111111111111111111111111111111111111111111110& E-328 convertToDouble +36314223356E-109 } 0x2b7fc575867314ee test expr-28.169 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +18157111678 E-109 x 1fc575867314ed_111111111111111111111111111111111111111111110& E-329 convertToDouble +18157111678E-109 } 0x2b6fc575867314ee test expr-28.170 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -45392779195 E-110 x -1fc575867314ed_111111111111111111111111111111111111111111110& E-331 convertToDouble -45392779195E-110 } 0xab4fc575867314ee test expr-28.171 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +778380362293 E218 x 19ab8261990292_0000000000000000000000000000000000000000000000000001& E763 convertToDouble +778380362293E218 } 0x6fa9ab8261990292 test expr-28.172 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -685763015669 E280 x -15fd7aa44d9477_000000000000000000000000000000000000000000000001& E969 convertToDouble -685763015669E280 } 0xfc85fd7aa44d9477 test expr-28.173 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +952918668151 E70 x 14177a9915fbf8_00000000000000000000000000000000000000000000001& E272 convertToDouble +952918668151E70 } 0x50f4177a9915fbf8 test expr-28.174 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -548357443505 E32 x -13abde2775e9b5_0000000000000000000000000000000000000000000001& E145 convertToDouble -548357443505E32 } 0xc903abde2775e9b5 test expr-28.175 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +384865004907 E-285 x 1aa65b58639e69_00000000000000000000000000000000000000000000001& E-909 convertToDouble +384865004907E-285 } 0x072aa65b58639e69 test expr-28.176 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -769730009814 E-285 x -1aa65b58639e69_00000000000000000000000000000000000000000000001& E-908 convertToDouble -769730009814E-285 } 0x873aa65b58639e69 test expr-28.177 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +697015418417 E-93 x 152847dad80453_0000000000000000000000000000000000000000000001& E-270 convertToDouble +697015418417E-93 } 0x2f152847dad80453 test expr-28.178 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -915654049301 E-28 x -1a645598d05989_0000000000000000000000000000000000000000000001& E-54 convertToDouble -915654049301E-28 } 0xbc9a645598d05989 test expr-28.179 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +178548656339 E169 x 1b89d67c5b6d24_111111111111111111111111111111111111111111110& E598 convertToDouble +178548656339E169 } 0x655b89d67c5b6d25 test expr-28.180 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -742522891517 E259 x -1c1c352fc3c308_11111111111111111111111111111111111111111111110& E899 convertToDouble -742522891517E259 } 0xf82c1c352fc3c309 test expr-28.181 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +742522891517 E258 x 167cf7596968d3_11111111111111111111111111111111111111111111110& E896 convertToDouble +742522891517E258 } 0x77f67cf7596968d4 test expr-28.182 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -357097312678 E169 x -1b89d67c5b6d24_111111111111111111111111111111111111111111110& E599 convertToDouble -357097312678E169 } 0xe56b89d67c5b6d25 test expr-28.183 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3113521449172 E218 x -19ab8261990292_0000000000000000000000000000000000000000000000000001& E765 convertToDouble -3113521449172E218 } 0xefc9ab8261990292 test expr-28.184 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +3891901811465 E217 x 19ab8261990292_0000000000000000000000000000000000000000000000000001& E762 convertToDouble +3891901811465E217 } 0x6f99ab8261990292 test expr-28.185 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -1556760724586 E218 x -19ab8261990292_0000000000000000000000000000000000000000000000000001& E764 convertToDouble -1556760724586E218 } 0xefb9ab8261990292 test expr-28.186 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +9997878507563 E-195 x 153db2fea1ea31_0000000000000000000000000000000000000000000000001& E-605 convertToDouble +9997878507563E-195 } 0x1a253db2fea1ea31 test expr-28.187 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -7247563029154 E-319 x -10493f056e9ef3_0000000000000000000000000000000000000000000000001& E-1017 convertToDouble -7247563029154E-319 } 0x8060493f056e9ef3 test expr-28.188 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +3623781514577 E-319 x 10493f056e9ef3_0000000000000000000000000000000000000000000000001& E-1018 convertToDouble +3623781514577E-319 } 0x0050493f056e9ef3 test expr-28.189 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3092446298323 E-200 x -113918353bbc47_0000000000000000000000000000000000000000000000001& E-623 convertToDouble -3092446298323E-200 } 0x99013918353bbc47 test expr-28.190 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +6363857920591 E145 x 128a61cf9483b6_1111111111111111111111111111111111111111111111111110& E524 convertToDouble +6363857920591E145 } 0x60b28a61cf9483b7 test expr-28.191 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -8233559360849 E94 x -11f324d11d4861_1111111111111111111111111111111111111111111111110& E355 convertToDouble -8233559360849E94 } 0xd621f324d11d4862 test expr-28.192 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +2689845954547 E49 x 10bd2bfd34f98a_1111111111111111111111111111111111111111111111110& E204 convertToDouble +2689845954547E49 } 0x4cb0bd2bfd34f98b test expr-28.193 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -5379691909094 E49 x -10bd2bfd34f98a_1111111111111111111111111111111111111111111111110& E205 convertToDouble -5379691909094E49 } 0xccc0bd2bfd34f98b test expr-28.194 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +5560322501926 E-301 x 15acc2053064c1_11111111111111111111111111111111111111111111111110& E-958 convertToDouble +5560322501926E-301 } 0x0415acc2053064c2 test expr-28.195 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -7812878489261 E-179 x -126dae7bbeda74_11111111111111111111111111111111111111111111111111110& E-552 convertToDouble -7812878489261E-179 } 0x9d726dae7bbeda75 test expr-28.196 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8439398533053 E-256 x 170cc285f2d209_1111111111111111111111111111111111111111111111110& E-808 convertToDouble +8439398533053E-256 } 0x0d770cc285f2d20a test expr-28.197 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -2780161250963 E-301 x -15acc2053064c1_11111111111111111111111111111111111111111111111110& E-959 convertToDouble -2780161250963E-301 } 0x8405acc2053064c2 test expr-28.198 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -87605699161665 E155 x -12920f96e7f9ef_00000000000000000000000000000000000000000000000000001& E561 convertToDouble -87605699161665E155 } 0xe302920f96e7f9ef test expr-28.199 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -17521139832333 E156 x -12920f96e7f9ef_00000000000000000000000000000000000000000000000000001& E562 convertToDouble -17521139832333E156 } 0xe312920f96e7f9ef test expr-28.200 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -88218101363513 E-170 x -18395688592faf_0000000000000000000000000000000000000000000000000001& E-519 convertToDouble -88218101363513E-170 } 0x9f88395688592faf test expr-28.201 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +38639244311627 E-115 x 114ef3e205c817_0000000000000000000000000000000000000000000000000001& E-337 convertToDouble +38639244311627E-115 } 0x2ae14ef3e205c817 test expr-28.202 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +35593959807306 E261 x 1072f3819c1320_11111111111111111111111111111111111111111111111111110& E912 convertToDouble +35593959807306E261 } 0x78f072f3819c1321 test expr-28.203 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -53390939710959 E260 x -13bd243521b08d_11111111111111111111111111111111111111111111111111110& E909 convertToDouble -53390939710959E260 } 0xf8c3bd243521b08e test expr-28.204 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +71187919614612 E261 x 1072f3819c1320_11111111111111111111111111111111111111111111111111110& E913 convertToDouble +71187919614612E261 } 0x790072f3819c1321 test expr-28.205 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -88984899518265 E260 x -1072f3819c1320_11111111111111111111111111111111111111111111111111110& E910 convertToDouble -88984899518265E260 } 0xf8d072f3819c1321 test expr-28.206 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +77003665618895 E-73 x 18bf7e7fa6f029_111111111111111111111111111111111111111111111111111111110& E-197 convertToDouble +77003665618895E-73 } 0x33a8bf7e7fa6f02a test expr-28.207 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -15400733123779 E-72 x -18bf7e7fa6f029_111111111111111111111111111111111111111111111111111111110& E-196 convertToDouble -15400733123779E-72 } 0xb3b8bf7e7fa6f02a test expr-28.208 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +61602932495116 E-72 x 18bf7e7fa6f029_111111111111111111111111111111111111111111111111111111110& E-194 convertToDouble +61602932495116E-72 } 0x33d8bf7e7fa6f02a test expr-28.209 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -30801466247558 E-72 x -18bf7e7fa6f029_111111111111111111111111111111111111111111111111111111110& E-195 convertToDouble -30801466247558E-72 } 0xb3c8bf7e7fa6f02a test expr-28.210 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +834735494917063 E-300 x 1fc6c26f899dd1_0000000000000000000000000000000000000000000000000000000001& E-948 convertToDouble +834735494917063E-300 } 0x04bfc6c26f899dd1 test expr-28.211 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -589795149206434 E-151 x -15f2df5e675a0f_0000000000000000000000000000000000000000000000000000000001& E-453 convertToDouble -589795149206434E-151 } 0xa3a5f2df5e675a0f test expr-28.212 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +475603213226859 E-42 x 12d73088f4050a_000000000000000000000000000000000000000000000000000000001& E-91 convertToDouble +475603213226859E-42 } 0x3a42d73088f4050a test expr-28.213 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -294897574603217 E-151 x -15f2df5e675a0f_0000000000000000000000000000000000000000000000000000000001& E-454 convertToDouble -294897574603217E-151 } 0xa395f2df5e675a0f test expr-28.214 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +850813008001913 E93 x 172f7a1831ad70_11111111111111111111111111111111111111111111111111111110& E358 convertToDouble +850813008001913E93 } 0x56572f7a1831ad71 test expr-28.215 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -203449172043339 E185 x -1102b47e4af987_11111111111111111111111111111111111111111111111111111110& E662 convertToDouble -203449172043339E185 } 0xe95102b47e4af988 test expr-28.216 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +406898344086678 E185 x 1102b47e4af987_11111111111111111111111111111111111111111111111111111110& E663 convertToDouble +406898344086678E185 } 0x696102b47e4af988 test expr-28.217 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -813796688173356 E185 x -1102b47e4af987_11111111111111111111111111111111111111111111111111111110& E664 convertToDouble -813796688173356E185 } 0xe97102b47e4af988 test expr-28.218 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +6045338514609393 E244 x 1f746182e6cd5d_00000000000000000000000000000000000000000000000000000000001& E862 convertToDouble +6045338514609393E244 } 0x75df746182e6cd5d test expr-28.219 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -5145963778954906 E142 x -1dfc11fbf46087_00000000000000000000000000000000000000000000000000000000001& E523 convertToDouble -5145963778954906E142 } 0xe0adfc11fbf46087 test expr-28.220 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +2572981889477453 E142 x 1dfc11fbf46087_00000000000000000000000000000000000000000000000000000000001& E522 convertToDouble +2572981889477453E142 } 0x609dfc11fbf46087 test expr-28.221 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -6965949469487146 E74 x -15e2c10ad970b0_0000000000000000000000000000000000000000000000000000000001& E298 convertToDouble -6965949469487146E74 } 0xd295e2c10ad970b0 test expr-28.222 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +6182410494241627 E-119 x 11b96458445d07_0000000000000000000000000000000000000000000000000000000000001& E-343 convertToDouble +6182410494241627E-119 } 0x2a81b96458445d07 test expr-28.223 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -8510309498186985 E-277 x -1acc46749dccfe_000000000000000000000000000000000000000000000000000000000001& E-868 convertToDouble -8510309498186985E-277 } 0x89bacc46749dccfe test expr-28.224 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +6647704637273331 E-212 x 13e07d2c0cb1e9_0000000000000000000000000000000000000000000000000000000000001& E-652 convertToDouble +6647704637273331E-212 } 0x1733e07d2c0cb1e9 test expr-28.225 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -2215901545757777 E-212 x -1a80a6e566428c_000000000000000000000000000000000000000000000000000000000001& E-654 convertToDouble -2215901545757777E-212 } 0x971a80a6e566428c test expr-28.226 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +3771476185376383 E276 x 183010aba78a53_111111111111111111111111111111111111111111111111111111111110& E968 convertToDouble +3771476185376383E276 } 0x7c783010aba78a54 test expr-28.227 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3729901848043846 E212 x -1f7d6721f7f143_111111111111111111111111111111111111111111111111111111111110& E755 convertToDouble -3729901848043846E212 } 0xef2f7d6721f7f144 test expr-28.228 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +3771476185376383 E277 x 1e3c14d6916ce8_111111111111111111111111111111111111111111111111111111111110& E971 convertToDouble +3771476185376383E277 } 0x7cae3c14d6916ce9 test expr-28.229 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -9977830465649166 E119 x -15f6de9d5d6b5a_111111111111111111111111111111111111111111111111111111111110& E448 convertToDouble -9977830465649166E119 } 0xdbf5f6de9d5d6b5b test expr-28.230 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8439928496349319 E-142 x 12483a0f125699_111111111111111111111111111111111111111111111111111111111110& E-419 convertToDouble +8439928496349319E-142 } 0x25c2483a0f12569a test expr-28.231 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -8204230082070882 E-59 x -1d460f4fca1d36_1111111111111111111111111111111111111111111111111111111110& E-144 convertToDouble -8204230082070882E-59 } 0xb6fd460f4fca1d37 test expr-28.232 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8853686434843997 E-244 x 157a340eb5d4f0_11111111111111111111111111111111111111111111111111111111110& E-758 convertToDouble +8853686434843997E-244 } 0x10957a340eb5d4f1 test expr-28.233 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -5553274272288559 E-104 x -1c47d20a19d1ed_1111111111111111111111111111111111111111111111111111111110& E-294 convertToDouble -5553274272288559E-104 } 0xad9c47d20a19d1ee test expr-28.234 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +36149023611096162 E144 x 1491daad0ba280_0000000000000000000000000000000000000000000000000000000000000001& E533 convertToDouble +36149023611096162E144 } 0x614491daad0ba280 test expr-28.235 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -36149023611096162 E147 x -14166f8cfd5cb1_0000000000000000000000000000000000000000000000000000000000000001& E543 convertToDouble -36149023611096162E147 } 0xe1e4166f8cfd5cb1 test expr-28.236 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +18074511805548081 E146 x 1011f2d73116f4_0000000000000000000000000000000000000000000000000000000000000001& E539 convertToDouble +18074511805548081E146 } 0x61a011f2d73116f4 test expr-28.237 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -18074511805548081 E147 x -14166f8cfd5cb1_0000000000000000000000000000000000000000000000000000000000000001& E542 convertToDouble -18074511805548081E147 } 0xe1d4166f8cfd5cb1 test expr-28.238 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +97338774138954421 E-290 x 10d9b828199006_0000000000000000000000000000000000000000000000000000000000000001& E-907 convertToDouble +97338774138954421E-290 } 0x0740d9b828199006 test expr-28.239 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -88133809804950961 E-308 x -119710dc581911_000000000000000000000000000000000000000000000000000000000000001& E-967 convertToDouble -88133809804950961E-308 } 0x83819710dc581911 test expr-28.240 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +94080055902682397 E-243 x 11d467e94b856e_0000000000000000000000000000000000000000000000000000000000000001& E-751 convertToDouble +94080055902682397E-243 } 0x1101d467e94b856e test expr-28.241 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -24691002732654881 E-115 x -159a2783ce70ab_000000000000000000000000000000000000000000000000000000000000001& E-328 convertToDouble -24691002732654881E-115 } 0xab759a2783ce70ab test expr-28.242 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +52306490527514614 E49 x 13de005bd620de_111111111111111111111111111111111111111111111111111111111111111110& E218 convertToDouble +52306490527514614E49 } 0x4d93de005bd620df test expr-28.243 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -26153245263757307 E49 x -13de005bd620de_111111111111111111111111111111111111111111111111111111111111111110& E217 convertToDouble -26153245263757307E49 } 0xcd83de005bd620df test expr-28.244 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +55188692254193604 E165 x 1a999ddec72ac9_11111111111111111111111111111111111111111111111111111111111110& E603 convertToDouble +55188692254193604E165 } 0x65aa999ddec72aca test expr-28.245 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -68985865317742005 E164 x -1a999ddec72ac9_11111111111111111111111111111111111111111111111111111111111110& E600 convertToDouble -68985865317742005E164 } 0xe57a999ddec72aca test expr-28.246 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +27176258005319167 E-261 x 17c0747bd76fa0_11111111111111111111111111111111111111111111111111111111111111110& E-813 convertToDouble +27176258005319167E-261 } 0x0d27c0747bd76fa1 test expr-28.247 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -73169230107256116 E-248 x -122cea327fa99c_1111111111111111111111111111111111111111111111111111111111110& E-768 convertToDouble -73169230107256116E-248 } 0x8ff22cea327fa99d test expr-28.248 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +91461537634070145 E-249 x 122cea327fa99c_1111111111111111111111111111111111111111111111111111111111110& E-771 convertToDouble +91461537634070145E-249 } 0x0fc22cea327fa99d test expr-28.249 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -54352516010638334 E-261 x -17c0747bd76fa0_11111111111111111111111111111111111111111111111111111111111111110& E-812 convertToDouble -54352516010638334E-261 } 0x8d37c0747bd76fa1 test expr-28.250 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +586144289638535878 E280 x 11eccbd6f62709_0000000000000000000000000000000000000000000000000000000000000000001& E989 convertToDouble +586144289638535878E280 } 0x7dc1eccbd6f62709 test expr-28.251 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -601117006785295431 E245 x -1e8b3525b3737e_000000000000000000000000000000000000000000000000000000000000000001& E872 convertToDouble -601117006785295431E245 } 0xf67e8b3525b3737e test expr-28.252 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +293072144819267939 E280 x 11eccbd6f62709_0000000000000000000000000000000000000000000000000000000000000000001& E988 convertToDouble +293072144819267939E280 } 0x7db1eccbd6f62709 test expr-28.253 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -953184713238516652 E272 x -138fd93f1f5342_00000000000000000000000000000000000000000000000000000000000000001& E963 convertToDouble -953184713238516652E272 } 0xfc238fd93f1f5342 test expr-28.254 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +902042358290366539 E-281 x 122dc01ca1cb8c_0000000000000000000000000000000000000000000000000000000000000000001& E-874 convertToDouble +902042358290366539E-281 } 0x09522dc01ca1cb8c test expr-28.255 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -557035730189854663 E-294 x -13bfac6bc4767b_00000000000000000000000000000000000000000000000000000000000000000001& E-918 convertToDouble -557035730189854663E-294 } 0x8693bfac6bc4767b test expr-28.256 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +902042358290366539 E-280 x 16b93023ca3e6f_0000000000000000000000000000000000000000000000000000000000000000001& E-871 convertToDouble +902042358290366539E-280 } 0x0986b93023ca3e6f test expr-28.257 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -354944100507554393 E-238 x -19a91cece6ad07_000000000000000000000000000000000000000000000000000000000000000001& E-733 convertToDouble -354944100507554393E-238 } 0x9229a91cece6ad07 test expr-28.258 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +272104041512242479 E199 x 1f92bacb3cb40b_11111111111111111111111111111111111111111111111111111111111111111111110& E718 convertToDouble +272104041512242479E199 } 0x6cdf92bacb3cb40c test expr-28.259 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -816312124536727437 E199 x -17ae0c186d8708_11111111111111111111111111111111111111111111111111111111111111111111110& E720 convertToDouble -816312124536727437E199 } 0xecf7ae0c186d8709 test expr-28.260 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +544208083024484958 E199 x 1f92bacb3cb40b_11111111111111111111111111111111111111111111111111111111111111111111110& E719 convertToDouble +544208083024484958E199 } 0x6cef92bacb3cb40c test expr-28.261 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -792644927852378159 E78 x -17bff336d8ff05_111111111111111111111111111111111111111111111111111111111111111111110& E318 convertToDouble -792644927852378159E78 } 0xd3d7bff336d8ff06 test expr-28.262 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -679406450132979175 E-263 x -17c0747bd76fa0_11111111111111111111111111111111111111111111111111111111111111110& E-815 convertToDouble -679406450132979175E-263 } 0x8d07c0747bd76fa1 test expr-28.263 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +543525160106383340 E-262 x 17c0747bd76fa0_11111111111111111111111111111111111111111111111111111111111111110& E-812 convertToDouble +543525160106383340E-262 } 0x0d37c0747bd76fa1 test expr-28.264 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7400253695682920196 E215 x 1dca94e3990085_00000000000000000000000000000000000000000000000000000000000000000000001& E776 convertToDouble +7400253695682920196E215 } 0x707dca94e3990085 test expr-28.265 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -1850063423920730049 E215 x -1dca94e3990085_00000000000000000000000000000000000000000000000000000000000000000000001& E774 convertToDouble -1850063423920730049E215 } 0xf05dca94e3990085 test expr-28.266 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +3700126847841460098 E215 x 1dca94e3990085_00000000000000000000000000000000000000000000000000000000000000000000001& E775 convertToDouble +3700126847841460098E215 } 0x706dca94e3990085 test expr-28.267 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -9250317119603650245 E214 x -1dca94e3990085_00000000000000000000000000000000000000000000000000000000000000000000001& E773 convertToDouble -9250317119603650245E214 } 0xf04dca94e3990085 test expr-28.268 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8396094300569779681 E-252 x 1ab223efcee35a_0000000000000000000000000000000000000000000000000000000000000000000000001& E-775 convertToDouble +8396094300569779681E-252 } 0x0f8ab223efcee35a test expr-28.269 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3507665085003296281 E-75 x -160499b881ea50_00000000000000000000000000000000000000000000000000000000000000000000001& E-188 convertToDouble -3507665085003296281E-75 } 0xb4360499b881ea50 test expr-28.270 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7015330170006592562 E-75 x 160499b881ea50_00000000000000000000000000000000000000000000000000000000000000000000001& E-187 convertToDouble +7015330170006592562E-75 } 0x34460499b881ea50 test expr-28.271 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -7015330170006592562 E-74 x -1b85c026a264e4_00000000000000000000000000000000000000000000000000000000000000000000001& E-184 convertToDouble -7015330170006592562E-74 } 0xb47b85c026a264e4 test expr-28.272 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7185620434951919351 E205 x 18d92d2bcc7a80_1111111111111111111111111111111111111111111111111111111111111111111111110& E743 convertToDouble +7185620434951919351E205 } 0x6e68d92d2bcc7a81 test expr-28.273 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -1360520207561212395 E198 x -1f92bacb3cb40b_11111111111111111111111111111111111111111111111111111111111111111111110& E717 convertToDouble -1360520207561212395E198 } 0xeccf92bacb3cb40c test expr-28.274 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +2178999185345151731 E-184 x 19b2c4d2a82335_1111111111111111111111111111111111111111111111111111111111111111111110& E-551 convertToDouble +2178999185345151731E-184 } 0x1d89b2c4d2a82336 test expr-28.275 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -8691089486201567102 E-218 x -1a9c42e5b6d89e_1111111111111111111111111111111111111111111111111111111111111111111110& E-662 convertToDouble -8691089486201567102E-218 } 0x969a9c42e5b6d89f test expr-28.276 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +4345544743100783551 E-218 x 1a9c42e5b6d89e_1111111111111111111111111111111111111111111111111111111111111111111110& E-663 convertToDouble +4345544743100783551E-218 } 0x168a9c42e5b6d89f test expr-28.277 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -4357998370690303462 E-184 x -19b2c4d2a82335_1111111111111111111111111111111111111111111111111111111111111111111110& E-550 convertToDouble -4357998370690303462E-184 } 0x9d99b2c4d2a82336 test expr-28.278 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +59825267349106892461 E177 x 199c476d7868df_000000000000000000000000000000000000000000000000000000000000000000000001& E653 convertToDouble +59825267349106892461E177 } 0x68c99c476d7868df test expr-28.279 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -62259110684423957791 E47 x -1d8f2cfc20d6e8_0000000000000000000000000000000000000000000000000000000000000000000000001& E221 convertToDouble -62259110684423957791E47 } 0xcdcd8f2cfc20d6e8 test expr-28.280 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +58380168477038565599 E265 x 1f686e9efbe48d_00000000000000000000000000000000000000000000000000000000000000000000000001& E945 convertToDouble +58380168477038565599E265 } 0x7b0f686e9efbe48d test expr-28.281 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -62259110684423957791 E48 x -12797c1d948651_0000000000000000000000000000000000000000000000000000000000000000000000001& E225 convertToDouble -62259110684423957791E48 } 0xce02797c1d948651 test expr-28.282 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -33584377202279118724 E-252 x -1ab223efcee35a_0000000000000000000000000000000000000000000000000000000000000000000000001& E-773 convertToDouble -33584377202279118724E-252 } 0x8faab223efcee35a test expr-28.283 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -57484963479615354808 E205 x -18d92d2bcc7a80_1111111111111111111111111111111111111111111111111111111111111111111111110& E746 convertToDouble -57484963479615354808E205 } 0xee98d92d2bcc7a81 test expr-28.284 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +71856204349519193510 E204 x 18d92d2bcc7a80_1111111111111111111111111111111111111111111111111111111111111111111111110& E743 convertToDouble +71856204349519193510E204 } 0x6e68d92d2bcc7a81 test expr-28.285 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -14371240869903838702 E205 x -18d92d2bcc7a80_1111111111111111111111111111111111111111111111111111111111111111111111110& E744 convertToDouble -14371240869903838702E205 } 0xee78d92d2bcc7a81 test expr-28.286 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +36992084760177624177 E-318 x 18c5f9551c2f99_111111111111111111111111111111111111111111111111111111111111111111111110& E-992 convertToDouble +36992084760177624177E-318 } 0x01f8c5f9551c2f9a test expr-28.287 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -73984169520355248354 E-318 x -18c5f9551c2f99_111111111111111111111111111111111111111111111111111111111111111111111110& E-991 convertToDouble -73984169520355248354E-318 } 0x8208c5f9551c2f9a test expr-28.288 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +99257763227713890244 E-115 x 15338a554b9ce0_11111111111111111111111111111111111111111111111111111111111111111111110& E-316 convertToDouble +99257763227713890244E-115 } 0x2c35338a554b9ce1 test expr-28.289 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -87336362425182547697 E-280 x -1130304e7d9c32_11111111111111111111111111111111111111111111111111111111111111111111110& E-864 convertToDouble -87336362425182547697E-280 } 0x89f130304e7d9c33 test expr-28.290 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7 E289 x 1cbb547777a284_10000000001& E962 convertToDouble +7E289 } 0x7c1cbb547777a285 test expr-28.291 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3 E153 x -1ca3d8e6d80cba_100000001& E509 convertToDouble -3E153 } 0xdfcca3d8e6d80cbb test expr-28.292 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +6 E153 x 1ca3d8e6d80cba_100000001& E510 convertToDouble +6E153 } 0x5fdca3d8e6d80cbb test expr-28.293 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -5 E243 x -176ec98994f488_10000001& E809 convertToDouble -5E243 } 0xf2876ec98994f489 test expr-28.294 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7 E-161 x 1f7e0db3799aa2_10000000001& E-533 convertToDouble +7E-161 } 0x1eaf7e0db3799aa3 test expr-28.295 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -7 E-172 x -15a4337446ef2a_1000000001& E-569 convertToDouble -7E-172 } 0x9c65a4337446ef2b test expr-28.296 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8 E-63 x 1a53fc9631d10c_10000001& E-207 convertToDouble +8E-63 } 0x330a53fc9631d10d test expr-28.297 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -7 E-113 x -158c47e6eea282_10000001& E-373 convertToDouble -7E-113 } 0xa8a58c47e6eea283 test expr-28.298 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8 E126 x 17a2ecc414a03f_0111111111110& E421 convertToDouble +8E126 } 0x5a47a2ecc414a03f test expr-28.299 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -4 E126 x -17a2ecc414a03f_0111111111110& E420 convertToDouble -4E126 } 0xda37a2ecc414a03f test expr-28.300 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +5 E125 x 17a2ecc414a03f_0111111111110& E417 convertToDouble +5E125 } 0x5a07a2ecc414a03f test expr-28.301 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -1 E126 x -17a2ecc414a03f_0111111111110& E418 convertToDouble -1E126 } 0xda17a2ecc414a03f test expr-28.302 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8 E-163 x 1708d0f84d3de7_011111110& E-539 convertToDouble +8E-163 } 0x1e4708d0f84d3de7 test expr-28.303 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -1 E-163 x -1708d0f84d3de7_011111110& E-542 convertToDouble -1E-163 } 0x9e1708d0f84d3de7 test expr-28.304 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +2 E-163 x 1708d0f84d3de7_011111110& E-541 convertToDouble +2E-163 } 0x1e2708d0f84d3de7 test expr-28.305 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -4 E-163 x -1708d0f84d3de7_011111110& E-540 convertToDouble -4E-163 } 0x9e3708d0f84d3de7 test expr-28.306 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +51 E195 x 15d51d249dca42_1000000000001& E653 convertToDouble +51E195 } 0x68c5d51d249dca43 test expr-28.307 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -37 E46 x -1033d7eca0adee_100000000000001& E158 convertToDouble -37E46 } 0xc9d033d7eca0adef test expr-28.308 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +74 E46 x 1033d7eca0adee_100000000000001& E159 convertToDouble +74E46 } 0x49e033d7eca0adef test expr-28.309 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -56 E289 x -1cbb547777a284_10000000001& E965 convertToDouble -56E289 } 0xfc4cbb547777a285 test expr-28.310 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +69 E-145 x 158a41b31c9a9a_100000000001& E-476 convertToDouble +69E-145 } 0x22358a41b31c9a9b test expr-28.311 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -70 E-162 x -1f7e0db3799aa2_10000000001& E-533 convertToDouble -70E-162 } 0x9eaf7e0db3799aa3 test expr-28.312 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +56 E-161 x 1f7e0db3799aa2_10000000001& E-530 convertToDouble +56E-161 } 0x1edf7e0db3799aa3 test expr-28.313 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -21 E-303 x -1ccd59caa6a750_10000000001& E-1003 convertToDouble -21E-303 } 0x814ccd59caa6a751 test expr-28.314 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +34 E-276 x 12d5a4350d30ff_011111111110& E-912 convertToDouble +34E-276 } 0x06f2d5a4350d30ff test expr-28.315 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -68 E-276 x -12d5a4350d30ff_011111111110& E-911 convertToDouble -68E-276 } 0x8702d5a4350d30ff test expr-28.316 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +85 E-277 x 12d5a4350d30ff_011111111110& E-914 convertToDouble +85E-277 } 0x06d2d5a4350d30ff test expr-28.317 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -87 E-274 x -12d36cf48e7abd_011111111111110& E-904 convertToDouble -87E-274 } 0x8772d36cf48e7abd test expr-28.318 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +829 E102 x 17221a79cdd1d8_1000000000000001& E348 convertToDouble +829E102 } 0x55b7221a79cdd1d9 test expr-28.319 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -623 E100 x -1640a62f3a83de_10000000000000000001& E341 convertToDouble -623E100 } 0xd54640a62f3a83df test expr-28.320 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +723 E-162 x 145457ee24abd2_1000000000000001& E-529 convertToDouble +723E-162 } 0x1ee45457ee24abd3 test expr-28.321 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -457 E-102 x -1ffc81bc29f02a_100000000000000001& E-331 convertToDouble -457E-102 } 0xab4ffc81bc29f02b test expr-28.322 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +914 E-102 x 1ffc81bc29f02a_100000000000000001& E-330 convertToDouble +914E-102 } 0x2b5ffc81bc29f02b test expr-28.323 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -323 E-135 x -1d589ae4d70218_10000000000001& E-441 convertToDouble -323E-135 } 0xa46d589ae4d70219 test expr-28.324 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +151 E176 x 1dcf7df8f573b7_0111111111111111110& E591 convertToDouble +151E176 } 0x64edcf7df8f573b7 test expr-28.325 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -302 E176 x -1dcf7df8f573b7_0111111111111111110& E592 convertToDouble -302E176 } 0xe4fdcf7df8f573b7 test expr-28.326 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +921 E90 x 1c420a45fd70ff_0111111111111110& E308 convertToDouble +921E90 } 0x533c420a45fd70ff test expr-28.327 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -604 E176 x -1dcf7df8f573b7_0111111111111111110& E593 convertToDouble -604E176 } 0xe50dcf7df8f573b7 test expr-28.328 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +823 E-206 x 14a48933c208ad_0111111111111110& E-675 convertToDouble +823E-206 } 0x15c4a48933c208ad test expr-28.329 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -463 E-114 x -11d0c83f6378a5_011111111111110& E-370 convertToDouble -463E-114 } 0xa8d1d0c83f6378a5 test expr-28.330 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +348 E-274 x 12d36cf48e7abd_011111111111110& E-902 convertToDouble +348E-274 } 0x0792d36cf48e7abd test expr-28.331 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +9968 E100 x 1640a62f3a83de_10000000000000000001& E345 convertToDouble +9968E100 } 0x558640a62f3a83df test expr-28.332 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -6230 E99 x -1640a62f3a83de_10000000000000000001& E341 convertToDouble -6230E99 } 0xd54640a62f3a83df test expr-28.333 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +1246 E100 x 1640a62f3a83de_10000000000000000001& E342 convertToDouble +1246E100 } 0x555640a62f3a83df test expr-28.334 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +6676 E-296 x 15519ac5142aaa_1000000000000000000001& E-971 convertToDouble +6676E-296 } 0x0345519ac5142aab test expr-28.335 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -8345 E-297 x -15519ac5142aaa_1000000000000000000001& E-974 convertToDouble -8345E-297 } 0x8315519ac5142aab test expr-28.336 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +1669 E-296 x 15519ac5142aaa_1000000000000000000001& E-973 convertToDouble +1669E-296 } 0x0325519ac5142aab test expr-28.337 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3338 E-296 x -15519ac5142aaa_1000000000000000000001& E-972 convertToDouble -3338E-296 } 0x8335519ac5142aab test expr-28.338 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +3257 E58 x 1444b34a6fb3eb_01111111111111111110& E204 convertToDouble +3257E58 } 0x4cb444b34a6fb3eb test expr-28.339 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -6514 E58 x -1444b34a6fb3eb_01111111111111111110& E205 convertToDouble -6514E58 } 0xccc444b34a6fb3eb test expr-28.340 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +2416 E176 x 1dcf7df8f573b7_0111111111111111110& E595 convertToDouble +2416E176 } 0x652dcf7df8f573b7 test expr-28.341 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8085 E-63 x 19fbf3c19b9a79_0111111111111111110& E-197 convertToDouble +8085E-63 } 0x33a9fbf3c19b9a79 test expr-28.342 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3234 E-62 x -19fbf3c19b9a79_0111111111111111110& E-195 convertToDouble -3234E-62 } 0xb3c9fbf3c19b9a79 test expr-28.343 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +1617 E-62 x 19fbf3c19b9a79_0111111111111111110& E-196 convertToDouble +1617E-62 } 0x33b9fbf3c19b9a79 test expr-28.344 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -6468 E-62 x -19fbf3c19b9a79_0111111111111111110& E-194 convertToDouble -6468E-62 } 0xb3d9fbf3c19b9a79 test expr-28.345 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +53418 E111 x 15b1051df943a8_1000000000000000000001& E384 convertToDouble +53418E111 } 0x57f5b1051df943a9 test expr-28.346 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -60513 E160 x -15043b64e56c72_1000000000000000000001& E547 convertToDouble -60513E160 } 0xe225043b64e56c73 test expr-28.347 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +26709 E111 x 15b1051df943a8_1000000000000000000001& E383 convertToDouble +26709E111 } 0x57e5b1051df943a9 test expr-28.348 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -99447 E166 x -10782189b336ae_1000000000000000000001& E568 convertToDouble -99447E166 } 0xe370782189b336af test expr-28.349 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +12549 E48 x 10c52fe6dc6a1b_011111111111111111111110& E173 convertToDouble +12549E48 } 0x4ac0c52fe6dc6a1b test expr-28.350 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -25098 E48 x -10c52fe6dc6a1b_011111111111111111111110& E174 convertToDouble -25098E48 } 0xcad0c52fe6dc6a1b test expr-28.351 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +50196 E48 x 10c52fe6dc6a1b_011111111111111111111110& E175 convertToDouble +50196E48 } 0x4ae0c52fe6dc6a1b test expr-28.352 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -62745 E47 x -10c52fe6dc6a1b_011111111111111111111110& E172 convertToDouble -62745E47 } 0xcab0c52fe6dc6a1b test expr-28.353 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +83771 E-73 x 1ce886fb5ffd6d_0111111111111111111110& E-227 convertToDouble +83771E-73 } 0x31cce886fb5ffd6d test expr-28.354 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -97451 E-167 x -1c0f220fb1c70d_01111111111111111111110& E-539 convertToDouble -97451E-167 } 0x9e4c0f220fb1c70d test expr-28.355 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +86637 E-203 x 10943edb4e81db_0111111111111111111110& E-658 convertToDouble +86637E-203 } 0x16d0943edb4e81db test expr-28.356 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -75569 E-254 x -15a462d91c6ab3_0111111111111111111111111110& E-828 convertToDouble -75569E-254 } 0x8c35a462d91c6ab3 test expr-28.357 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +473806 E83 x 17d15bf3186080_1000000000000000000000001& E294 convertToDouble +473806E83 } 0x5257d15bf3186081 test expr-28.358 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -947612 E83 x -17d15bf3186080_1000000000000000000000001& E295 convertToDouble -947612E83 } 0xd267d15bf3186081 test expr-28.359 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +292369 E76 x 18a85eb277e644_100000000000000000000000001& E270 convertToDouble +292369E76 } 0x50d8a85eb277e645 test expr-28.360 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -584738 E76 x -18a85eb277e644_100000000000000000000000001& E271 convertToDouble -584738E76 } 0xd0e8a85eb277e645 test expr-28.361 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +933587 E-140 x 1b248728b9c116_100000000000000000000000001& E-446 convertToDouble +933587E-140 } 0x241b248728b9c117 test expr-28.362 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -720919 E-14 x -1ef696965cbf04_10000000000000000000000001& E-28 convertToDouble -720919E-14 } 0xbe3ef696965cbf05 test expr-28.363 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +535001 E-149 x 10b38e07c745ae_1000000000000000000000001& E-476 convertToDouble +535001E-149 } 0x2230b38e07c745af test expr-28.364 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -890521 E-235 x -114828ee39c852_1000000000000000000000001& E-761 convertToDouble -890521E-235 } 0x90614828ee39c853 test expr-28.365 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +548057 E81 x 11a1d9135cca53_0111111111111111111111110& E288 convertToDouble +548057E81 } 0x51f1a1d9135cca53 test expr-28.366 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -706181 E88 x -1b156ac4c2d1e5_0111111111111111111111110& E311 convertToDouble -706181E88 } 0xd36b156ac4c2d1e5 test expr-28.367 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +820997 E106 x 1b4f8b64fa125d_0111111111111111111111110& E371 convertToDouble +820997E106 } 0x572b4f8b64fa125d test expr-28.368 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -320681 E63 x -17ca18a876c5ef_0111111111111111111111110& E227 convertToDouble -320681E63 } 0xce27ca18a876c5ef test expr-28.369 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +928609 E-261 x 1be2dd66200bef_011111111111111111111111111110& E-848 convertToDouble +928609E-261 } 0x0afbe2dd66200bef test expr-28.370 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -302276 E-254 x -15a462d91c6ab3_0111111111111111111111111110& E-826 convertToDouble -302276E-254 } 0x8c55a462d91c6ab3 test expr-28.371 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +151138 E-254 x 15a462d91c6ab3_0111111111111111111111111110& E-827 convertToDouble +151138E-254 } 0x0c45a462d91c6ab3 test expr-28.372 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +4691773 E45 x 19147b9330eaae_1000000000000000000000000001& E171 convertToDouble +4691773E45 } 0x4aa9147b9330eaaf test expr-28.373 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -9383546 E45 x -19147b9330eaae_1000000000000000000000000001& E172 convertToDouble -9383546E45 } 0xcab9147b9330eaaf test expr-28.374 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +3059949 E-243 x 13ecf22ea07862_10000000000000000000000000001& E-786 convertToDouble +3059949E-243 } 0x0ed3ecf22ea07863 test expr-28.375 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -6119898 E-243 x -13ecf22ea07862_10000000000000000000000000001& E-785 convertToDouble -6119898E-243 } 0x8ee3ecf22ea07863 test expr-28.376 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +5356626 E-213 x 1b84252abdf6ba_100000000000000000000000001& E-686 convertToDouble +5356626E-213 } 0x151b84252abdf6bb test expr-28.377 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -4877378 E-199 x -11cd5cd90cb200_100000000000000000000000001& E-639 convertToDouble -4877378E-199 } 0x9801cd5cd90cb201 test expr-28.378 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7716693 E223 x 1972d9d2cff683_01111111111111111111111111110& E763 convertToDouble +7716693E223 } 0x6fa972d9d2cff683 test expr-28.379 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -5452869 E109 x -16247b136fecc3_01111111111111111111111111110& E384 convertToDouble -5452869E109 } 0xd7f6247b136fecc3 test expr-28.380 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +4590831 E156 x 14689b4a5fa201_011111111111111111111111111110& E540 convertToDouble +4590831E156 } 0x61b4689b4a5fa201 test expr-28.381 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -9181662 E156 x -14689b4a5fa201_011111111111111111111111111110& E541 convertToDouble -9181662E156 } 0xe1c4689b4a5fa201 test expr-28.382 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3714436 E-261 x -1be2dd66200bef_011111111111111111111111111110& E-846 convertToDouble -3714436E-261 } 0x8b1be2dd66200bef test expr-28.383 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +4643045 E-262 x 1be2dd66200bef_011111111111111111111111111110& E-849 convertToDouble +4643045E-262 } 0x0aebe2dd66200bef test expr-28.384 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -7428872 E-261 x -1be2dd66200bef_011111111111111111111111111110& E-845 convertToDouble -7428872E-261 } 0x8b2be2dd66200bef test expr-28.385 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +52942146 E130 x 16c31d08af89c2_10000000000000000000000000000001& E457 convertToDouble +52942146E130 } 0x5c86c31d08af89c3 test expr-28.386 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -27966061 E145 x -155bcf72fd10f8_1000000000000000000000000000000001& E506 convertToDouble -27966061E145 } 0xdf955bcf72fd10f9 test expr-28.387 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +26471073 E130 x 16c31d08af89c2_10000000000000000000000000000001& E456 convertToDouble +26471073E130 } 0x5c76c31d08af89c3 test expr-28.388 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -55932122 E145 x -155bcf72fd10f8_1000000000000000000000000000000001& E507 convertToDouble -55932122E145 } 0xdfa55bcf72fd10f9 test expr-28.389 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +95412548 E-99 x 18e0bfb98864c8_100000000000000000000000000000001& E-303 convertToDouble +95412548E-99 } 0x2d08e0bfb98864c9 test expr-28.390 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -47706274 E-99 x -18e0bfb98864c8_100000000000000000000000000000001& E-304 convertToDouble -47706274E-99 } 0xacf8e0bfb98864c9 test expr-28.391 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +23853137 E-99 x 18e0bfb98864c8_100000000000000000000000000000001& E-305 convertToDouble +23853137E-99 } 0x2ce8e0bfb98864c9 test expr-28.392 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -78493654 E-301 x -140d76077b648e_10000000000000000000000000000001& E-974 convertToDouble -78493654E-301 } 0x83140d76077b648f test expr-28.393 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +65346417 E29 x 13aa1ad778f23b_0111111111111111111111111111110& E122 convertToDouble +65346417E29 } 0x4793aa1ad778f23b test expr-28.394 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -51083099 E167 x -14a75eb58df47b_0111111111111111111111111111110& E580 convertToDouble -51083099E167 } 0xe434a75eb58df47b test expr-28.395 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +89396333 E264 x 1526f061ca9053_0111111111111111111111111111111110& E903 convertToDouble +89396333E264 } 0x786526f061ca9053 test expr-28.396 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -84863171 E114 x -106e98f5ec8f37_0111111111111111111111111111111110& E405 convertToDouble -84863171E114 } 0xd9406e98f5ec8f37 test expr-28.397 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +59540836 E-251 x 10430c2d075c07_011111111111111111111111111111110& E-808 convertToDouble +59540836E-251 } 0x0d70430c2d075c07 test expr-28.398 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -74426045 E-252 x -10430c2d075c07_011111111111111111111111111111110& E-811 convertToDouble -74426045E-252 } 0x8d40430c2d075c07 test expr-28.399 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +14885209 E-251 x 10430c2d075c07_011111111111111111111111111111110& E-810 convertToDouble +14885209E-251 } 0x0d50430c2d075c07 test expr-28.400 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -29770418 E-251 x -10430c2d075c07_011111111111111111111111111111110& E-809 convertToDouble -29770418E-251 } 0x8d60430c2d075c07 test expr-28.401 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +982161308 E122 x 11b6231e18c5ca_100000000000000000000000000000000000000001& E435 convertToDouble +982161308E122 } 0x5b21b6231e18c5cb test expr-28.402 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -245540327 E122 x -11b6231e18c5ca_100000000000000000000000000000000000000001& E433 convertToDouble -245540327E122 } 0xdb01b6231e18c5cb test expr-28.403 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +491080654 E122 x 11b6231e18c5ca_100000000000000000000000000000000000000001& E434 convertToDouble +491080654E122 } 0x5b11b6231e18c5cb test expr-28.404 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +525452622 E-310 x 12045136ce0340_1000000000000000000000000000000000001& E-1001 convertToDouble +525452622E-310 } 0x0162045136ce0341 test expr-28.405 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -771837113 E-134 x -14e61f991c4ed0_100000000000000000000000000000000001& E-416 convertToDouble -771837113E-134 } 0xa5f4e61f991c4ed1 test expr-28.406 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +820858081 E-150 x 14050669985a86_10000000000000000000000000000000001& E-469 convertToDouble +820858081E-150 } 0x22a4050669985a87 test expr-28.407 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -262726311 E-310 x -12045136ce0340_1000000000000000000000000000000000001& E-1002 convertToDouble -262726311E-310 } 0x8152045136ce0341 test expr-28.408 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +923091487 E209 x 10bc60e6896717_011111111111111111111111111111111110& E724 convertToDouble +923091487E209 } 0x6d30bc60e6896717 test expr-28.409 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -653777767 E273 x -120223f2b3a881_0111111111111111111111111111111111111110& E936 convertToDouble -653777767E273 } 0xfa720223f2b3a881 test expr-28.410 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +842116236 E-53 x 1809c5732cdc7f_0111111111111111111111111111111110& E-147 convertToDouble +842116236E-53 } 0x36c809c5732cdc7f test expr-28.411 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -741111169 E-202 x -15a3e1d1b73099_01111111111111111111111111111111110& E-642 convertToDouble -741111169E-202 } 0x97d5a3e1d1b73099 test expr-28.412 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +839507247 E-284 x 129a1effc50859_0111111111111111111111111111111110& E-914 convertToDouble +839507247E-284 } 0x06d29a1effc50859 test expr-28.413 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -951487269 E-264 x -1c92befccb5f59_0111111111111111111111111111111110& E-848 convertToDouble -951487269E-264 } 0x8afc92befccb5f59 test expr-28.414 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -9821613080 E121 x -11b6231e18c5ca_100000000000000000000000000000000000000001& E435 convertToDouble -9821613080E121 } 0xdb21b6231e18c5cb test expr-28.415 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +6677856011 E-31 x 193a6d11077292_100000000000000000000000000000000000001& E-71 convertToDouble +6677856011E-31 } 0x3b893a6d11077293 test expr-28.416 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3573796826 E-266 x -112be2041a79fc_100000000000000000000000000000000000001& E-852 convertToDouble -3573796826E-266 } 0x8ab12be2041a79fd test expr-28.417 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7147593652 E-266 x 112be2041a79fc_100000000000000000000000000000000000001& E-851 convertToDouble +7147593652E-266 } 0x0ac12be2041a79fd test expr-28.418 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -9981396317 E-181 x -1edbd94cb50054_100000000000000000000000000000000000001& E-569 convertToDouble -9981396317E-181 } 0x9c6edbd94cb50055 test expr-28.419 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +3268888835 E272 x 120223f2b3a881_0111111111111111111111111111111111111110& E935 convertToDouble +3268888835E272 } 0x7a620223f2b3a881 test expr-28.420 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -2615111068 E273 x -120223f2b3a881_0111111111111111111111111111111111111110& E938 convertToDouble -2615111068E273 } 0xfa920223f2b3a881 test expr-28.421 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +1307555534 E273 x 120223f2b3a881_0111111111111111111111111111111111111110& E937 convertToDouble +1307555534E273 } 0x7a820223f2b3a881 test expr-28.422 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +2990671154 E-190 x 13db11ac608107_01111111111111111111111111111111111111110& E-600 convertToDouble +2990671154E-190 } 0x1a73db11ac608107 test expr-28.423 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -1495335577 E-190 x -13db11ac608107_01111111111111111111111111111111111111110& E-601 convertToDouble -1495335577E-190 } 0x9a63db11ac608107 test expr-28.424 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +5981342308 E-190 x 13db11ac608107_01111111111111111111111111111111111111110& E-599 convertToDouble +5981342308E-190 } 0x1a83db11ac608107 test expr-28.425 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -7476677885 E-191 x -13db11ac608107_01111111111111111111111111111111111111110& E-602 convertToDouble -7476677885E-191 } 0x9a53db11ac608107 test expr-28.426 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +82259684194 E-202 x 12c3e72d179606_1000000000000000000000000000000000000000001& E-635 convertToDouble +82259684194E-202 } 0x1842c3e72d179607 test expr-28.427 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -93227267727 E-49 x -1960fe08d5847e_100000000000000000000000000000000000000001& E-127 convertToDouble -93227267727E-49 } 0xb80960fe08d5847f test expr-28.428 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +41129842097 E-202 x 12c3e72d179606_1000000000000000000000000000000000000000001& E-636 convertToDouble +41129842097E-202 } 0x1832c3e72d179607 test expr-28.429 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -47584241418 E-314 x -14e25dd3747e96_10000000000000000000000000000000000000001& E-1008 convertToDouble -47584241418E-314 } 0x80f4e25dd3747e97 test expr-28.430 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -79360293406 E92 x -1c58a00bb31863_01111111111111111111111111111111111111110& E341 convertToDouble -79360293406E92 } 0xd54c58a00bb31863 test expr-28.431 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +57332259349 E225 x 120811f528378b_01111111111111111111111111111111111111110& E783 convertToDouble +57332259349E225 } 0x70e20811f528378b test expr-28.432 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -57202326162 E111 x -1626f1c480545b_01111111111111111111111111111111111111110& E404 convertToDouble -57202326162E111 } 0xd93626f1c480545b test expr-28.433 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +86860597053 E-206 x 103b77d2b969d9_0111111111111111111111111111111111111111110& E-648 convertToDouble +86860597053E-206 } 0x17703b77d2b969d9 test expr-28.434 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -53827010643 E-200 x -132fa69a69bd6d_0111111111111111111111111111111111111111110& E-629 convertToDouble -53827010643E-200 } 0x98a32fa69a69bd6d test expr-28.435 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +53587107423 E-61 x 100a19a3ffd981_011111111111111111111111111111111111111111110& E-167 convertToDouble +53587107423E-61 } 0x35800a19a3ffd981 test expr-28.436 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +635007636765 E200 x 1824e73a4f030e_100000000000000000000000000000000000000000001& E703 convertToDouble +635007636765E200 } 0x6be824e73a4f030f test expr-28.437 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +508006109412 E201 x 1824e73a4f030e_100000000000000000000000000000000000000000001& E706 convertToDouble +508006109412E201 } 0x6c1824e73a4f030f test expr-28.438 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -254003054706 E201 x -1824e73a4f030e_100000000000000000000000000000000000000000001& E705 convertToDouble -254003054706E201 } 0xec0824e73a4f030f test expr-28.439 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +561029718715 E-72 x 1cd96a6972a14a_100000000000000000000000000000000000000000001& E-201 convertToDouble +561029718715E-72 } 0x336cd96a6972a14b test expr-28.440 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -897647549944 E-71 x -1cd96a6972a14a_100000000000000000000000000000000000000000001& E-197 convertToDouble -897647549944E-71 } 0xb3acd96a6972a14b test expr-28.441 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +112205943743 E-71 x 1cd96a6972a14a_100000000000000000000000000000000000000000001& E-200 convertToDouble +112205943743E-71 } 0x337cd96a6972a14b test expr-28.442 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -873947086081 E-236 x -19e117541d04e6_1000000000000000000000000000000000000000000001& E-745 convertToDouble -873947086081E-236 } 0x9169e117541d04e7 test expr-28.443 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +809184709177 E116 x 1de27e59fb0679_011111111111111111111111111111111111111111110& E424 convertToDouble +809184709177E116 } 0x5a7de27e59fb0679 test expr-28.444 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -573112917422 E81 x -11958b36c5102b_01111111111111111111111111111111111111111111110& E308 convertToDouble -573112917422E81 } 0xd331958b36c5102b test expr-28.445 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +286556458711 E81 x 11958b36c5102b_01111111111111111111111111111111111111111111110& E307 convertToDouble +286556458711E81 } 0x5321958b36c5102b test expr-28.446 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +952805821491 E-259 x 1551767ef8a9a3_011111111111111111111111111111111111111111110& E-821 convertToDouble +952805821491E-259 } 0x0ca551767ef8a9a3 test expr-28.447 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -132189992873 E-44 x -1b746cf242410b_011111111111111111111111111111111111111111110& E-110 convertToDouble -132189992873E-44 } 0xb91b746cf242410b test expr-28.448 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -173696038493 E-144 x -1f8fefbb3249d3_011111111111111111111111111111111111111111110& E-442 convertToDouble -173696038493E-144 } 0xa45f8fefbb3249d3 test expr-28.449 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +1831132757599 E-107 x 138e6edd48f2a2_1000000000000000000000000000000000000000000000001& E-315 convertToDouble +1831132757599E-107 } 0x2c438e6edd48f2a3 test expr-28.450 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -9155663787995 E-108 x -138e6edd48f2a2_1000000000000000000000000000000000000000000000001& E-316 convertToDouble -9155663787995E-108 } 0xac338e6edd48f2a3 test expr-28.451 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7324531030396 E-107 x 138e6edd48f2a2_1000000000000000000000000000000000000000000000001& E-313 convertToDouble +7324531030396E-107 } 0x2c638e6edd48f2a3 test expr-28.452 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -9277338894969 E-200 x -19d5a44fd99a6a_1000000000000000000000000000000000000000000000001& E-622 convertToDouble -9277338894969E-200 } 0x9919d5a44fd99a6b test expr-28.453 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8188292423973 E287 x 1390273bf8f983_0111111111111111111111111111111111111111111111110& E996 convertToDouble +8188292423973E287 } 0x7e3390273bf8f983 test expr-28.454 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -5672557437938 E59 x -148c2bd60a1523_011111111111111111111111111111111111111111111110& E238 convertToDouble -5672557437938E59 } 0xced48c2bd60a1523 test expr-28.455 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +2836278718969 E59 x 148c2bd60a1523_011111111111111111111111111111111111111111111110& E237 convertToDouble +2836278718969E59 } 0x4ec48c2bd60a1523 test expr-28.456 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -9995153153494 E54 x -17ba37c4fbe993_01111111111111111111111111111111111111111111110& E222 convertToDouble -9995153153494E54 } 0xcdd7ba37c4fbe993 test expr-28.457 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +9224786422069 E-291 x 14ee5d56b32957_011111111111111111111111111111111111111111111111110& E-924 convertToDouble +9224786422069E-291 } 0x0634ee5d56b32957 test expr-28.458 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3142213164987 E-294 x -1d3409dfbca26f_011111111111111111111111111111111111111111111111110& E-936 convertToDouble -3142213164987E-294 } 0x857d3409dfbca26f test expr-28.459 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +6284426329974 E-294 x 1d3409dfbca26f_011111111111111111111111111111111111111111111111110& E-935 convertToDouble +6284426329974E-294 } 0x058d3409dfbca26f test expr-28.460 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -8340483752889 E-301 x -10419183e44b91_01111111111111111111111111111111111111111111111110& E-957 convertToDouble -8340483752889E-301 } 0x8420419183e44b91 test expr-28.461 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +67039371486466 E89 x 17f203339c9628_10000000000000000000000000000000000000000000000000001& E341 convertToDouble +67039371486466E89 } 0x5547f203339c9629 test expr-28.462 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -62150786615239 E197 x -12e79a035b9714_1000000000000000000000000000000000000000000000000001& E700 convertToDouble -62150786615239E197 } 0xebb2e79a035b9715 test expr-28.463 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +33519685743233 E89 x 17f203339c9628_10000000000000000000000000000000000000000000000000001& E340 convertToDouble +33519685743233E89 } 0x5537f203339c9629 test expr-28.464 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -52563419496999 E156 x -1bdb17625bf6e6_1000000000000000000000000000000000000000000000000001& E563 convertToDouble -52563419496999E156 } 0xe32bdb17625bf6e7 test expr-28.465 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +32599460466991 E-65 x 1f395d4c779d8e_1000000000000000000000000000000000000000000000000001& E-172 convertToDouble +32599460466991E-65 } 0x353f395d4c779d8f test expr-28.466 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -41010988798007 E-133 x -152e1c9e04ee06_100000000000000000000000000000000000000000000000001& E-397 convertToDouble -41010988798007E-133 } 0xa7252e1c9e04ee07 test expr-28.467 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +65198920933982 E-65 x 1f395d4c779d8e_1000000000000000000000000000000000000000000000000001& E-171 convertToDouble +65198920933982E-65 } 0x354f395d4c779d8f test expr-28.468 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -82021977596014 E-133 x -152e1c9e04ee06_100000000000000000000000000000000000000000000000001& E-396 convertToDouble -82021977596014E-133 } 0xa7352e1c9e04ee07 test expr-28.469 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +80527976643809 E61 x 1c7c5aea080a49_0111111111111111111111111111111111111111111111111110& E248 convertToDouble +80527976643809E61 } 0x4f7c7c5aea080a49 test expr-28.470 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -74712611505209 E158 x -1eeebe9ea010f3_011111111111111111111111111111111111111111111111110& E570 convertToDouble -74712611505209E158 } 0xe39eeebe9ea010f3 test expr-28.471 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +53390939710959 E261 x 18ac6d426a1cb1_0111111111111111111111111111111111111111111111111110& E912 convertToDouble +53390939710959E261 } 0x78f8ac6d426a1cb1 test expr-28.472 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -69277302659155 E225 x -1547166a3a2b0f_011111111111111111111111111111111111111111111111110& E793 convertToDouble -69277302659155E225 } 0xf18547166a3a2b0f test expr-28.473 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +46202199371337 E-72 x 128f9edfbd341f_0111111111111111111111111111111111111111111111111111111110& E-194 convertToDouble +46202199371337E-72 } 0x33d28f9edfbd341f test expr-28.474 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -23438635467783 E-179 x -1ba485b99e47af_0111111111111111111111111111111111111111111111111110& E-551 convertToDouble -23438635467783E-179 } 0x9d8ba485b99e47af test expr-28.475 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +41921560615349 E-67 x 19b2a5c4041e4b_0111111111111111111111111111111111111111111111111110& E-178 convertToDouble +41921560615349E-67 } 0x34d9b2a5c4041e4b test expr-28.476 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -92404398742674 E-72 x -128f9edfbd341f_0111111111111111111111111111111111111111111111111111111110& E-193 convertToDouble -92404398742674E-72 } 0xb3e28f9edfbd341f test expr-28.477 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +738545606647197 E124 x 13d8886a766a20_100000000000000000000000000000000000000000000000000001& E461 convertToDouble +738545606647197E124 } 0x5cc3d8886a766a21 test expr-28.478 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -972708181182949 E117 x -15ed1f039cebfe_1000000000000000000000000000000000000000000000000000001& E438 convertToDouble -972708181182949E117 } 0xdb55ed1f039cebff test expr-28.479 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -837992143580825 E87 x -17f203339c9628_10000000000000000000000000000000000000000000000000001& E338 convertToDouble -837992143580825E87 } 0xd517f203339c9629 test expr-28.480 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +609610927149051 E-255 x 104273b18918b0_100000000000000000000000000000000000000000000000000000001& E-798 convertToDouble +609610927149051E-255 } 0x0e104273b18918b1 test expr-28.481 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -475603213226859 E-41 x -178cfcab31064c_10000000000000000000000000000000000000000000000000000001& E-88 convertToDouble -475603213226859E-41 } 0xba778cfcab31064d test expr-28.482 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +563002800671023 E-177 x 1035e7b5183922_10000000000000000000000000000000000000000000000000000001& E-539 convertToDouble +563002800671023E-177 } 0x1e4035e7b5183923 test expr-28.483 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -951206426453718 E-41 x -178cfcab31064c_10000000000000000000000000000000000000000000000000000001& E-87 convertToDouble -951206426453718E-41 } 0xba878cfcab31064d test expr-28.484 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +805416432656519 E202 x 175d226331d039_01111111111111111111111111111111111111111111111111111110& E720 convertToDouble +805416432656519E202 } 0x6cf75d226331d039 test expr-28.485 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -530658674694337 E159 x -112a13daa46fe3_0111111111111111111111111111111111111111111111111111110& E577 convertToDouble -530658674694337E159 } 0xe4012a13daa46fe3 test expr-28.486 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +946574173863918 E208 x 1a2fbffdb7580b_011111111111111111111111111111111111111111111111111110& E740 convertToDouble +946574173863918E208 } 0x6e3a2fbffdb7580b test expr-28.487 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -318329953318553 E113 x -178358811cbc95_011111111111111111111111111111111111111111111111111110& E423 convertToDouble -318329953318553E113 } 0xda678358811cbc95 test expr-28.488 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -462021993713370 E-73 x -128f9edfbd341f_0111111111111111111111111111111111111111111111111111111110& E-194 convertToDouble -462021993713370E-73 } 0xb3d28f9edfbd341f test expr-28.489 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +369617594970696 E-72 x 128f9edfbd341f_0111111111111111111111111111111111111111111111111111111110& E-191 convertToDouble +369617594970696E-72 } 0x34028f9edfbd341f test expr-28.490 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +3666156212014994 E233 x 1a37935f3b71c8_100000000000000000000000000000000000000000000000000000001& E825 convertToDouble +3666156212014994E233 } 0x738a37935f3b71c9 test expr-28.491 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -1833078106007497 E233 x -1a37935f3b71c8_100000000000000000000000000000000000000000000000000000001& E824 convertToDouble -1833078106007497E233 } 0xf37a37935f3b71c9 test expr-28.492 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +8301790508624232 E174 x 1dcfee6690ffc6_100000000000000000000000000000000000000000000000000000001& E630 convertToDouble +8301790508624232E174 } 0x675dcfee6690ffc7 test expr-28.493 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -1037723813578029 E174 x -1dcfee6690ffc6_100000000000000000000000000000000000000000000000000000001& E627 convertToDouble -1037723813578029E174 } 0xe72dcfee6690ffc7 test expr-28.494 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7297662880581139 E-286 x 18ac8c79e1ff18_1000000000000000000000000000000000000000000000000000000000001& E-898 convertToDouble +7297662880581139E-286 } 0x07d8ac8c79e1ff19 test expr-28.495 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -5106185698912191 E-276 x -141934d77659be_1000000000000000000000000000000000000000000000000000000000001& E-865 convertToDouble -5106185698912191E-276 } 0x89e41934d77659bf test expr-28.496 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7487252720986826 E-165 x 18823a57adbef8_100000000000000000000000000000000000000000000000000000000000001& E-496 convertToDouble +7487252720986826E-165 } 0x20f8823a57adbef9 test expr-28.497 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3743626360493413 E-165 x -18823a57adbef8_100000000000000000000000000000000000000000000000000000000000001& E-497 convertToDouble -3743626360493413E-165 } 0xa0e8823a57adbef9 test expr-28.498 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +3773057430100257 E230 x 1ba10d818fdafd_0111111111111111111111111111111111111111111111111111111110& E815 convertToDouble +3773057430100257E230 } 0x72eba10d818fdafd test expr-28.499 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -7546114860200514 E230 x -1ba10d818fdafd_0111111111111111111111111111111111111111111111111111111110& E816 convertToDouble -7546114860200514E230 } 0xf2fba10d818fdafd test expr-28.500 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +4321222892463822 E58 x 18750ea732fdad_011111111111111111111111111111111111111111111111111111110& E244 convertToDouble +4321222892463822E58 } 0x4f38750ea732fdad test expr-28.501 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -7793560217139653 E51 x -1280461b856ec5_0111111111111111111111111111111111111111111111111111111110& E222 convertToDouble -7793560217139653E51 } 0xcdd280461b856ec5 test expr-28.502 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +26525993941010681 E112 x 187dcbf6ad5cf8_10000000000000000000000000000000000000000000000000000000000001& E426 convertToDouble +26525993941010681E112 } 0x5a987dcbf6ad5cf9 test expr-28.503 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -53051987882021362 E112 x -187dcbf6ad5cf8_10000000000000000000000000000000000000000000000000000000000001& E427 convertToDouble -53051987882021362E112 } 0xdaa87dcbf6ad5cf9 test expr-28.504 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +72844871414247907 E77 x 1bf00baf60b70c_100000000000000000000000000000000000000000000000000000000001& E311 convertToDouble +72844871414247907E77 } 0x536bf00baf60b70d test expr-28.505 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -88839359596763261 E105 x -1133b1a33a1108_100000000000000000000000000000000000000000000000000000000001& E405 convertToDouble -88839359596763261E105 } 0xd94133b1a33a1109 test expr-28.506 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +18718131802467065 E-166 x 18823a57adbef8_100000000000000000000000000000000000000000000000000000000000001& E-498 convertToDouble +18718131802467065E-166 } 0x20d8823a57adbef9 test expr-28.507 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -14974505441973652 E-165 x -18823a57adbef8_100000000000000000000000000000000000000000000000000000000000001& E-495 convertToDouble -14974505441973652E-165 } 0xa108823a57adbef9 test expr-28.508 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +73429396004640239 E106 x 11c5cb19ef3451_01111111111111111111111111111111111111111111111111111111111110& E408 convertToDouble +73429396004640239E106 } 0x5971c5cb19ef3451 test expr-28.509 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -58483921078398283 E57 x -108ce499519ce3_0111111111111111111111111111111111111111111111111111111111111110& E245 convertToDouble -58483921078398283E57 } 0xcf408ce499519ce3 test expr-28.510 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +41391519190645203 E165 x 13f33667156017_011111111111111111111111111111111111111111111111111111111111110& E603 convertToDouble +41391519190645203E165 } 0x65a3f33667156017 test expr-28.511 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -82783038381290406 E165 x -13f33667156017_011111111111111111111111111111111111111111111111111111111111110& E604 convertToDouble -82783038381290406E165 } 0xe5b3f33667156017 test expr-28.512 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +58767043776702677 E-163 x 12c92fee3a3867_0111111111111111111111111111111111111111111111111111111111110& E-486 convertToDouble +58767043776702677E-163 } 0x2192c92fee3a3867 test expr-28.513 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -90506231831231999 E-129 x -1bdc4114397ff3_01111111111111111111111111111111111111111111111111111111111110& E-373 convertToDouble -90506231831231999E-129 } 0xa8abdc4114397ff3 test expr-28.514 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +64409240769861689 E-159 x 192238f7987779_011111111111111111111111111111111111111111111111111111111111110& E-473 convertToDouble +64409240769861689E-159 } 0x22692238f7987779 test expr-28.515 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -77305427432277771 E-190 x -1e978b7780b613_0111111111111111111111111111111111111111111111111111111111110& E-576 convertToDouble -77305427432277771E-190 } 0x9bfe978b7780b613 test expr-28.516 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +476592356619258326 E273 x 1873cf8ee72812_10000000000000000000000000000000000000000000000000000000000000001& E965 convertToDouble +476592356619258326E273 } 0x7c4873cf8ee72813 test expr-28.517 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -953184713238516652 E273 x -1873cf8ee72812_10000000000000000000000000000000000000000000000000000000000000001& E966 convertToDouble -953184713238516652E273 } 0xfc5873cf8ee72813 test expr-28.518 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +899810892172646163 E283 x 1adf51fa055e02_100000000000000000000000000000000000000000000000000000000000000000001& E999 convertToDouble +899810892172646163E283 } 0x7e6adf51fa055e03 test expr-28.519 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -929167076892018333 E187 x -1da2c42fce2bc4_10000000000000000000000000000000000000000000000000000000000000000001& E680 convertToDouble -929167076892018333E187 } 0xea7da2c42fce2bc5 test expr-28.520 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +647761278967534239 E-312 x 1a7a2476ec0b3e_10000000000000000000000000000000000000000000000000000000000000001& E-978 convertToDouble +647761278967534239E-312 } 0x02da7a2476ec0b3f test expr-28.521 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -644290479820542942 E-180 x -128d1407dfa832_10000000000000000000000000000000000000000000000000000000000000001& E-539 convertToDouble -644290479820542942E-180 } 0x9e428d1407dfa833 test expr-28.522 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +926145344610700019 E-225 x 1307a67f1f69fe_10000000000000000000000000000000000000000000000000000000000000000001& E-688 convertToDouble +926145344610700019E-225 } 0x14f307a67f1f69ff test expr-28.523 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -958507931896511964 E-246 x -17406753df2f0c_10000000000000000000000000000000000000000000000000000000000000001& E-758 convertToDouble -958507931896511964E-246 } 0x9097406753df2f0d test expr-28.524 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +272104041512242479 E200 x 13bbb4bf05f087_011111111111111111111111111111111111111111111111111111111111111111111110& E722 convertToDouble +272104041512242479E200 } 0x6d13bbb4bf05f087 test expr-28.525 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -792644927852378159 E79 x -1daff0048f3ec7_011111111111111111111111111111111111111111111111111111111111111111110& E321 convertToDouble -792644927852378159E79 } 0xd40daff0048f3ec7 test expr-28.526 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +544208083024484958 E200 x 13bbb4bf05f087_011111111111111111111111111111111111111111111111111111111111111111111110& E723 convertToDouble +544208083024484958E200 } 0x6d23bbb4bf05f087 test expr-28.527 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -929963218616126365 E290 x -108dcc0c505461_01111111111111111111111111111111111111111111111111111111111111110& E1023 convertToDouble -929963218616126365E290 } 0xffe08dcc0c505461 test expr-28.528 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +305574339166810102 E-219 x 17f399fe02c4b9_011111111111111111111111111111111111111111111111111111111111111110& E-670 convertToDouble +305574339166810102E-219 } 0x1617f399fe02c4b9 test expr-28.529 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -152787169583405051 E-219 x -17f399fe02c4b9_011111111111111111111111111111111111111111111111111111111111111110& E-671 convertToDouble -152787169583405051E-219 } 0x9607f399fe02c4b9 test expr-28.530 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +611148678333620204 E-219 x 17f399fe02c4b9_011111111111111111111111111111111111111111111111111111111111111110& E-669 convertToDouble +611148678333620204E-219 } 0x1627f399fe02c4b9 test expr-28.531 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -763935847917025255 E-220 x -17f399fe02c4b9_011111111111111111111111111111111111111111111111111111111111111110& E-672 convertToDouble -763935847917025255E-220 } 0x95f7f399fe02c4b9 test expr-28.532 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +7439550220920798612 E158 x 177fe14f40159a_10000000000000000000000000000000000000000000000000000000000000000000001& E587 convertToDouble +7439550220920798612E158 } 0x64a77fe14f40159b test expr-28.533 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -3719775110460399306 E158 x -177fe14f40159a_10000000000000000000000000000000000000000000000000000000000000000000001& E586 convertToDouble -3719775110460399306E158 } 0xe4977fe14f40159b test expr-28.534 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +9299437776150998265 E157 x 177fe14f40159a_10000000000000000000000000000000000000000000000000000000000000000000001& E584 convertToDouble +9299437776150998265E157 } 0x64777fe14f40159b test expr-28.535 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -7120190517612959703 E120 x -13220dcd5899fc_1000000000000000000000000000000000000000000000000000000000000000000000001& E461 convertToDouble -7120190517612959703E120 } 0xdcc3220dcd5899fd test expr-28.536 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +3507665085003296281 E-73 x 11339818257f0e_100000000000000000000000000000000000000000000000000000000000000000000001& E-181 convertToDouble +3507665085003296281E-73 } 0x34a1339818257f0f test expr-28.537 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -7015330170006592562 E-73 x -11339818257f0e_100000000000000000000000000000000000000000000000000000000000000000000001& E-180 convertToDouble -7015330170006592562E-73 } 0xb4b1339818257f0f test expr-28.538 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -6684428762278255956 E-294 x -1d9f82a1a6b1b8_10000000000000000000000000000000000000000000000000000000000000000001& E-915 convertToDouble -6684428762278255956E-294 } 0x86cd9f82a1a6b1b9 test expr-28.539 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -1088416166048969916 E200 x -13bbb4bf05f087_011111111111111111111111111111111111111111111111111111111111111111111110& E724 convertToDouble -1088416166048969916E200 } 0xed33bbb4bf05f087 test expr-28.540 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -8707329328391759328 E200 x -13bbb4bf05f087_011111111111111111111111111111111111111111111111111111111111111111111110& E727 convertToDouble -8707329328391759328E200 } 0xed63bbb4bf05f087 test expr-28.541 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +4439021781608558002 E-65 x 1038168b71e2c9_01111111111111111111111111111111111111111111111111111111111111111110& E-154 convertToDouble +4439021781608558002E-65 } 0x365038168b71e2c9 test expr-28.542 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -8878043563217116004 E-65 x -1038168b71e2c9_01111111111111111111111111111111111111111111111111111111111111111110& E-153 convertToDouble -8878043563217116004E-65 } 0xb66038168b71e2c9 test expr-28.543 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +2219510890804279001 E-65 x 1038168b71e2c9_01111111111111111111111111111111111111111111111111111111111111111110& E-155 convertToDouble +2219510890804279001E-65 } 0x364038168b71e2c9 test expr-28.544 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +33051223951904955802 E55 x 1762068a24fd54_1000000000000000000000000000000000000000000000000000000000000000000000001& E247 convertToDouble +33051223951904955802E55 } 0x4f6762068a24fd55 test expr-28.545 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -56961524140903677624 E120 x -13220dcd5899fc_1000000000000000000000000000000000000000000000000000000000000000000000001& E464 convertToDouble -56961524140903677624E120 } 0xdcf3220dcd5899fd test expr-28.546 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +71201905176129597030 E119 x 13220dcd5899fc_1000000000000000000000000000000000000000000000000000000000000000000000001& E461 convertToDouble +71201905176129597030E119 } 0x5cc3220dcd5899fd test expr-28.547 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +14030660340013185124 E-73 x 11339818257f0e_100000000000000000000000000000000000000000000000000000000000000000000001& E-179 convertToDouble +14030660340013185124E-73 } 0x34c1339818257f0f test expr-28.548 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -17538325425016481405 E-74 x -11339818257f0e_100000000000000000000000000000000000000000000000000000000000000000000001& E-182 convertToDouble -17538325425016481405E-74 } 0xb491339818257f0f test expr-28.549 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +67536228609141569109 E-133 x 10a1b35cf2a635_01111111111111111111111111111111111111111111111111111111111111111111110& E-376 convertToDouble +67536228609141569109E-133 } 0x2870a1b35cf2a635 test expr-28.550 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -35620497849450218807 E-306 x -15b22082529425_0111111111111111111111111111111111111111111111111111111111111111111111110& E-952 convertToDouble -35620497849450218807E-306 } 0x8475b22082529425 test expr-28.551 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN +66550376797582521751 E-126 x 13897c0ede6c69_01111111111111111111111111111111111111111111111111111111111111111111110& E-353 convertToDouble +66550376797582521751E-126 } 0x29e3897c0ede6c69 test expr-28.552 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b d UN -71240995698900437614 E-306 x -15b22082529425_0111111111111111111111111111111111111111111111111111111111111111111111110& E-951 convertToDouble -71240995698900437614E-306 } 0x8485b22082529425 test expr-28.553 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +3 E24 x 13da329b633647_0001& E81 convertToDouble +3E24 } 0x4503da329b633647 test expr-28.554 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -6 E24 x -13da329b633647_0001& E82 convertToDouble -6E24 } 0xc513da329b633647 test expr-28.555 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +6 E26 x 1f04ef12cb04cf_0001& E88 convertToDouble +6E26 } 0x457f04ef12cb04cf test expr-28.556 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -7 E25 x -1cf389cd46047d_0000001& E85 convertToDouble -7E25 } 0xc54cf389cd46047d test expr-28.557 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +1 E-14 x 16849b86a12b9b_00000001& E-47 convertToDouble +1E-14 } 0x3d06849b86a12b9b test expr-28.558 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -2 E-14 x -16849b86a12b9b_00000001& E-46 convertToDouble -2E-14 } 0xbd16849b86a12b9b test expr-28.559 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4 E-14 x 16849b86a12b9b_00000001& E-45 convertToDouble +4E-14 } 0x3d26849b86a12b9b test expr-28.560 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8 E-14 x -16849b86a12b9b_00000001& E-44 convertToDouble -8E-14 } 0xbd36849b86a12b9b test expr-28.561 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +5 E26 x 19d971e4fe8401_1110& E88 convertToDouble +5E26 } 0x4579d971e4fe8402 test expr-28.562 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8 E27 x -19d971e4fe8401_1110& E92 convertToDouble -8E27 } 0xc5b9d971e4fe8402 test expr-28.563 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +1 E27 x 19d971e4fe8401_1110& E89 convertToDouble +1E27 } 0x4589d971e4fe8402 test expr-28.564 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -4 E27 x -19d971e4fe8401_1110& E91 convertToDouble -4E27 } 0xc5a9d971e4fe8402 test expr-28.565 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +9 E-13 x 1faa7ab552a551_111110& E-41 convertToDouble +9E-13 } 0x3d6faa7ab552a552 test expr-28.566 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -7 E-20 x -14a90ceafff9de_11110& E-64 convertToDouble -7E-20 } 0xbbf4a90ceafff9df test expr-28.567 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +56 E25 x 1cf389cd46047d_0000001& E88 convertToDouble +56E25 } 0x457cf389cd46047d test expr-28.568 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -70 E24 x -1cf389cd46047d_0000001& E85 convertToDouble -70E24 } 0xc54cf389cd46047d test expr-28.569 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +51 E26 x 107a9f01fbda8e_0000001& E92 convertToDouble +51E26 } 0x45b07a9f01fbda8e test expr-28.570 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +71 E-17 x 19949819f693d7_00000000001& E-51 convertToDouble +71E-17 } 0x3cc9949819f693d7 test expr-28.571 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -31 E-5 x -1450efdc9c4da9_00000000001& E-12 convertToDouble -31E-5 } 0xbf3450efdc9c4da9 test expr-28.572 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +62 E-5 x 1450efdc9c4da9_00000000001& E-11 convertToDouble +62E-5 } 0x3f4450efdc9c4da9 test expr-28.573 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -94 E-8 x -1f8a89dc374df5_0000000001& E-21 convertToDouble -94E-8 } 0xbeaf8a89dc374df5 test expr-28.574 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +67 E27 x 1b0fa33bba7231_11111110& E95 convertToDouble +67E27 } 0x45eb0fa33bba7232 test expr-28.575 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -81 E24 x -10c01ab31bb5cb_1111110& E86 convertToDouble -81E24 } 0xc550c01ab31bb5cc test expr-28.576 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +54 E23 x 11ddfa58a6173f_111110& E82 convertToDouble +54E23 } 0x4511ddfa58a61740 test expr-28.577 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -54 E25 x -1bead72a838453_111110& E88 convertToDouble -54E25 } 0xc57bead72a838454 test expr-28.578 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +63 E-22 x 1dc03b8fd70169_11111111110& E-68 convertToDouble +63E-22 } 0x3bbdc03b8fd7016a test expr-28.579 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -63 E-23 x -17ccfc73126787_11111111110& E-71 convertToDouble -63E-23 } 0xbb87ccfc73126788 test expr-28.580 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +43 E-4 x 119ce075f6fd21_111111110& E-8 convertToDouble +43E-4 } 0x3f719ce075f6fd22 test expr-28.581 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -86 E-4 x -119ce075f6fd21_111111110& E-7 convertToDouble -86E-4 } 0xbf819ce075f6fd22 test expr-28.582 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +942 E26 x 1306069e8681f3_00000000001& E96 convertToDouble +942E26 } 0x45f306069e8681f3 test expr-28.583 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -471 E25 x -1e700a973d9cb8_0000000001& E91 convertToDouble -471E25 } 0xc5ae700a973d9cb8 test expr-28.584 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +803 E24 x 14c1cee9cd666b_000000000001& E89 convertToDouble +803E24 } 0x4584c1cee9cd666b test expr-28.585 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -471 E26 x -1306069e8681f3_00000000001& E95 convertToDouble -471E26 } 0xc5e306069e8681f3 test expr-28.586 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -409 E-21 x -1e2dcaa4115622_000000000001& E-62 convertToDouble -409E-21 } 0xbc1e2dcaa4115622 test expr-28.587 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +818 E-21 x 1e2dcaa4115622_000000000001& E-61 convertToDouble +818E-21 } 0x3c2e2dcaa4115622 test expr-28.588 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -867 E-8 x -122eabba029aba_000000000001& E-17 convertToDouble -867E-8 } 0xbee22eabba029aba test expr-28.589 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +538 E27 x 1b297cad9f70b5_1111111111111110& E98 convertToDouble +538E27 } 0x461b297cad9f70b6 test expr-28.590 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -857 E24 x -16272678ba603b_11111111110& E89 convertToDouble -857E24 } 0xc586272678ba603c test expr-28.591 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +269 E27 x 1b297cad9f70b5_1111111111111110& E97 convertToDouble +269E27 } 0x460b297cad9f70b6 test expr-28.592 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -403 E26 x -1046ec1e31dd85_1111111110& E95 convertToDouble -403E26 } 0xc5e046ec1e31dd86 test expr-28.593 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +959 E-7 x 1923bd746a3527_11111111111110& E-14 convertToDouble +959E-7 } 0x3f1923bd746a3528 test expr-28.594 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -959 E-6 x -1f6cacd184c271_1111111111110& E-11 convertToDouble -959E-6 } 0xbf4f6cacd184c272 test expr-28.595 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +373 E-27 x 1cdc06b20ef182_1111111111110& E-82 convertToDouble +373E-27 } 0x3adcdc06b20ef183 test expr-28.596 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -746 E-27 x -1cdc06b20ef182_1111111111110& E-81 convertToDouble -746E-27 } 0xbaecdc06b20ef183 test expr-28.597 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4069 E24 x 1a4b9887fbfe7a_0000000000001& E91 convertToDouble +4069E24 } 0x45aa4b9887fbfe7a test expr-28.598 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -4069 E23 x -150946d32ffec8_0000000000001& E88 convertToDouble -4069E23 } 0xc5750946d32ffec8 test expr-28.599 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8138 E24 x -1a4b9887fbfe7a_0000000000001& E92 convertToDouble -8138E24 } 0xc5ba4b9887fbfe7a test expr-28.600 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +8294 E-15 x 123d1b5eb1d778_000000000000000001& E-37 convertToDouble +8294E-15 } 0x3da23d1b5eb1d778 test expr-28.601 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -4147 E-14 x -16cc62365e4d56_00000000000000001& E-35 convertToDouble -4147E-14 } 0xbdc6cc62365e4d56 test expr-28.602 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4147 E-15 x 123d1b5eb1d778_000000000000000001& E-38 convertToDouble +4147E-15 } 0x3d923d1b5eb1d778 test expr-28.603 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8294 E-14 x -16cc62365e4d56_00000000000000001& E-34 convertToDouble -8294E-14 } 0xbdd6cc62365e4d56 test expr-28.604 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +538 E27 x 1b297cad9f70b5_1111111111111110& E98 convertToDouble +538E27 } 0x461b297cad9f70b6 test expr-28.605 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -2690 E26 x -1b297cad9f70b5_1111111111111110& E97 convertToDouble -2690E26 } 0xc60b297cad9f70b6 test expr-28.606 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +269 E27 x 1b297cad9f70b5_1111111111111110& E97 convertToDouble +269E27 } 0x460b297cad9f70b6 test expr-28.607 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -2152 E27 x -1b297cad9f70b5_1111111111111110& E100 convertToDouble -2152E27 } 0xc63b297cad9f70b6 test expr-28.608 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +1721 E-17 x 136071dcae4564_111111111111110& E-46 convertToDouble +1721E-17 } 0x3d136071dcae4565 test expr-28.609 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -7979 E-27 x -134ac304747faf_111111111111110& E-77 convertToDouble -7979E-27 } 0xbb234ac304747fb0 test expr-28.610 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +6884 E-17 x 136071dcae4564_111111111111110& E-44 convertToDouble +6884E-17 } 0x3d336071dcae4565 test expr-28.611 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8605 E-18 x -136071dcae4564_111111111111110& E-47 convertToDouble -8605E-18 } 0xbd036071dcae4565 test expr-28.612 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +82854 E27 x 10570ed9e3cecc_00000000000000001& E106 convertToDouble +82854E27 } 0x4690570ed9e3cecc test expr-28.613 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -55684 E24 x -167d9735144ae3_00000000000000001& E95 convertToDouble -55684E24 } 0xc5e67d9735144ae3 test expr-28.614 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +27842 E24 x 167d9735144ae3_00000000000000001& E94 convertToDouble +27842E24 } 0x45d67d9735144ae3 test expr-28.615 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -48959 E25 x -18b7cd6ca56f85_00000000000000001& E98 convertToDouble -48959E25 } 0xc618b7cd6ca56f85 test expr-28.616 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +81921 E-17 x 1cd2c9a6cdd003_000000000000000000001& E-41 convertToDouble +81921E-17 } 0x3d6cd2c9a6cdd003 test expr-28.617 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -76207 E-8 x -18f8b4dd16f1df_0000000000000000001& E-11 convertToDouble -76207E-8 } 0xbf48f8b4dd16f1df test expr-28.618 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4147 E-15 x 123d1b5eb1d778_000000000000000001& E-38 convertToDouble +4147E-15 } 0x3d923d1b5eb1d778 test expr-28.619 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -41470 E-16 x -123d1b5eb1d778_000000000000000001& E-38 convertToDouble -41470E-16 } 0xbd923d1b5eb1d778 test expr-28.620 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +89309 E24 x 12092ac5f2019e_1111111111111111110& E96 convertToDouble +89309E24 } 0x45f2092ac5f2019f test expr-28.621 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +75859 E26 x 17efd75a2938eb_1111111111111111111110& E102 convertToDouble +75859E26 } 0x4657efd75a2938ec test expr-28.622 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -75859 E25 x -132645e1ba93ef_1111111111111111111110& E99 convertToDouble -75859E25 } 0xc6232645e1ba93f0 test expr-28.623 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +14257 E-23 x 150a246ecd44f2_1111111111111111110& E-63 convertToDouble +14257E-23 } 0x3c050a246ecd44f3 test expr-28.624 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -28514 E-23 x -150a246ecd44f2_1111111111111111110& E-62 convertToDouble -28514E-23 } 0xbc150a246ecd44f3 test expr-28.625 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +57028 E-23 x 150a246ecd44f2_1111111111111111110& E-61 convertToDouble +57028E-23 } 0x3c250a246ecd44f3 test expr-28.626 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -71285 E-24 x -150a246ecd44f2_1111111111111111110& E-64 convertToDouble -71285E-24 } 0xbbf50a246ecd44f3 test expr-28.627 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +344863 E27 x 1100c873963d6d_00000000000000000001& E108 convertToDouble +344863E27 } 0x46b100c873963d6d test expr-28.628 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -951735 E27 x -17764ad224e24a_000000000000000000001& E109 convertToDouble -951735E27 } 0xc6c7764ad224e24a test expr-28.629 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +200677 E23 x 1035e73135b834_0000000000000000001& E94 convertToDouble +200677E23 } 0x45d035e73135b834 test expr-28.630 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -401354 E24 x -144360fd832641_0000000000000000001& E98 convertToDouble -401354E24 } 0xc6144360fd832641 test expr-28.631 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +839604 E-11 x 119b96f36ec68b_00000000000000000000000001& E-17 convertToDouble +839604E-11 } 0x3ee19b96f36ec68b test expr-28.632 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -209901 E-11 x -119b96f36ec68b_00000000000000000000000001& E-19 convertToDouble -209901E-11 } 0xbec19b96f36ec68b test expr-28.633 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +419802 E-11 x 119b96f36ec68b_00000000000000000000000001& E-18 convertToDouble +419802E-11 } 0x3ed19b96f36ec68b test expr-28.634 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -537734 E-24 x -13d6c1088ae40e_0000000000000000000001& E-61 convertToDouble -537734E-24 } 0xbc23d6c1088ae40e test expr-28.635 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +910308 E26 x 11f3e1839eeab0_11111111111111111111110& E106 convertToDouble +910308E26 } 0x4691f3e1839eeab1 test expr-28.636 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -227577 E26 x -11f3e1839eeab0_11111111111111111111110& E104 convertToDouble -227577E26 } 0xc671f3e1839eeab1 test expr-28.637 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +455154 E26 x 11f3e1839eeab0_11111111111111111111110& E105 convertToDouble +455154E26 } 0x4681f3e1839eeab1 test expr-28.638 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -531013 E25 x -10c17d25834171_11111111111111111111110& E102 convertToDouble -531013E25 } 0xc650c17d25834172 test expr-28.639 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +963019 E-21 x 11592429784914_11111111111111111111110& E-50 convertToDouble +963019E-21 } 0x3cd1592429784915 test expr-28.640 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -519827 E-13 x -1be872a8b30d7c_11111111111111111111110& E-25 convertToDouble -519827E-13 } 0xbe6be872a8b30d7d test expr-28.641 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +623402 E-27 x 178d2c97bde2a0_11111111111111111111110& E-71 convertToDouble +623402E-27 } 0x3b878d2c97bde2a1 test expr-28.642 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -311701 E-27 x -178d2c97bde2a0_11111111111111111111110& E-72 convertToDouble -311701E-27 } 0xbb778d2c97bde2a1 test expr-28.643 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +9613651 E26 x 17b31116270d9b_000000000000000000000001& E109 convertToDouble +9613651E26 } 0x46c7b31116270d9b test expr-28.644 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -9191316 E23 x -1733bfae0801fd_0000000000000000000001& E99 convertToDouble -9191316E23 } 0xc62733bfae0801fd test expr-28.645 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4595658 E23 x 1733bfae0801fd_0000000000000000000001& E98 convertToDouble +4595658E23 } 0x461733bfae0801fd test expr-28.646 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -2297829 E23 x -1733bfae0801fd_0000000000000000000001& E97 convertToDouble -2297829E23 } 0xc60733bfae0801fd test expr-28.647 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -1679208 E-11 x -119b96f36ec68b_00000000000000000000000001& E-16 convertToDouble -1679208E-11 } 0xbef19b96f36ec68b test expr-28.648 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +3379223 E27 x 14d3794ce2fc25_1111111111111111111111110& E111 convertToDouble +3379223E27 } 0x46e4d3794ce2fc26 test expr-28.649 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -6758446 E27 x -14d3794ce2fc25_1111111111111111111111110& E112 convertToDouble -6758446E27 } 0xc6f4d3794ce2fc26 test expr-28.650 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +5444097 E-21 x 18849dd33c95ae_11111111111111111111111111110& E-48 convertToDouble +5444097E-21 } 0x3cf8849dd33c95af test expr-28.651 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8399969 E-27 x -13d5783e85fcf7_1111111111111111111111110& E-67 convertToDouble -8399969E-27 } 0xbbc3d5783e85fcf8 test expr-28.652 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +8366487 E-16 x 1cbf3d630403af_1111111111111111111111110& E-31 convertToDouble +8366487E-16 } 0x3e0cbf3d630403b0 test expr-28.653 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8366487 E-15 x -11f7865de2824d_11111111111111111111111110& E-27 convertToDouble -8366487E-15 } 0xbe41f7865de2824e test expr-28.654 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +65060671 E25 x 1009e7d474572a_0000000000000000000000000001& E109 convertToDouble +65060671E25 } 0x46c009e7d474572a test expr-28.655 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +65212389 E23 x 1493d098d37657_000000000000000000000000001& E102 convertToDouble +65212389E23 } 0x465493d098d37657 test expr-28.656 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +55544957 E-13 x 174c1826f3010c_00000000000000000000000000001& E-18 convertToDouble +55544957E-13 } 0x3ed74c1826f3010c test expr-28.657 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -51040905 E-20 x -11f55b23c8bf2d_0000000000000000000000000001& E-41 convertToDouble -51040905E-20 } 0xbd61f55b23c8bf2d test expr-28.658 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +99585767 E-22 x 166cba8699f0f2_0000000000000000000000000001& E-47 convertToDouble +99585767E-22 } 0x3d066cba8699f0f2 test expr-28.659 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -99585767 E-23 x -11f095387b2728_0000000000000000000000000001& E-50 convertToDouble -99585767E-23 } 0xbcd1f095387b2728 test expr-28.660 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +40978393 E26 x 1941401cca2bfd_1111111111111111111111111110& E111 convertToDouble +40978393E26 } 0x46e941401cca2bfe test expr-28.661 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -67488159 E24 x -1a9e90059d12db_11111111111111111111111111110& E105 convertToDouble -67488159E24 } 0xc68a9e90059d12dc test expr-28.662 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +69005339 E23 x 15c634f6ef1f95_111111111111111111111111110& E102 convertToDouble +69005339E23 } 0x4655c634f6ef1f96 test expr-28.663 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -81956786 E26 x -1941401cca2bfd_1111111111111111111111111110& E112 convertToDouble -81956786E26 } 0xc6f941401cca2bfe test expr-28.664 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -87105552 E-21 x -18849dd33c95ae_11111111111111111111111111110& E-44 convertToDouble -87105552E-21 } 0xbd38849dd33c95af test expr-28.665 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +10888194 E-21 x 18849dd33c95ae_11111111111111111111111111110& E-47 convertToDouble +10888194E-21 } 0x3d08849dd33c95af test expr-28.666 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -21776388 E-21 x -18849dd33c95ae_11111111111111111111111111110& E-46 convertToDouble -21776388E-21 } 0xbd18849dd33c95af test expr-28.667 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +635806667 E27 x 1e9cec176c96f8_000000000000000000000000000000001& E118 convertToDouble +635806667E27 } 0x475e9cec176c96f8 test expr-28.668 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -670026614 E25 x -14a593f89f4194_00000000000000000000000000000001& E112 convertToDouble -670026614E25 } 0xc6f4a593f89f4194 test expr-28.669 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +335013307 E26 x 19cef8f6c711f9_0000000000000000000000000000001& E114 convertToDouble +335013307E26 } 0x4719cef8f6c711f9 test expr-28.670 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -335013307 E25 x -14a593f89f4194_00000000000000000000000000000001& E111 convertToDouble -335013307E25 } 0xc6e4a593f89f4194 test expr-28.671 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +371790617 E-24 x 1aca538c61ba9c_000000000000000000000000000000001& E-52 convertToDouble +371790617E-24 } 0x3cbaca538c61ba9c test expr-28.672 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -371790617 E-25 x -156ea93d1afbb0_0000000000000000000000000000000001& E-55 convertToDouble -371790617E-25 } 0xbc856ea93d1afbb0 test expr-28.673 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +743581234 E-24 x 1aca538c61ba9c_000000000000000000000000000000001& E-51 convertToDouble +743581234E-24 } 0x3ccaca538c61ba9c test expr-28.674 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -743581234 E-25 x -156ea93d1afbb0_0000000000000000000000000000000001& E-54 convertToDouble -743581234E-25 } 0xbc956ea93d1afbb0 test expr-28.675 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +202464477 E24 x 13f6ec0435ce24_111111111111111111111111111110& E107 convertToDouble +202464477E24 } 0x46a3f6ec0435ce25 test expr-28.676 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -404928954 E24 x -13f6ec0435ce24_111111111111111111111111111110& E108 convertToDouble -404928954E24 } 0xc6b3f6ec0435ce25 test expr-28.677 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +997853758 E27 x 1805bfa33b98fa_111111111111111111111111111110& E119 convertToDouble +997853758E27 } 0x476805bfa33b98fb test expr-28.678 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -997853758 E26 x -1337cc829613fb_111111111111111111111111111110& E116 convertToDouble -997853758E26 } 0xc73337cc829613fc test expr-28.679 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +405498418 E-17 x 116a8093df66a6_111111111111111111111111111111110& E-28 convertToDouble +405498418E-17 } 0x3e316a8093df66a7 test expr-28.680 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -582579084 E-14 x -186f653140a658_111111111111111111111111111111110& E-18 convertToDouble -582579084E-14 } 0xbed86f653140a659 test expr-28.681 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +608247627 E-18 x 14e633e4a5ae61_111111111111111111111111111111110& E-31 convertToDouble +608247627E-18 } 0x3e04e633e4a5ae62 test expr-28.682 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -291289542 E-14 x -186f653140a658_111111111111111111111111111111110& E-19 convertToDouble -291289542E-14 } 0xbec86f653140a659 test expr-28.683 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -9537100005 E26 x -16f5b11191713a_000000000000000000000000000000001& E119 convertToDouble -9537100005E26 } 0xc766f5b11191713a test expr-28.684 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +6358066670 E27 x 1322138ea3de5b_000000000000000000000000000000001& E122 convertToDouble +6358066670E27 } 0x479322138ea3de5b test expr-28.685 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -1271613334 E27 x -1e9cec176c96f8_000000000000000000000000000000001& E119 convertToDouble -1271613334E27 } 0xc76e9cec176c96f8 test expr-28.686 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +5229646999 E-16 x 118c3b89731f3d_000000000000000000000000000000000001& E-21 convertToDouble +5229646999E-16 } 0x3ea18c3b89731f3d test expr-28.687 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +5229646999 E-17 x 1c13927584fec8_00000000000000000000000000000000001& E-25 convertToDouble +5229646999E-17 } 0x3e6c13927584fec8 test expr-28.688 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4429943614 E24 x 1b4d37fa06864a_1111111111111111111111111111111110& E111 convertToDouble +4429943614E24 } 0x46eb4d37fa06864b test expr-28.689 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8859887228 E24 x -1b4d37fa06864a_1111111111111111111111111111111110& E112 convertToDouble -8859887228E24 } 0xc6fb4d37fa06864b test expr-28.690 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +2214971807 E24 x 1b4d37fa06864a_1111111111111111111111111111111110& E110 convertToDouble +2214971807E24 } 0x46db4d37fa06864b test expr-28.691 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -4176887093 E26 x -141c692c5bd07a_111111111111111111111111111111110& E118 convertToDouble -4176887093E26 } 0xc7541c692c5bd07b test expr-28.692 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4003495257 E-20 x 16026b2e07ec06_111111111111111111111111111111111110& E-35 convertToDouble +4003495257E-20 } 0x3dc6026b2e07ec07 test expr-28.693 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -4361901637 E-23 x -188e29a9d7c5b8_11111111111111111111111111111111110& E-45 convertToDouble -4361901637E-23 } 0xbd288e29a9d7c5b9 test expr-28.694 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +8723803274 E-23 x 188e29a9d7c5b8_11111111111111111111111111111111110& E-44 convertToDouble +8723803274E-23 } 0x3d388e29a9d7c5b9 test expr-28.695 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8006990514 E-20 x -16026b2e07ec06_111111111111111111111111111111111110& E-34 convertToDouble -8006990514E-20 } 0xbdd6026b2e07ec07 test expr-28.696 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +72835110098 E27 x 1b65c41711fb6d_0000000000000000000000000000000000001& E125 convertToDouble +72835110098E27 } 0x47cb65c41711fb6d test expr-28.697 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -36417555049 E27 x -1b65c41711fb6d_0000000000000000000000000000000000001& E124 convertToDouble -36417555049E27 } 0xc7bb65c41711fb6d test expr-28.698 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +84279630104 E25 x 144a221b1cf62e_000000000000000000000000000000000001& E119 convertToDouble +84279630104E25 } 0x47644a221b1cf62e test expr-28.699 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -84279630104 E24 x -103b4e7c172b58_000000000000000000000000000000000001& E116 convertToDouble -84279630104E24 } 0xc7303b4e7c172b58 test expr-28.700 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +21206176437 E-27 x 1872f563ae0cc9_0000000000000000000000000000000000001& E-56 convertToDouble +21206176437E-27 } 0x3c7872f563ae0cc9 test expr-28.701 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -66461566917 E-22 x -1d3ae83e4322b3_00000000000000000000000000000000000001& E-38 convertToDouble -66461566917E-22 } 0xbd9d3ae83e4322b3 test expr-28.702 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +64808355539 E-16 x 1b2ebe83265fbf_00000000000000000000000000000000000001& E-18 convertToDouble +64808355539E-16 } 0x3edb2ebe83265fbf test expr-28.703 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -84932679673 E-19 x -123d39339f1bf6_00000000000000000000000000000000000001& E-27 convertToDouble -84932679673E-19 } 0xbe423d39339f1bf6 test expr-28.704 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +65205430094 E26 x 139f3e5d7fd76a_1111111111111111111111111111111111110& E122 convertToDouble +65205430094E26 } 0x47939f3e5d7fd76b test expr-28.705 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -68384463429 E25 x -107684982f634e_1111111111111111111111111111111111111110& E119 convertToDouble -68384463429E25 } 0xc7607684982f634f test expr-28.706 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +32602715047 E26 x 139f3e5d7fd76a_1111111111111111111111111111111111110& E121 convertToDouble +32602715047E26 } 0x47839f3e5d7fd76b test expr-28.707 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -62662203426 E27 x -1792269424688d_111111111111111111111111111111111110& E125 convertToDouble -62662203426E27 } 0xc7c792269424688e test expr-28.708 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +58784444678 E-18 x 1f8f45c64b4682_111111111111111111111111111111111111110& E-25 convertToDouble +58784444678E-18 } 0x3e6f8f45c64b4683 test expr-28.709 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -50980203373 E-21 x -1c06d366394440_11111111111111111111111111111111111111111110& E-35 convertToDouble -50980203373E-21 } 0xbdcc06d366394441 test expr-28.710 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +29392222339 E-18 x 1f8f45c64b4682_111111111111111111111111111111111111110& E-26 convertToDouble +29392222339E-18 } 0x3e5f8f45c64b4683 test expr-28.711 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -75529940323 E-27 x -15c5203c0aad52_1111111111111111111111111111111111111110& E-54 convertToDouble -75529940323E-27 } 0xbc95c5203c0aad53 test expr-28.712 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -937495906299 E26 x -11a1e0ebb6af11_000000000000000000000000000000000000000001& E126 convertToDouble -937495906299E26 } 0xc7d1a1e0ebb6af11 test expr-28.713 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +842642485799 E-20 x 121879decdd7cb_000000000000000000000000000000000000000001& E-27 convertToDouble +842642485799E-20 } 0x3e421879decdd7cb test expr-28.714 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -387824150699 E-23 x -110e8302245571_00000000000000000000000000000000000000001& E-38 convertToDouble -387824150699E-23 } 0xbd910e8302245571 test expr-28.715 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +924948814726 E-27 x 10a992d1fc6ded_00000000000000000000000000000000000000001& E-50 convertToDouble +924948814726E-27 } 0x3cd0a992d1fc6ded test expr-28.716 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -775648301398 E-23 x -110e8302245571_00000000000000000000000000000000000000001& E-37 convertToDouble -775648301398E-23 } 0xbda10e8302245571 test expr-28.717 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +547075707432 E25 x 107684982f634e_1111111111111111111111111111111111111110& E122 convertToDouble +547075707432E25 } 0x47907684982f634f test expr-28.718 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +683844634290 E24 x 107684982f634e_1111111111111111111111111111111111111110& E119 convertToDouble +683844634290E24 } 0x47607684982f634f test expr-28.719 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -136768926858 E25 x -107684982f634e_1111111111111111111111111111111111111110& E120 convertToDouble -136768926858E25 } 0xc7707684982f634f test expr-28.720 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +509802033730 E-22 x 1c06d366394440_11111111111111111111111111111111111111111110& E-35 convertToDouble +509802033730E-22 } 0x3dcc06d366394441 test expr-28.721 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +101960406746 E-21 x 1c06d366394440_11111111111111111111111111111111111111111110& E-34 convertToDouble +101960406746E-21 } 0x3ddc06d366394441 test expr-28.722 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -815683253968 E-21 x -1c06d366394440_11111111111111111111111111111111111111111110& E-31 convertToDouble -815683253968E-21 } 0xbe0c06d366394441 test expr-28.723 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +7344124123524 E24 x 1619b519dd6833_00000000000000000000000000000000000000000001& E122 convertToDouble +7344124123524E24 } 0x479619b519dd6833 test expr-28.724 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -9180155154405 E23 x -1619b519dd6833_00000000000000000000000000000000000000000001& E119 convertToDouble -9180155154405E23 } 0xc76619b519dd6833 test expr-28.725 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +6479463327323 E27 x 130a9b3e9bd05e_00000000000000000000000000000000000000000001& E132 convertToDouble +6479463327323E27 } 0x48330a9b3e9bd05e test expr-28.726 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -1836031030881 E24 x -1619b519dd6833_00000000000000000000000000000000000000000001& E120 convertToDouble -1836031030881E24 } 0xc77619b519dd6833 test expr-28.727 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4337269293039 E-19 x 1d1b5f354c63d6_00000000000000000000000000000000000000000001& E-22 convertToDouble +4337269293039E-19 } 0x3e9d1b5f354c63d6 test expr-28.728 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -4599163554373 E-23 x -1948bf4d34088d_00000000000000000000000000000000000000000001& E-35 convertToDouble -4599163554373E-23 } 0xbdc948bf4d34088d test expr-28.729 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +9198327108746 E-23 x 1948bf4d34088d_00000000000000000000000000000000000000000001& E-34 convertToDouble +9198327108746E-23 } 0x3dd948bf4d34088d test expr-28.730 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4812803938347 E27 x 1c4980a4ee94ce_111111111111111111111111111111111111111111110& E131 convertToDouble +4812803938347E27 } 0x482c4980a4ee94cf test expr-28.731 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8412030890011 E23 x -14405075e52db9_11111111111111111111111111111111111111111110& E119 convertToDouble -8412030890011E23 } 0xc764405075e52dba test expr-28.732 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +9625607876694 E27 x 1c4980a4ee94ce_111111111111111111111111111111111111111111110& E132 convertToDouble +9625607876694E27 } 0x483c4980a4ee94cf test expr-28.733 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -4739968828249 E24 x -1c87140cdf8a1d_1111111111111111111111111111111111111111110& E121 convertToDouble -4739968828249E24 } 0xc78c87140cdf8a1e test expr-28.734 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +9697183891673 E-23 x 1aa7c959b6a666_11111111111111111111111111111111111111111111110& E-34 convertToDouble +9697183891673E-23 } 0x3ddaa7c959b6a667 test expr-28.735 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -7368108517543 E-20 x -13c7535bbd85a1_1111111111111111111111111111111111111111111110& E-24 convertToDouble -7368108517543E-20 } 0xbe73c7535bbd85a2 test expr-28.736 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +51461358161422 E25 x 18326f87d4cae0_0000000000000000000000000000000000000000000000001& E128 convertToDouble +51461358161422E25 } 0x47f8326f87d4cae0 test expr-28.737 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -77192037242133 E26 x -16af488f577e32_0000000000000000000000000000000000000000000000001& E132 convertToDouble -77192037242133E26 } 0xc836af488f577e32 test expr-28.738 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +77192037242133 E25 x 1225d3a5df9828_0000000000000000000000000000000000000000000000001& E129 convertToDouble +77192037242133E25 } 0x480225d3a5df9828 test expr-28.739 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -51461358161422 E27 x -12e767221e3e7f_0000000000000000000000000000000000000000000000001& E135 convertToDouble -51461358161422E27 } 0xc862e767221e3e7f test expr-28.740 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +43999661561541 E-21 x 179f4476d372a3_0000000000000000000000000000000000000000000000001& E-25 convertToDouble +43999661561541E-21 } 0x3e679f4476d372a3 test expr-28.741 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -87999323123082 E-21 x -179f4476d372a3_0000000000000000000000000000000000000000000000001& E-24 convertToDouble -87999323123082E-21 } 0xbe779f4476d372a3 test expr-28.742 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +48374886826137 E-26 x 110538f23350d5_00000000000000000000000000000000000000000000001& E-41 convertToDouble +48374886826137E-26 } 0x3d610538f23350d5 test expr-28.743 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -57684246567111 E-23 x -13d1f5c1b8a912_00000000000000000000000000000000000000000000001& E-31 convertToDouble -57684246567111E-23 } 0xbe03d1f5c1b8a912 test expr-28.744 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +87192805957686 E23 x 1a3d16e55a9664_1111111111111111111111111111111111111111111110& E122 convertToDouble +87192805957686E23 } 0x479a3d16e55a9665 test expr-28.745 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -75108713005913 E24 x -1c40b4baa79655_11111111111111111111111111111111111111111111110& E125 convertToDouble -75108713005913E24 } 0xc7cc40b4baa79656 test expr-28.746 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +64233110587487 E27 x 179873e38669a6_1111111111111111111111111111111111111111111110& E135 convertToDouble +64233110587487E27 } 0x48679873e38669a7 test expr-28.747 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -77577471133384 E-23 x -1aa7c959b6a666_11111111111111111111111111111111111111111111110& E-31 convertToDouble -77577471133384E-23 } 0xbe0aa7c959b6a667 test expr-28.748 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +48485919458365 E-24 x 1aa7c959b6a666_11111111111111111111111111111111111111111111110& E-35 convertToDouble +48485919458365E-24 } 0x3dcaa7c959b6a667 test expr-28.749 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -56908598265713 E-26 x -1405deef4bdef5_111111111111111111111111111111111111111111111110& E-41 convertToDouble -56908598265713E-26 } 0xbd6405deef4bdef6 test expr-28.750 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +589722294620133 E23 x 162ed1b287caef_00000000000000000000000000000000000000000000000001& E125 convertToDouble +589722294620133E23 } 0x47c62ed1b287caef test expr-28.751 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +652835804449289 E-22 x 118640e490b087_0000000000000000000000000000000000000000000000000001& E-24 convertToDouble +652835804449289E-22 } 0x3e718640e490b087 test expr-28.752 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -656415363936202 E-23 x -1c315cfe25d201_00000000000000000000000000000000000000000000000001& E-28 convertToDouble -656415363936202E-23 } 0xbe3c315cfe25d201 test expr-28.753 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +579336749585745 E-25 x 1fd9709d9aeb19_00000000000000000000000000000000000000000000000001& E-35 convertToDouble +579336749585745E-25 } 0x3dcfd9709d9aeb19 test expr-28.754 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -381292764980839 E-26 x -10c4f9921c3f8f_00000000000000000000000000000000000000000000000001& E-38 convertToDouble -381292764980839E-26 } 0xbd90c4f9921c3f8f test expr-28.755 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +965265859649698 E23 x 12279607edcb0c_1111111111111111111111111111111111111111111111110& E126 convertToDouble +965265859649698E23 } 0x47d2279607edcb0d test expr-28.756 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -848925235434882 E27 x -137d88ba4b43e3_1111111111111111111111111111111111111111111111111110& E139 convertToDouble -848925235434882E27 } 0xc8a37d88ba4b43e4 test expr-28.757 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +536177612222491 E23 x 142b33dd3acafd_11111111111111111111111111111111111111111111111110& E125 convertToDouble +536177612222491E23 } 0x47c42b33dd3acafe test expr-28.758 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -424462617717441 E27 x -137d88ba4b43e3_1111111111111111111111111111111111111111111111111110& E138 convertToDouble -424462617717441E27 } 0xc8937d88ba4b43e4 test expr-28.759 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +276009279888989 E-27 x 136c242313c288_111111111111111111111111111111111111111111111111110& E-42 convertToDouble +276009279888989E-27 } 0x3d536c242313c289 test expr-28.760 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -608927158043691 E-26 x -1ac7e909c22f09_11111111111111111111111111111111111111111111111110& E-38 convertToDouble -608927158043691E-26 } 0xbd9ac7e909c22f0a test expr-28.761 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +552018559777978 E-27 x 136c242313c288_111111111111111111111111111111111111111111111111110& E-41 convertToDouble +552018559777978E-27 } 0x3d636c242313c289 test expr-28.762 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -425678377667758 E-22 x -16da7aa49bdcd5_1111111111111111111111111111111111111111111111110& E-25 convertToDouble -425678377667758E-22 } 0xbe66da7aa49bdcd6 test expr-28.763 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +8013702726927119 E26 x 126607f8f1b29e_00000000000000000000000000000000000000000000000000001& E139 convertToDouble +8013702726927119E26 } 0x48a26607f8f1b29e test expr-28.764 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +8862627962362001 E27 x 196f3b0e7787c2_00000000000000000000000000000000000000000000000000001& E142 convertToDouble +8862627962362001E27 } 0x48d96f3b0e7787c2 test expr-28.765 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -5068007907757162 E26 x -17456a27848397_00000000000000000000000000000000000000000000000000001& E138 convertToDouble -5068007907757162E26 } 0xc897456a27848397 test expr-28.766 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -7379714799828406 E-23 x -13cf4d2839e036_00000000000000000000000000000000000000000000000000001& E-24 convertToDouble -7379714799828406E-23 } 0xbe73cf4d2839e036 test expr-28.767 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4114538064016107 E-27 x 12188eda98010c_0000000000000000000000000000000000000000000000000001& E-38 convertToDouble +4114538064016107E-27 } 0x3d92188eda98010c test expr-28.768 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -3689857399914203 E-23 x -13cf4d2839e036_00000000000000000000000000000000000000000000000000001& E-25 convertToDouble -3689857399914203E-23 } 0xbe63cf4d2839e036 test expr-28.769 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +5575954851815478 E23 x 1a37cfbf2ffdb5_1111111111111111111111111111111111111111111111111110& E128 convertToDouble +5575954851815478E23 } 0x47fa37cfbf2ffdb6 test expr-28.770 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +3395700941739528 E27 x 137d88ba4b43e3_1111111111111111111111111111111111111111111111111110& E141 convertToDouble +3395700941739528E27 } 0x48c37d88ba4b43e4 test expr-28.771 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4115535777581961 E-23 x 1618596be30fe4_111111111111111111111111111111111111111111111111111110& E-25 convertToDouble +4115535777581961E-23 } 0x3e6618596be30fe5 test expr-28.772 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8231071555163922 E-23 x -1618596be30fe4_111111111111111111111111111111111111111111111111111110& E-24 convertToDouble -8231071555163922E-23 } 0xbe7618596be30fe5 test expr-28.773 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +6550246696190871 E-26 x 1201538b0f8c69_111111111111111111111111111111111111111111111111111110& E-34 convertToDouble +6550246696190871E-26 } 0x3dd201538b0f8c6a test expr-28.774 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -68083046403986701 E27 x -186c70ba8ba28d_000000000000000000000000000000000000000000000000000000001& E145 convertToDouble -68083046403986701E27 } 0xc9086c70ba8ba28d test expr-28.775 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +43566388595783643 E27 x 1f41e1bf48b03f_111111111111111111111111111111111111111111111111111111110& E144 convertToDouble +43566388595783643E27 } 0x48ff41e1bf48b040 test expr-28.776 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -87132777191567286 E27 x -1f41e1bf48b03f_111111111111111111111111111111111111111111111111111111110& E145 convertToDouble -87132777191567286E27 } 0xc90f41e1bf48b040 test expr-28.777 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +59644881059342141 E25 x 1b6338d9d8ae38_11111111111111111111111111111111111111111111111111111110& E138 convertToDouble +59644881059342141E25 } 0x489b6338d9d8ae39 test expr-28.778 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -83852770718576667 E23 x -18a4619ed6f442_111111111111111111111111111111111111111111111111111111110& E132 convertToDouble -83852770718576667E23 } 0xc838a4619ed6f443 test expr-28.779 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +99482967418206961 E-25 x 155d224bfed7ac_11111111111111111111111111111111111111111111111111111111110& E-27 convertToDouble +99482967418206961E-25 } 0x3e455d224bfed7ad test expr-28.780 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -99482967418206961 E-26 x -11174ea3324623_11111111111111111111111111111111111111111111111111111111110& E-30 convertToDouble -99482967418206961E-26 } 0xbe11174ea3324624 test expr-28.781 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +87446669969994614 E-27 x 1809832942376d_11111111111111111111111111111111111111111111111111111110& E-34 convertToDouble +87446669969994614E-27 } 0x3dd809832942376e test expr-28.782 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -43723334984997307 E-27 x -1809832942376d_11111111111111111111111111111111111111111111111111111110& E-35 convertToDouble -43723334984997307E-27 } 0xbdc809832942376e test expr-28.783 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +5 E24 x 108b2a2c280290_1001& E82 convertToDouble +5E24 } 0x45108b2a2c280291 test expr-28.784 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8 E25 x -108b2a2c280290_1001& E86 convertToDouble -8E25 } 0xc5508b2a2c280291 test expr-28.785 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +1 E25 x 108b2a2c280290_1001& E83 convertToDouble +1E25 } 0x45208b2a2c280291 test expr-28.786 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -4 E25 x -108b2a2c280290_1001& E85 convertToDouble -4E25 } 0xc5408b2a2c280291 test expr-28.787 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +2 E-5 x 14f8b588e368f0_100001& E-16 convertToDouble +2E-5 } 0x3ef4f8b588e368f1 test expr-28.788 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -5 E-6 x -14f8b588e368f0_100001& E-18 convertToDouble -5E-6 } 0xbed4f8b588e368f1 test expr-28.789 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4 E-5 x 14f8b588e368f0_100001& E-15 convertToDouble +4E-5 } 0x3f04f8b588e368f1 test expr-28.790 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -3 E-20 x -11b578c96db19a_100001& E-65 convertToDouble -3E-20 } 0xbbe1b578c96db19b test expr-28.791 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +3 E27 x 1363156bbee301_0110& E91 convertToDouble +3E27 } 0x45a363156bbee301 test expr-28.792 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -9 E26 x -1743b34e18439b_010& E89 convertToDouble -9E26 } 0xc58743b34e18439b test expr-28.793 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +7 E25 x 1cf389cd46047d_00& E85 convertToDouble +7E25 } 0x454cf389cd46047d test expr-28.794 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -6 E27 x -1363156bbee301_0110& E92 convertToDouble -6E27 } 0xc5b363156bbee301 test expr-28.795 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +2 E-21 x 12e3b40a0e9b4f_0111110& E-69 convertToDouble +2E-21 } 0x3ba2e3b40a0e9b4f test expr-28.796 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -5 E-22 x -12e3b40a0e9b4f_0111110& E-71 convertToDouble -5E-22 } 0xbb82e3b40a0e9b4f test expr-28.797 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -4 E-21 x -12e3b40a0e9b4f_0111110& E-68 convertToDouble -4E-21 } 0xbbb2e3b40a0e9b4f test expr-28.798 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +87 E25 x 167d2d5406637c_10001& E89 convertToDouble +87E25 } 0x45867d2d5406637d test expr-28.799 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -97 E24 x -140f232256e982_1000000001& E86 convertToDouble -97E24 } 0xc5540f232256e983 test expr-28.800 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +82 E-24 x 18c87154dff6c6_1000000001& E-74 convertToDouble +82E-24 } 0x3b58c87154dff6c7 test expr-28.801 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -41 E-24 x -18c87154dff6c6_1000000001& E-75 convertToDouble -41E-24 } 0xbb48c87154dff6c7 test expr-28.802 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +76 E-23 x 1cb644dc1633c0_10000001& E-71 convertToDouble +76E-23 } 0x3b8cb644dc1633c1 test expr-28.803 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +83 E25 x 15747ab143e353_011111111110& E89 convertToDouble +83E25 } 0x4585747ab143e353 test expr-28.804 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -50 E27 x -1431e0fae6d721_0111110& E95 convertToDouble -50E27 } 0xc5e431e0fae6d721 test expr-28.805 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +25 E27 x 1431e0fae6d721_0111110& E94 convertToDouble +25E27 } 0x45d431e0fae6d721 test expr-28.806 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -99 E27 x -13fe2e171cda19_011110& E96 convertToDouble -99E27 } 0xc5f3fe2e171cda19 test expr-28.807 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +97 E-10 x 14d4a1a3157dc7_011111110& E-27 convertToDouble +97E-10 } 0x3e44d4a1a3157dc7 test expr-28.808 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -57 E-20 x -15077f6f3242e7_011111110& E-61 convertToDouble -57E-20 } 0xbc25077f6f3242e7 test expr-28.809 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +997 E23 x 149e12f51c1a3c_10000000001& E86 convertToDouble +997E23 } 0x45549e12f51c1a3d test expr-28.810 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +776 E24 x 140f232256e982_1000000001& E89 convertToDouble +776E24 } 0x45840f232256e983 test expr-28.811 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -388 E24 x -140f232256e982_1000000001& E88 convertToDouble -388E24 } 0xc5740f232256e983 test expr-28.812 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +521 E-10 x 1bf891c92c0890_100000000001& E-25 convertToDouble +521E-10 } 0x3e6bf891c92c0891 test expr-28.813 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -506 E-26 x -1877fa0260beb2_10000000001& E-78 convertToDouble -506E-26 } 0xbb1877fa0260beb3 test expr-28.814 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +739 E-10 x 13d65e8c76722c_10000000001& E-24 convertToDouble +739E-10 } 0x3e73d65e8c76722d test expr-28.815 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -867 E-7 x -16ba56a8834168_100000000001& E-14 convertToDouble -867E-7 } 0xbf16ba56a8834169 test expr-28.816 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -415 E24 x -15747ab143e353_011111111110& E88 convertToDouble -415E24 } 0xc575747ab143e353 test expr-28.817 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +332 E25 x 15747ab143e353_011111111110& E91 convertToDouble +332E25 } 0x45a5747ab143e353 test expr-28.818 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -664 E25 x -15747ab143e353_011111111110& E92 convertToDouble -664E25 } 0xc5b5747ab143e353 test expr-28.819 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +291 E-13 x 1ffeebfc8b81b5_01111111111110& E-36 convertToDouble +291E-13 } 0x3dbffeebfc8b81b5 test expr-28.820 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -982 E-8 x -14981285e98e79_0111111111110& E-17 convertToDouble -982E-8 } 0xbee4981285e98e79 test expr-28.821 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +582 E-13 x 1ffeebfc8b81b5_01111111111110& E-35 convertToDouble +582E-13 } 0x3dcffeebfc8b81b5 test expr-28.822 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -491 E-8 x -14981285e98e79_0111111111110& E-18 convertToDouble -491E-8 } 0xbed4981285e98e79 test expr-28.823 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4574 E26 x 1717c1a612f954_100000000001& E98 convertToDouble +4574E26 } 0x461717c1a612f955 test expr-28.824 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8609 E26 x -15bb6f942546ee_1000000000001& E99 convertToDouble -8609E26 } 0xc625bb6f942546ef test expr-28.825 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +2287 E26 x 1717c1a612f954_100000000001& E97 convertToDouble +2287E26 } 0x460717c1a612f955 test expr-28.826 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -4818 E24 x -1f22b65eb419a0_10000000001& E91 convertToDouble -4818E24 } 0xc5af22b65eb419a1 test expr-28.827 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +6529 E-8 x 111d89a8b5c142_100000000000001& E-14 convertToDouble +6529E-8 } 0x3f111d89a8b5c143 test expr-28.828 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8151 E-21 x -12cb804b61b898_1000000000000001& E-57 convertToDouble -8151E-21 } 0xbc62cb804b61b899 test expr-28.829 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +1557 E-12 x 1abfc227ab1026_10000000000001& E-30 convertToDouble +1557E-12 } 0x3e1abfc227ab1027 test expr-28.830 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -2573 E-18 x -172cef1ebbca44_10000000000001& E-49 convertToDouble -2573E-18 } 0xbce72cef1ebbca45 test expr-28.831 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4929 E-16 x 1157a604ed019f_0111111111111110& E-41 convertToDouble +4929E-16 } 0x3d6157a604ed019f test expr-28.832 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -3053 E-22 x -1686f435fe6b6b_011111111111110& E-62 convertToDouble -3053E-22 } 0xbc1686f435fe6b6b test expr-28.833 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +9858 E-16 x 1157a604ed019f_0111111111111110& E-40 convertToDouble +9858E-16 } 0x3d7157a604ed019f test expr-28.834 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -7767 E-11 x -14d971170ed055_011111111111110& E-24 convertToDouble -7767E-11 } 0xbe74d971170ed055 test expr-28.835 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +54339 E26 x 1125782ec15cbe_100000000000000001& E102 convertToDouble +54339E26 } 0x465125782ec15cbf test expr-28.836 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -62409 E25 x -1f822c980d4bb2_100000000000000001& E98 convertToDouble -62409E25 } 0xc61f822c980d4bb3 test expr-28.837 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +32819 E27 x 19e3be885fc16a_100000000000001& E104 convertToDouble +32819E27 } 0x4679e3be885fc16b test expr-28.838 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -89849 E27 x -11b8371b6dda04_1000000000000001& E106 convertToDouble -89849E27 } 0xc691b8371b6dda05 test expr-28.839 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +63876 E-20 x 1703856844bdbe_1000000000000000000001& E-51 convertToDouble +63876E-20 } 0x3cc703856844bdbf test expr-28.840 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -15969 E-20 x -1703856844bdbe_1000000000000000000001& E-53 convertToDouble -15969E-20 } 0xbca703856844bdbf test expr-28.841 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +31938 E-20 x 1703856844bdbe_1000000000000000000001& E-52 convertToDouble +31938E-20 } 0x3cb703856844bdbf test expr-28.842 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -79845 E-21 x -1703856844bdbe_1000000000000000000001& E-54 convertToDouble -79845E-21 } 0xbc9703856844bdbf test expr-28.843 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +89306 E27 x 119cccff237e17_011111111111110& E106 convertToDouble +89306E27 } 0x46919cccff237e17 test expr-28.844 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -25487 E24 x -1496968ba07117_01111111111110& E94 convertToDouble -25487E24 } 0xc5d496968ba07117 test expr-28.845 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +79889 E24 x 10222a1c7e27d3_01111111111110& E96 convertToDouble +79889E24 } 0x45f0222a1c7e27d3 test expr-28.846 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -97379 E26 x -1eba3685911519_011111111111111110& E102 convertToDouble -97379E26 } 0xc65eba3685911519 test expr-28.847 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +81002 E-8 x 1a8af0b45d9531_0111111111111111110& E-11 convertToDouble +81002E-8 } 0x3f4a8af0b45d9531 test expr-28.848 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -43149 E-25 x -146064de6ecbed_011111111111111110& E-68 convertToDouble -43149E-25 } 0xbbb46064de6ecbed test expr-28.849 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +40501 E-8 x 1a8af0b45d9531_0111111111111111110& E-12 convertToDouble +40501E-8 } 0x3f3a8af0b45d9531 test expr-28.850 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -60318 E-10 x -194c988f217e51_011111111111111110& E-18 convertToDouble -60318E-10 } 0xbed94c988f217e51 test expr-28.851 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -648299 E27 x -1ff6af0bf00100_10000000000000000001& E108 convertToDouble -648299E27 } 0xc6bff6af0bf00101 test expr-28.852 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +780649 E24 x 13b4d36f9edd18_10000000000000000001& E99 convertToDouble +780649E24 } 0x4623b4d36f9edd19 test expr-28.853 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +720919 E-14 x 1ef696965cbf04_10000000000000000000000001& E-28 convertToDouble +720919E-14 } 0x3e3ef696965cbf05 test expr-28.854 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -629703 E-11 x -1a69626d2629d0_1000000000000000000000001& E-18 convertToDouble -629703E-11 } 0xbeda69626d2629d1 test expr-28.855 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +557913 E24 x 1c2adb44b394bf_01111111111111111110& E98 convertToDouble +557913E24 } 0x461c2adb44b394bf test expr-28.856 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -847899 E23 x -111f88fb93dce9_011111111111111111110& E96 convertToDouble -847899E23 } 0xc5f11f88fb93dce9 test expr-28.857 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +565445 E27 x 1be0eb55770d4d_0111111111111111110& E108 convertToDouble +565445E27 } 0x46bbe0eb55770d4d test expr-28.858 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -736531 E24 x -1297b853d64ac7_01111111111111111110& E99 convertToDouble -736531E24 } 0xc62297b853d64ac7 test expr-28.859 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +680013 E-19 x 13240293e95c3b_01111111111111111111110& E-44 convertToDouble +680013E-19 } 0x3d33240293e95c3b test expr-28.860 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -529981 E-10 x -1bc948d999ac11_011111111111111111110& E-15 convertToDouble -529981E-10 } 0xbf0bc948d999ac11 test expr-28.861 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +382923 E-23 x 11a8c1c10a1fc5_011111111111111111110& E-58 convertToDouble +382923E-23 } 0x3c51a8c1c10a1fc5 test expr-28.862 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -633614 E-18 x -164b166995a9b7_011111111111111111110& E-41 convertToDouble -633614E-18 } 0xbd664b166995a9b7 test expr-28.863 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +2165479 E27 x 1ab10c016c34b8_100000000000000000000001& E110 convertToDouble +2165479E27 } 0x46dab10c016c34b9 test expr-28.864 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8661916 E27 x -1ab10c016c34b8_100000000000000000000001& E112 convertToDouble -8661916E27 } 0xc6fab10c016c34b9 test expr-28.865 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4330958 E27 x 1ab10c016c34b8_100000000000000000000001& E111 convertToDouble +4330958E27 } 0x46eab10c016c34b9 test expr-28.866 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -9391993 E22 x -12f78bec748c98_1000000000000000000001& E96 convertToDouble -9391993E22 } 0xc5f2f78bec748c99 test expr-28.867 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -5767352 E-14 x -1ef696965cbf04_10000000000000000000000001& E-25 convertToDouble -5767352E-14 } 0xbe6ef696965cbf05 test expr-28.868 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +7209190 E-15 x 1ef696965cbf04_10000000000000000000000001& E-28 convertToDouble +7209190E-15 } 0x3e3ef696965cbf05 test expr-28.869 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -1441838 E-14 x -1ef696965cbf04_10000000000000000000000001& E-27 convertToDouble -1441838E-14 } 0xbe4ef696965cbf05 test expr-28.870 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +8478990 E22 x 111f88fb93dce9_011111111111111111110& E96 convertToDouble +8478990E22 } 0x45f11f88fb93dce9 test expr-28.871 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +1473062 E24 x 1297b853d64ac7_01111111111111111110& E100 convertToDouble +1473062E24 } 0x463297b853d64ac7 test expr-28.872 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +8366487 E-14 x 167567f55b22e1_0111111111111111111111110& E-24 convertToDouble +8366487E-14 } 0x3e767567f55b22e1 test expr-28.873 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8399969 E-25 x -1efd8be1b15b43_011111111111111111111110& E-61 convertToDouble -8399969E-25 } 0xbc2efd8be1b15b43 test expr-28.874 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +9366737 E-12 x 13a4ba87ddc13f_011111111111111111111110& E-17 convertToDouble +9366737E-12 } 0x3ee3a4ba87ddc13f test expr-28.875 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -9406141 E-13 x -1f8fd047c84d49_0111111111111111111111110& E-21 convertToDouble -9406141E-13 } 0xbeaf8fd047c84d49 test expr-28.876 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +65970979 E24 x 1a055dd68f3e3c_1000000000000000000000000001& E105 convertToDouble +65970979E24 } 0x468a055dd68f3e3d test expr-28.877 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -65060671 E26 x -140c61c9916cf4_100000000000000000000000001& E112 convertToDouble -65060671E26 } 0xc6f40c61c9916cf5 test expr-28.878 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +54923002 E27 x 1527d37d8b38ea_10000000000000000000000001& E115 convertToDouble +54923002E27 } 0x472527d37d8b38eb test expr-28.879 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -63846927 E25 x -1f7a9d79dad9b4_10000000000000000000000001& E108 convertToDouble -63846927E25 } 0xc6bf7a9d79dad9b5 test expr-28.880 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +99585767 E-21 x 1c07e928406d2e_100000000000000000000000001& E-44 convertToDouble +99585767E-21 } 0x3d3c07e928406d2f test expr-28.881 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +67488159 E25 x 10a31a03822bc9_011111111111111111111111111110& E109 convertToDouble +67488159E25 } 0x46c0a31a03822bc9 test expr-28.882 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -69005339 E24 x -1b37c234aae77b_011111111111111111111111110& E105 convertToDouble -69005339E24 } 0xc68b37c234aae77b test expr-28.883 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +81956786 E27 x 1f919023fcb6fd_0111111111111111111111111110& E115 convertToDouble +81956786E27 } 0x472f919023fcb6fd test expr-28.884 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -40978393 E27 x -1f919023fcb6fd_0111111111111111111111111110& E114 convertToDouble -40978393E27 } 0xc71f919023fcb6fd test expr-28.885 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +77505754 E-12 x 145152b6f85e09_0111111111111111111111111110& E-14 convertToDouble +77505754E-12 } 0x3f145152b6f85e09 test expr-28.886 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -38752877 E-12 x -145152b6f85e09_0111111111111111111111111110& E-15 convertToDouble -38752877E-12 } 0xbf045152b6f85e09 test expr-28.887 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +82772981 E-15 x 16381dae63505f_0111111111111111111111111111110& E-24 convertToDouble +82772981E-15 } 0x3e76381dae63505f test expr-28.888 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -95593517 E-25 x -160ad862d8537d_0111111111111111111111111110& E-57 convertToDouble -95593517E-25 } 0xbc660ad862d8537d test expr-28.889 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +200036989 E25 x 18a80dedbc575e_10000000000000000000000000001& E110 convertToDouble +200036989E25 } 0x46d8a80dedbc575f test expr-28.890 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -772686455 E27 x -129a0c45ceca7a_1000000000000000000000000000001& E119 convertToDouble -772686455E27 } 0xc7629a0c45ceca7b test expr-28.891 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +859139907 E23 x 10f18c4dd0ffe2_10000000000000000000000000001& E106 convertToDouble +859139907E23 } 0x4690f18c4dd0ffe3 test expr-28.892 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -400073978 E25 x -18a80dedbc575e_10000000000000000000000000001& E111 convertToDouble -400073978E25 } 0xc6e8a80dedbc575f test expr-28.893 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +569014327 E-14 x 17ddbeac19d3b2_100000000000000000000000000001& E-18 convertToDouble +569014327E-14 } 0x3ed7ddbeac19d3b3 test expr-28.894 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -794263862 E-15 x -1aa6acb41dfc52_1000000000000000000000000000001& E-21 convertToDouble -794263862E-15 } 0xbeaaa6acb41dfc53 test expr-28.895 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +397131931 E-15 x 1aa6acb41dfc52_1000000000000000000000000000001& E-22 convertToDouble +397131931E-15 } 0x3e9aa6acb41dfc53 test expr-28.896 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -380398957 E-16 x -146c29d8331024_100000000000000000000000000001& E-25 convertToDouble -380398957E-16 } 0xbe646c29d8331025 test expr-28.897 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +567366773 E27 x 1b5155dd5417f9_0111111111111111111111111111110& E118 convertToDouble +567366773E27 } 0x475b5155dd5417f9 test expr-28.898 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -337440795 E24 x -10a31a03822bc9_011111111111111111111111111110& E108 convertToDouble -337440795E24 } 0xc6b0a31a03822bc9 test expr-28.899 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +134976318 E25 x 10a31a03822bc9_011111111111111111111111111110& E110 convertToDouble +134976318E25 } 0x46d0a31a03822bc9 test expr-28.900 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -269952636 E25 x -10a31a03822bc9_011111111111111111111111111110& E111 convertToDouble -269952636E25 } 0xc6e0a31a03822bc9 test expr-28.901 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +932080597 E-20 x 147f25b4941e5b_0111111111111111111111111111110& E-37 convertToDouble +932080597E-20 } 0x3da47f25b4941e5b test expr-28.902 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -331091924 E-15 x -16381dae63505f_0111111111111111111111111111110& E-22 convertToDouble -331091924E-15 } 0xbe96381dae63505f test expr-28.903 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -413864905 E-16 x -16381dae63505f_0111111111111111111111111111110& E-25 convertToDouble -413864905E-16 } 0xbe66381dae63505f test expr-28.904 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +8539246247 E26 x 148eb7813eaeba_10000000000000000000000000000001& E119 convertToDouble +8539246247E26 } 0x47648eb7813eaebb test expr-28.905 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -5859139791 E26 x -1c35f28719d478_10000000000000000000000000000001& E118 convertToDouble -5859139791E26 } 0xc75c35f28719d479 test expr-28.906 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +6105010149 E24 x 12d000fb2b138a_1000000000000000000000000000000001& E112 convertToDouble +6105010149E24 } 0x46f2d000fb2b138b test expr-28.907 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -3090745820 E27 x -129a0c45ceca7a_1000000000000000000000000000001& E121 convertToDouble -3090745820E27 } 0xc7829a0c45ceca7b test expr-28.908 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +3470877773 E-20 x 1314d381f2c31e_1000000000000000000000000000000001& E-35 convertToDouble +3470877773E-20 } 0x3dc314d381f2c31f test expr-28.909 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -6136309089 E-27 x -1c4c799fab4328_1000000000000000000000000000000001& E-58 convertToDouble -6136309089E-27 } 0xbc5c4c799fab4329 test expr-28.910 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +8917758713 E-19 x 1ea424bda7d7f4_100000000000000000000000000000001& E-31 convertToDouble +8917758713E-19 } 0x3e0ea424bda7d7f5 test expr-28.911 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -6941755546 E-20 x -1314d381f2c31e_1000000000000000000000000000000001& E-34 convertToDouble -6941755546E-20 } 0xbdd314d381f2c31f test expr-28.912 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +9194900535 E25 x 11b56f9c090dfb_011111111111111111111111111111111110& E116 convertToDouble +9194900535E25 } 0x4731b56f9c090dfb test expr-28.913 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -1838980107 E26 x -11b56f9c090dfb_011111111111111111111111111111111110& E117 convertToDouble -1838980107E26 } 0xc741b56f9c090dfb test expr-28.914 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +7355920428 E26 x 11b56f9c090dfb_011111111111111111111111111111111110& E119 convertToDouble +7355920428E26 } 0x4761b56f9c090dfb test expr-28.915 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -3677960214 E26 x -11b56f9c090dfb_011111111111111111111111111111111110& E118 convertToDouble -3677960214E26 } 0xc751b56f9c090dfb test expr-28.916 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +8473634343 E-17 x 16bf0984b232b7_0111111111111111111111111111111110& E-24 convertToDouble +8473634343E-17 } 0x3e76bf0984b232b7 test expr-28.917 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8870766274 E-16 x -1dc3ee22137269_0111111111111111111111111111111110& E-21 convertToDouble -8870766274E-16 } 0xbeadc3ee22137269 test expr-28.918 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +4435383137 E-16 x 1dc3ee22137269_0111111111111111111111111111111110& E-22 convertToDouble +4435383137E-16 } 0x3e9dc3ee22137269 test expr-28.919 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -9598990129 E-15 x -14216b286031e7_01111111111111111111111111111111110& E-17 convertToDouble -9598990129E-15 } 0xbee4216b286031e7 test expr-28.920 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +71563496764 E26 x 15890d1ef6a0da_10000000000000000000000000000000000001& E122 convertToDouble +71563496764E26 } 0x4795890d1ef6a0db test expr-28.921 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -89454370955 E25 x -15890d1ef6a0da_10000000000000000000000000000000000001& E119 convertToDouble -89454370955E25 } 0xc765890d1ef6a0db test expr-28.922 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +17890874191 E26 x 15890d1ef6a0da_10000000000000000000000000000000000001& E120 convertToDouble +17890874191E26 } 0x4775890d1ef6a0db test expr-28.923 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -35781748382 E26 x -15890d1ef6a0da_10000000000000000000000000000000000001& E121 convertToDouble -35781748382E26 } 0xc785890d1ef6a0db test expr-28.924 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +57973447842 E-19 x 18e63f7cf5313c_1000000000000000000000000000000000000001& E-28 convertToDouble +57973447842E-19 } 0x3e38e63f7cf5313d test expr-28.925 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -28986723921 E-19 x -18e63f7cf5313c_1000000000000000000000000000000000000001& E-29 convertToDouble -28986723921E-19 } 0xbe28e63f7cf5313d test expr-28.926 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +76822711313 E-19 x 107f5f8b3bf818_100000000000000000000000000000000001& E-27 convertToDouble +76822711313E-19 } 0x3e407f5f8b3bf819 test expr-28.927 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -97699466874 E-20 x -10c8de34de806e_10000000000000000000000000000000001& E-30 convertToDouble -97699466874E-20 } 0xbe10c8de34de806f test expr-28.928 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +67748656762 E27 x 197bf5559b31fd_01111111111111111111111111111111111110& E125 convertToDouble +67748656762E27 } 0x47c97bf5559b31fd test expr-28.929 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -19394840991 E24 x -1de1ea791a6e7d_0111111111111111111111111111111111110& E113 convertToDouble -19394840991E24 } 0xc70de1ea791a6e7d test expr-28.930 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +38789681982 E24 x 1de1ea791a6e7d_0111111111111111111111111111111111110& E114 convertToDouble +38789681982E24 } 0x471de1ea791a6e7d test expr-28.931 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -33874328381 E27 x -197bf5559b31fd_01111111111111111111111111111111111110& E124 convertToDouble -33874328381E27 } 0xc7b97bf5559b31fd test expr-28.932 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +54323763886 E-27 x 1f50c5c63e5441_0111111111111111111111111111111111110& E-55 convertToDouble +54323763886E-27 } 0x3c8f50c5c63e5441 test expr-28.933 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -58987193887 E-20 x -14449185a4c829_011111111111111111111111111111111111110& E-31 convertToDouble -58987193887E-20 } 0xbe04449185a4c829 test expr-28.934 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +27161881943 E-27 x 1f50c5c63e5441_0111111111111111111111111111111111110& E-56 convertToDouble +27161881943E-27 } 0x3c7f50c5c63e5441 test expr-28.935 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -93042648033 E-19 x -13fb12dc023fd3_0111111111111111111111111111111111110& E-27 convertToDouble -93042648033E-19 } 0xbe43fb12dc023fd3 test expr-28.936 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +520831059055 E27 x 187d469cb69dd0_10000000000000000000000000000000000000001& E128 convertToDouble +520831059055E27 } 0x47f87d469cb69dd1 test expr-28.937 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -768124264394 E25 x -171d6a019edae8_1000000000000000000000000000000000000001& E122 convertToDouble -768124264394E25 } 0xc7971d6a019edae9 test expr-28.938 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +384062132197 E25 x 171d6a019edae8_1000000000000000000000000000000000000001& E121 convertToDouble +384062132197E25 } 0x47871d6a019edae9 test expr-28.939 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +765337749889 E-25 x 158ad6f5d0a854_100000000000000000000000000000000000000001& E-44 convertToDouble +765337749889E-25 } 0x3d358ad6f5d0a855 test expr-28.940 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +794368912771 E25 x 17e79872f2f7ef_01111111111111111111111111111111111111110& E122 convertToDouble +794368912771E25 } 0x4797e79872f2f7ef test expr-28.941 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -994162090146 E23 x -132598f85e658b_011111111111111111111111111111111111110& E116 convertToDouble -994162090146E23 } 0xc7332598f85e658b test expr-28.942 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +781652779431 E26 x 1d670adf52038f_01111111111111111111111111111111111110& E125 convertToDouble +781652779431E26 } 0x47cd670adf52038f test expr-28.943 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +910077190046 E-26 x 147e3ce1871d79_01111111111111111111111111111111111111110& E-47 convertToDouble +910077190046E-26 } 0x3d047e3ce1871d79 test expr-28.944 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -455038595023 E-26 x -147e3ce1871d79_01111111111111111111111111111111111111110& E-48 convertToDouble -455038595023E-26 } 0xbcf47e3ce1871d79 test expr-28.945 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +471897551096 E-20 x 14449185a4c829_011111111111111111111111111111111111110& E-28 convertToDouble +471897551096E-20 } 0x3e34449185a4c829 test expr-28.946 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -906698409911 E-21 x -1f27674f7d5745_0111111111111111111111111111111111111110& E-31 convertToDouble -906698409911E-21 } 0xbe0f27674f7d5745 test expr-28.947 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +8854128003935 E25 x 10a71b8948faac_100000000000000000000000000000000000000001& E126 convertToDouble +8854128003935E25 } 0x47d0a71b8948faad test expr-28.948 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8146122716299 E27 x -17f0762ac05654_1000000000000000000000000000000000000000001& E132 convertToDouble -8146122716299E27 } 0xc837f0762ac05655 test expr-28.949 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +7083302403148 E26 x 10a71b8948faac_100000000000000000000000000000000000000001& E129 convertToDouble +7083302403148E26 } 0x4800a71b8948faad test expr-28.950 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -3541651201574 E26 x -10a71b8948faac_100000000000000000000000000000000000000001& E128 convertToDouble -3541651201574E26 } 0xc7f0a71b8948faad test expr-28.951 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +8394920649291 E-25 x 1d8978e8c1cc78_100000000000000000000000000000000000000000001& E-41 convertToDouble +8394920649291E-25 } 0x3d6d8978e8c1cc79 test expr-28.952 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -7657975756753 E-22 x -1a5006d695fef0_1000000000000000000000000000000000000000000001& E-31 convertToDouble -7657975756753E-22 } 0xbe0a5006d695fef1 test expr-28.953 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +5473834002228 E-20 x 1d632e1f745624_100000000000000000000000000000000000000000001& E-25 convertToDouble +5473834002228E-20 } 0x3e6d632e1f745625 test expr-28.954 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -6842292502785 E-21 x -1d632e1f745624_100000000000000000000000000000000000000000001& E-28 convertToDouble -6842292502785E-21 } 0xbe3d632e1f745625 test expr-28.955 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -2109568884597 E25 x -1fbdc386609b13_011111111111111111111111111111111111111110& E123 convertToDouble -2109568884597E25 } 0xc7afbdc386609b13 test expr-28.956 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +8438275538388 E25 x 1fbdc386609b13_011111111111111111111111111111111111111110& E125 convertToDouble +8438275538388E25 } 0x47cfbdc386609b13 test expr-28.957 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -4219137769194 E25 x -1fbdc386609b13_011111111111111111111111111111111111111110& E124 convertToDouble -4219137769194E25 } 0xc7bfbdc386609b13 test expr-28.958 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +3200141789841 E-25 x 1684dcea3829f7_0111111111111111111111111111111111111111110& E-42 convertToDouble +3200141789841E-25 } 0x3d5684dcea3829f7 test expr-28.959 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8655689322607 E-22 x -1dbd9ff5dc8991_011111111111111111111111111111111111111110& E-31 convertToDouble -8655689322607E-22 } 0xbe0dbd9ff5dc8991 test expr-28.960 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +6400283579682 E-25 x 1684dcea3829f7_0111111111111111111111111111111111111111110& E-41 convertToDouble +6400283579682E-25 } 0x3d6684dcea3829f7 test expr-28.961 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -8837719634493 E-21 x -12fa9676d2585b_011111111111111111111111111111111111111110& E-27 convertToDouble -8837719634493E-21 } 0xbe42fa9676d2585b test expr-28.962 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +19428217075297 E24 x 1d3b7a1d154aba_10000000000000000000000000000000000000000000001& E123 convertToDouble +19428217075297E24 } 0x47ad3b7a1d154abb test expr-28.963 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -38856434150594 E24 x -1d3b7a1d154aba_10000000000000000000000000000000000000000000001& E124 convertToDouble -38856434150594E24 } 0xc7bd3b7a1d154abb test expr-28.964 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +77712868301188 E24 x 1d3b7a1d154aba_10000000000000000000000000000000000000000000001& E125 convertToDouble +77712868301188E24 } 0x47cd3b7a1d154abb test expr-28.965 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -77192037242133 E27 x -1c5b1ab32d5dbe_1000000000000000000000000000000000000000000000001& E135 convertToDouble -77192037242133E27 } 0xc86c5b1ab32d5dbf test expr-28.966 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +76579757567530 E-23 x 1a5006d695fef0_1000000000000000000000000000000000000000000001& E-31 convertToDouble +76579757567530E-23 } 0x3e0a5006d695fef1 test expr-28.967 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +15315951513506 E-22 x 1a5006d695fef0_1000000000000000000000000000000000000000000001& E-30 convertToDouble +15315951513506E-22 } 0x3e1a5006d695fef1 test expr-28.968 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -38289878783765 E-23 x -1a5006d695fef0_1000000000000000000000000000000000000000000001& E-32 convertToDouble -38289878783765E-23 } 0xbdfa5006d695fef1 test expr-28.969 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +49378033925202 E25 x 1737aa2567167b_0111111111111111111111111111111111111111111110& E128 convertToDouble +49378033925202E25 } 0x47f737aa2567167b test expr-28.970 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -50940527102367 E24 x -132964f2944b05_0111111111111111111111111111111111111111111111110& E125 convertToDouble -50940527102367E24 } 0xc7c32964f2944b05 test expr-28.971 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +98756067850404 E25 x 1737aa2567167b_0111111111111111111111111111111111111111111110& E129 convertToDouble +98756067850404E25 } 0x480737aa2567167b test expr-28.972 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -99589397544892 E26 x -1d4446075c4933_0111111111111111111111111111111111111111111110& E132 convertToDouble -99589397544892E26 } 0xc83d4446075c4933 test expr-28.973 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -56908598265713 E-25 x -190756ab1ed6b3_011111111111111111111111111111111111111111111110& E-38 convertToDouble -56908598265713E-25 } 0xbd990756ab1ed6b3 test expr-28.974 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +97470695699657 E-22 x 14ee821710e655_01111111111111111111111111111111111111111111110& E-27 convertToDouble +97470695699657E-22 } 0x3e44ee821710e655 test expr-28.975 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -35851901247343 E-25 x -1f8921657e1581_0111111111111111111111111111111111111111111110& E-39 convertToDouble -35851901247343E-25 } 0xbd8f8921657e1581 test expr-28.976 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +154384074484266 E27 x 1c5b1ab32d5dbe_1000000000000000000000000000000000000000000000001& E136 convertToDouble +154384074484266E27 } 0x487c5b1ab32d5dbf test expr-28.977 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -308768148968532 E27 x -1c5b1ab32d5dbe_1000000000000000000000000000000000000000000000001& E137 convertToDouble -308768148968532E27 } 0xc88c5b1ab32d5dbf test expr-28.978 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +910990389005985 E23 x 112242592ae54a_100000000000000000000000000000000000000000000001& E126 convertToDouble +910990389005985E23 } 0x47d12242592ae54b test expr-28.979 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +271742424169201 E-27 x 131f46bcf7b452_10000000000000000000000000000000000000000000000001& E-42 convertToDouble +271742424169201E-27 } 0x3d531f46bcf7b453 test expr-28.980 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -543484848338402 E-27 x -131f46bcf7b452_10000000000000000000000000000000000000000000000001& E-41 convertToDouble -543484848338402E-27 } 0xbd631f46bcf7b453 test expr-28.981 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +162192083357563 E-26 x 1c887b68658760_1000000000000000000000000000000000000000000000001& E-40 convertToDouble +162192083357563E-26 } 0x3d7c887b68658761 test expr-28.982 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -869254552770081 E-23 x -12aac70665485e_1000000000000000000000000000000000000000000000000001& E-27 convertToDouble -869254552770081E-23 } 0xbe42aac70665485f test expr-28.983 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +664831007626046 E24 x 1f429cb67eb075_011111111111111111111111111111111111111111111111110& E128 convertToDouble +664831007626046E24 } 0x47ff429cb67eb075 test expr-28.984 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -332415503813023 E24 x -1f429cb67eb075_011111111111111111111111111111111111111111111111110& E127 convertToDouble -332415503813023E24 } 0xc7ef429cb67eb075 test expr-28.985 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +943701829041427 E24 x 162fb2e38ee461_01111111111111111111111111111111111111111111111110& E129 convertToDouble +943701829041427E24 } 0x48062fb2e38ee461 test expr-28.986 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -101881054204734 E24 x -132964f2944b05_0111111111111111111111111111111111111111111111110& E126 convertToDouble -101881054204734E24 } 0xc7d32964f2944b05 test expr-28.987 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +828027839666967 E-27 x 1d2236349da3cd_011111111111111111111111111111111111111111111111110& E-41 convertToDouble +828027839666967E-27 } 0x3d6d2236349da3cd test expr-28.988 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -280276135608777 E-27 x -13b901892fd0bf_0111111111111111111111111111111111111111111111110& E-42 convertToDouble -280276135608777E-27 } 0xbd53b901892fd0bf test expr-28.989 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +212839188833879 E-21 x 1c91194dc2d40b_0111111111111111111111111111111111111111111111110& E-23 convertToDouble +212839188833879E-21 } 0x3e8c91194dc2d40b test expr-28.990 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -113817196531426 E-25 x -190756ab1ed6b3_011111111111111111111111111111111111111111111110& E-37 convertToDouble -113817196531426E-25 } 0xbda90756ab1ed6b3 test expr-28.991 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +9711553197796883 E27 x 1bdeec25c0f03e_10000000000000000000000000000000000000000000000000001& E142 convertToDouble +9711553197796883E27 } 0x48dbdeec25c0f03f test expr-28.992 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -2739849386524269 E26 x -19295ade212370_1000000000000000000000000000000000000000000000000001& E137 convertToDouble -2739849386524269E26 } 0xc889295ade212371 test expr-28.993 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +5479698773048538 E26 x 19295ade212370_1000000000000000000000000000000000000000000000000001& E138 convertToDouble +5479698773048538E26 } 0x4899295ade212371 test expr-28.994 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +6124568318523113 E-25 x 150b3a2e0aff14_1000000000000000000000000000000000000000000000000000001& E-31 convertToDouble +6124568318523113E-25 } 0x3e050b3a2e0aff15 test expr-28.995 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -1139777988171071 E-24 x -1394cbee428ea4_10000000000000000000000000000000000000000000000000001& E-30 convertToDouble -1139777988171071E-24 } 0xbe1394cbee428ea5 test expr-28.996 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +6322612303128019 E-27 x 1bcea0ec21e250_1000000000000000000000000000000000000000000000000000001& E-38 convertToDouble +6322612303128019E-27 } 0x3d9bcea0ec21e251 test expr-28.997 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -2955864564844617 E-25 x -1450030e26c6dc_10000000000000000000000000000000000000000000000000001& E-32 convertToDouble -2955864564844617E-25 } 0xbdf450030e26c6dd test expr-28.998 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -9994029144998961 E25 x -125b2b7fed4a61_0111111111111111111111111111111111111111111111111110& E136 convertToDouble -9994029144998961E25 } 0xc8725b2b7fed4a61 test expr-28.999 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -2971238324022087 E27 x -110dd7a301db67_0111111111111111111111111111111111111111111111111110& E141 convertToDouble -2971238324022087E27 } 0xc8c10dd7a301db67 test expr-28.1000 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -1656055679333934 E-27 x -1d2236349da3cd_011111111111111111111111111111111111111111111111110& E-40 convertToDouble -1656055679333934E-27 } 0xbd7d2236349da3cd test expr-28.1001 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -1445488709150234 E-26 x -1fc960c59526c7_0111111111111111111111111111111111111111111111110& E-37 convertToDouble -1445488709150234E-26 } 0xbdafc960c59526c7 test expr-28.1002 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +55824717499885172 E27 x 1406b0cd17fd56_1000000000000000000000000000000000000000000000000000000001& E145 convertToDouble +55824717499885172E27 } 0x490406b0cd17fd57 test expr-28.1003 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -69780896874856465 E26 x -1406b0cd17fd56_1000000000000000000000000000000000000000000000000000000001& E142 convertToDouble -69780896874856465E26 } 0xc8d406b0cd17fd57 test expr-28.1004 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +84161538867545199 E25 x 13529217bdce6c_10000000000000000000000000000000000000000000000000000000001& E139 convertToDouble +84161538867545199E25 } 0x48a3529217bdce6d test expr-28.1005 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -27912358749942586 E27 x -1406b0cd17fd56_1000000000000000000000000000000000000000000000000000000001& E144 convertToDouble -27912358749942586E27 } 0xc8f406b0cd17fd57 test expr-28.1006 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +24711112462926331 E-25 x 153a07f6040d22_100000000000000000000000000000000000000000000000000000001& E-29 convertToDouble +24711112462926331E-25 } 0x3e253a07f6040d23 test expr-28.1007 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -12645224606256038 E-27 x -1bcea0ec21e250_1000000000000000000000000000000000000000000000000000001& E-37 convertToDouble -12645224606256038E-27 } 0xbdabcea0ec21e251 test expr-28.1008 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -12249136637046226 E-25 x -150b3a2e0aff14_1000000000000000000000000000000000000000000000000000001& E-30 convertToDouble -12249136637046226E-25 } 0xbe150b3a2e0aff15 test expr-28.1009 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +74874448287465757 E27 x 1adc21d1d50b09_01111111111111111111111111111111111111111111111111111110& E145 convertToDouble +74874448287465757E27 } 0x490adc21d1d50b09 test expr-28.1010 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -35642836832753303 E24 x -1a2fac2b421f53_0111111111111111111111111111111111111111111111111111110& E134 convertToDouble -35642836832753303E24 } 0xc85a2fac2b421f53 test expr-28.1011 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -71285673665506606 E24 x -1a2fac2b421f53_0111111111111111111111111111111111111111111111111111110& E135 convertToDouble -71285673665506606E24 } 0xc86a2fac2b421f53 test expr-28.1012 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +43723334984997307 E-26 x 1e0be3f392c549_01111111111111111111111111111111111111111111111111111110& E-32 convertToDouble +43723334984997307E-26 } 0x3dfe0be3f392c549 test expr-28.1013 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN +10182419849537963 E-24 x 15ddd831ebbe53_011111111111111111111111111111111111111111111111111110& E-27 convertToDouble +10182419849537963E-24 } 0x3e45ddd831ebbe53 test expr-28.1014 {input floating-point conversion} {ieeeFloatingPoint} { # Ad2b dieee UN -93501703572661982 E-26 x -10103f97ea6e13_0111111111111111111111111111111111111111111111111110& E-30 convertToDouble -93501703572661982E-26 } 0xbe10103f97ea6e13 test expr-29.1 {smallest representible number} {ieeeFloatingPoint} { list [catch {convertToDouble 4.9406564584124654e-324} result] \ $result \ [catch {convertToDouble 2.4703282292062327e-324} result] \ $result \ [catch {convertToDouble 2.47032822920623e-324} result] \ $result } {0 0x0000000000000001 0 0x0000000000000001 0 0x0000000000000000} test expr-29.2 {smallest representible number} {ieeeFloatingPoint} { list [catch {convertToDouble -4.9406564584124654e-324} result] \ $result \ [catch {convertToDouble -2.4703282292062327e-324} result] \ $result \ [catch {convertToDouble -2.47032822920623e-324} result] \ $result } {0 0x8000000000000001 0 0x8000000000000001 0 0x8000000000000000} test expr-29.3 {silent underflow on input conversion} {ieeeFloatingPoint} { set v ? list [scan 2.47032822920623e-324 %g v] $v } {1 0.0} test expr-29.4 {silent underflow on input conversion} {ieeeFloatingPoint} { set v ? list [scan -2.47032822920623e-324 %g v] $v } {1 -0.0} test expr-30.1 {largest representible number} {ieeeFloatingPoint} { list [catch {convertToDouble 1.7976931348623155e+308} result] \ $result \ [catch {convertToDouble 1.7976931348623157e+308} result] \ $result \ [catch {convertToDouble 1.7976931348623159e+308} result] \ $result } {0 0x7feffffffffffffe 0 0x7fefffffffffffff 0 0x7ff0000000000000} test expr-30.2 {largest representible number} {ieeeFloatingPoint} { list [catch {convertToDouble -1.7976931348623155e+308} result] \ $result \ [catch {convertToDouble -1.7976931348623157e+308} result] \ $result \ [catch {convertToDouble -1.7976931348623159e+308} result] \ $result } {0 0xffeffffffffffffe 0 0xffefffffffffffff 0 0xfff0000000000000} test expr-30.3 {silent overflow on input conversion} {ieeeFloatingPoint} { set v ? list [scan 1.7976931348623159e+308 %f v] $v } {1 Inf} test expr-30.4 {silent overflow on input conversion} {ieeeFloatingPoint} { set v ? list [scan -1.7976931348623159e+308 %f v] $v } {1 -Inf} # bool() tests (TIP #182) set i 0 foreach s {yes true on} { test expr-31.$i.0 {boolean conversion} {expr bool($s)} 1 test expr-31.$i.1 {boolean conversion} {expr bool(!$s)} 0 test expr-31.$i.2 {boolean conversion} {expr bool("$s")} 1 test expr-31.$i.3 {boolean conversion} {expr bool(!"$s")} 0 set j 1 while {$j < [string length $s]-1} { test expr-31.$i.4.$j {boolean conversion} { expr bool([string range $s 0 $j]) } 1 test expr-31.$i.5.$j {boolean conversion} { expr bool("[string range $s 0 $j]") } 1 incr j } incr i } test expr-31.0.4.0 {boolean conversion} {expr bool(y)} 1 test expr-31.0.5.0 {boolean conversion} {expr bool("y")} 1 test expr-31.1.4.0 {boolean conversion} {expr bool(t)} 1 test expr-31.1.5.0 {boolean conversion} {expr bool("t")} 1 test expr-31.2.4.0 {boolean conversion} -body { expr bool(o) } -returnCodes error -match glob -result * test expr-31.2.5.0 {boolean conversion} -body { expr bool("o") } -returnCodes error -match glob -result * foreach s {no false off} { test expr-31.$i.0 {boolean conversion} {expr bool($s)} 0 test expr-31.$i.1 {boolean conversion} {expr bool(!$s)} 1 test expr-31.$i.2 {boolean conversion} {expr bool("$s")} 0 test expr-31.$i.3 {boolean conversion} {expr bool(!"$s")} 1 set j 1 while {$j < [string length $s]-1} { test expr-31.$i.4.$j {boolean conversion} { expr bool([string range $s 0 $j]) } 0 test expr-31.$i.5.$j {boolean conversion} { expr bool("[string range $s 0 $j]") } 0 incr j } incr i } test expr-31.3.4.0 {boolean conversion} {expr bool(n)} 0 test expr-31.3.5.0 {boolean conversion} {expr bool("n")} 0 test expr-31.4.4.0 {boolean conversion} {expr bool(f)} 0 test expr-31.4.5.0 {boolean conversion} {expr bool("f")} 0 test expr-31.6 {boolean conversion} {expr bool(-1 + 1)} 0 test expr-31.7 {boolean conversion} {expr bool(0 + 1)} 1 test expr-31.8 {boolean conversion} {expr bool(0.0)} 0 test expr-31.9 {boolean conversion} {expr bool(0x0)} 0 test expr-31.10 {boolean conversion} {expr bool(wide(0))} 0 test expr-31.11 {boolean conversion} {expr bool(5.0)} 1 test expr-31.12 {boolean conversion} {expr bool(5)} 1 test expr-31.13 {boolean conversion} {expr bool(0x5)} 1 test expr-31.14 {boolean conversion} {expr bool(wide(5))} 1 test expr-31.15 {boolean conversion} -body { expr bool("fred") } -returnCodes error -match glob -result * test expr-32.1 {expr mod basics} { set mod_nums [list \ {-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \ {-3 -1} {-3 -2} {-3 -3} {-3 -4} {-3 -5} \ {-2 1} {-2 2} {-2 3} {-2 4} {-2 5} \ {-2 -1} {-2 -2} {-2 -3} {-2 -4} {-2 -5} \ {-1 1} {-1 2} {-1 3} {-1 4} {-1 5} \ {-1 -1} {-1 -2} {-1 -3} {-1 -4} {-1 -5} \ {0 -100} {0 -1} {0 1} {0 100} \ {1 1} {1 2} {1 3} {1 4} {1 5} \ {1 -1} {1 -2} {1 -3} {1 -4} {1 -5} \ {2 1} {2 2} {2 3} {2 4} {2 5} \ {2 -1} {2 -2} {2 -3} {2 -4} {2 -5} \ {3 1} {3 2} {3 3} {3 4} {3 5} \ {3 -1} {3 -2} {3 -3} {3 -4} {3 -5} \ ] set results [list] foreach pair $mod_nums { set dividend [lindex $pair 0] set divisor [lindex $pair 1] lappend results [expr {$dividend % $divisor}] } set results } [list \ 0 1 0 1 2 \ 0 -1 0 -3 -3 \ 0 0 1 2 3 \ 0 0 -2 -2 -2 \ 0 1 2 3 4 \ 0 -1 -1 -1 -1 \ 0 0 0 0 \ 0 1 1 1 1 \ 0 -1 -2 -3 -4 \ 0 0 2 2 2 \ 0 0 -1 -2 -3 \ 0 1 0 3 3 \ 0 -1 0 -1 -2 \ ] test expr-32.2 {expr div basics} { set mod_nums [list \ {-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \ {-3 -1} {-3 -2} {-3 -3} {-3 -4} {-3 -5} \ {-2 1} {-2 2} {-2 3} {-2 4} {-2 5} \ {-2 -1} {-2 -2} {-2 -3} {-2 -4} {-2 -5} \ {-1 1} {-1 2} {-1 3} {-1 4} {-1 5} \ {-1 -1} {-1 -2} {-1 -3} {-1 -4} {-1 -5} \ {0 -100} {0 -1} {0 1} {0 100} \ {1 1} {1 2} {1 3} {1 4} {1 5} \ {1 -1} {1 -2} {1 -3} {1 -4} {1 -5} \ {2 1} {2 2} {2 3} {2 4} {2 5} \ {2 -1} {2 -2} {2 -3} {2 -4} {2 -5} \ {3 1} {3 2} {3 3} {3 4} {3 5} \ {3 -1} {3 -2} {3 -3} {3 -4} {3 -5} \ ] set results [list] foreach pair $mod_nums { set dividend [lindex $pair 0] set divisor [lindex $pair 1] lappend results [expr {$dividend / $divisor}] } set results } [list \ -3 -2 -1 -1 -1 \ 3 1 1 0 0 \ -2 -1 -1 -1 -1 \ 2 1 0 0 0 \ -1 -1 -1 -1 -1 \ 1 0 0 0 0 \ 0 0 0 0 \ 1 0 0 0 0 \ -1 -1 -1 -1 -1 \ 2 1 0 0 0 \ -2 -1 -1 -1 -1 \ 3 1 1 0 0 \ -3 -2 -1 -1 -1 \ ] test expr-33.1 {parse largest long value} {longIs32bit} { set max_long_str 2147483647 set max_long_hex "0x7FFFFFFF " # Convert to integer (long, not wide) internal rep set max_long 2147483647 string is integer $max_long list \ [expr {" $max_long_str "}] \ [expr {$max_long_str + 0}] \ [expr {$max_long + 0}] \ [expr {2147483647 + 0}] \ [expr {$max_long == $max_long_hex}] \ [expr {(2147483647 + 1) < 0}] \ } {2147483647 2147483647 2147483647 2147483647 1 1} test expr-33.2 {parse smallest long value} {longIs32bit} { set min_long_str -2147483648 set min_long_hex "-0x80000000 " set min_long -2147483648 # This will convert to integer (not wide) internal rep string is integer $min_long # Note: If the final expression returns 0 then the # expression literal is being promoted to a wide type # when it should be parsed as a long type. list \ [expr {" $min_long_str "}] \ [expr {$min_long_str + 0}] \ [expr {$min_long + 0}] \ [expr {-2147483648 + 0}] \ [expr {$min_long == $min_long_hex}] \ [expr {(-2147483648 - 1) == 0x7FFFFFFF}] \ } {-2147483648 -2147483648 -2147483648 -2147483648 1 1} test expr-33.3 {parse largest wide value} {wideIs64bit} { set max_wide_str 9223372036854775807 set max_wide_hex "0x7FFFFFFFFFFFFFFF " # Convert to wide integer set max_wide 9223372036854775807 string is integer $max_wide list \ [expr {" $max_wide_str "}] \ [expr {$max_wide_str + 0}] \ [expr {$max_wide + 0}] \ [expr {9223372036854775807 + 0}] \ [expr {$max_wide == $max_wide_hex}] \ [expr {(9223372036854775807 + 1) < 0}] \ } {9223372036854775807 9223372036854775807 9223372036854775807 9223372036854775807 1 1} test expr-33.4 {parse smallest wide value} {wideIs64bit} { set min_wide_str -9223372036854775808 set min_wide_hex "-0x8000000000000000 " set min_wide -9223372036854775808 # Convert to wide integer string is integer $min_wide # Note: If the final expression returns 0 then the # wide integer is not being parsed correctly with # the leading - sign. list \ [expr {" $min_wide_str "}] \ [expr {$min_wide_str + 0}] \ [expr {$min_wide + 0}] \ [expr {-9223372036854775808 + 0}] \ [expr {$min_wide == $min_wide_hex}] \ [expr {(-9223372036854775808 - 1) == 0x7FFFFFFFFFFFFFFF}] \ } {-9223372036854775808 -9223372036854775808 -9223372036854775808 -9223372036854775808 1 1} set min -2147483648 set max 2147483647 test expr-34.1 {expr edge cases} {longIs32bit} { expr {$min / $min} } {1} test expr-34.2 {expr edge cases} {longIs32bit} { expr {$min % $min} } {0} test expr-34.3 {expr edge cases} {longIs32bit} { expr {$min / ($min + 1)} } {1} test expr-34.4 {expr edge cases} {longIs32bit} { expr {$min % ($min + 1)} } {-1} test expr-34.5 {expr edge cases} {longIs32bit} { expr {$min / ($min + 2)} } {1} test expr-34.6 {expr edge cases} {longIs32bit} { expr {$min % ($min + 2)} } {-2} test expr-34.7 {expr edge cases} {longIs32bit} { expr {$min / ($min + 3)} } {1} test expr-34.8 {expr edge cases} {longIs32bit} { expr {$min % ($min + 3)} } {-3} test expr-34.9 {expr edge cases} {longIs32bit} { expr {$min / -3} } {715827882} test expr-34.10 {expr edge cases} {longIs32bit} { expr {$min % -3} } {-2} test expr-34.11 {expr edge cases} {longIs32bit} { expr {$min / -2} } {1073741824} test expr-34.12 {expr edge cases} {longIs32bit} { expr {$min % -2} } {0} test expr-34.13 {expr edge cases} {longIs32bit} { expr {$min / -1} } {-2147483648} test expr-34.14 {expr edge cases} {longIs32bit} { expr {$min % -1} } {0} test expr-34.15 {expr edge cases} {longIs32bit} { expr {$min * -1} } $min test expr-34.16 {expr edge cases} {longIs32bit} { expr {-$min} } $min test expr-34.17 {expr edge cases} {longIs32bit} { expr {$min / 1} } $min test expr-34.18 {expr edge cases} {longIs32bit} { expr {$min % 1} } {0} test expr-34.19 {expr edge cases} {longIs32bit} { expr {$min / 2} } {-1073741824} test expr-34.20 {expr edge cases} {longIs32bit} { expr {$min % 2} } {0} test expr-34.21 {expr edge cases} {longIs32bit} { expr {$min / 3} } {-715827883} test expr-34.22 {expr edge cases} {longIs32bit} { expr {$min % 3} } {1} test expr-34.23 {expr edge cases} {longIs32bit} { expr {$min / ($max - 3)} } {-2} test expr-34.24 {expr edge cases} {longIs32bit} { expr {$min % ($max - 3)} } {2147483640} test expr-34.25 {expr edge cases} {longIs32bit} { expr {$min / ($max - 2)} } {-2} test expr-34.26 {expr edge cases} {longIs32bit} { expr {$min % ($max - 2)} } {2147483642} test expr-34.27 {expr edge cases} {longIs32bit} { expr {$min / ($max - 1)} } {-2} test expr-34.28 {expr edge cases} {longIs32bit} { expr {$min % ($max - 1)} } {2147483644} test expr-34.29 {expr edge cases} {longIs32bit} { expr {$min / $max} } {-2} test expr-34.30 {expr edge cases} {longIs32bit} { expr {$min % $max} } {2147483646} test expr-34.31 {expr edge cases} {longIs32bit} { expr {$max / $max} } {1} test expr-34.32 {expr edge cases} {longIs32bit} { expr {$max % $max} } {0} test expr-34.33 {expr edge cases} {longIs32bit} { expr {$max / ($max - 1)} } {1} test expr-34.34 {expr edge cases} {longIs32bit} { expr {$max % ($max - 1)} } {1} test expr-34.35 {expr edge cases} {longIs32bit} { expr {$max / ($max - 2)} } {1} test expr-34.36 {expr edge cases} {longIs32bit} { expr {$max % ($max - 2)} } {2} test expr-34.37 {expr edge cases} {longIs32bit} { expr {$max / ($max - 3)} } {1} test expr-34.38 {expr edge cases} {longIs32bit} { expr {$max % ($max - 3)} } {3} test expr-34.39 {expr edge cases} {longIs32bit} { expr {$max / 3} } {715827882} test expr-34.40 {expr edge cases} {longIs32bit} { expr {$max % 3} } {1} test expr-34.41 {expr edge cases} {longIs32bit} { expr {$max / 2} } {1073741823} test expr-34.42 {expr edge cases} {longIs32bit} { expr {$max % 2} } {1} test expr-34.43 {expr edge cases} {longIs32bit} { expr {$max / 1} } $max test expr-34.44 {expr edge cases} {longIs32bit} { expr {$max % 1} } {0} test expr-34.45 {expr edge cases} {longIs32bit} { expr {$max / -1} } "-$max" test expr-34.46 {expr edge cases} {longIs32bit} { expr {$max % -1} } {0} test expr-34.47 {expr edge cases} {longIs32bit} { expr {$max / -2} } {-1073741824} test expr-34.48 {expr edge cases} {longIs32bit} { expr {$max % -2} } {-1} test expr-34.49 {expr edge cases} {longIs32bit} { expr {$max / -3} } {-715827883} test expr-34.50 {expr edge cases} {longIs32bit} { expr {$max % -3} } {-2} test expr-34.51 {expr edge cases} {longIs32bit} { expr {$max / ($min + 3)} } {-2} test expr-34.52 {expr edge cases} {longIs32bit} { expr {$max % ($min + 3)} } {-2147483643} test expr-34.53 {expr edge cases} {longIs32bit} { expr {$max / ($min + 2)} } {-2} test expr-34.54 {expr edge cases} {longIs32bit} { expr {$max % ($min + 2)} } {-2147483645} test expr-34.55 {expr edge cases} {longIs32bit} { expr {$max / ($min + 1)} } {-1} test expr-34.56 {expr edge cases} {longIs32bit} { expr {$max % ($min + 1)} } {0} test expr-34.57 {expr edge cases} {longIs32bit} { expr {$max / $min} } {-1} test expr-34.58 {expr edge cases} {longIs32bit} { expr {$max % $min} } {-1} test expr-34.59 {expr edge cases} {longIs32bit} { expr {($min + 1) / ($max - 1)} } {-2} test expr-34.60 {expr edge cases} {longIs32bit} { expr {($min + 1) % ($max - 1)} } {2147483645} test expr-34.61 {expr edge cases} {longIs32bit} { expr {($max - 1) / ($min + 1)} } {-1} test expr-34.62 {expr edge cases} {longIs32bit} { expr {($max - 1) % ($min + 1)} } {-1} test expr-34.63 {expr edge cases} {longIs32bit} { expr {($max - 1) / $min} } {-1} test expr-34.64 {expr edge cases} {longIs32bit} { expr {($max - 1) % $min} } {-2} test expr-34.65 {expr edge cases} {longIs32bit} { expr {($max - 2) / $min} } {-1} test expr-34.66 {expr edge cases} {longIs32bit} { expr {($max - 2) % $min} } {-3} test expr-34.67 {expr edge cases} {longIs32bit} { expr {($max - 3) / $min} } {-1} test expr-34.68 {expr edge cases} {longIs32bit} { expr {($max - 3) % $min} } {-4} test expr-34.69 {expr edge cases} {longIs32bit} { expr {-3 / $min} } {0} test expr-34.70 {expr edge cases} {longIs32bit} { expr {-3 % $min} } {-3} test expr-34.71 {expr edge cases} {longIs32bit} { expr {-2 / $min} } {0} test expr-34.72 {expr edge cases} {longIs32bit} { expr {-2 % $min} } {-2} test expr-34.73 {expr edge cases} {longIs32bit} { expr {-1 / $min} } {0} test expr-34.74 {expr edge cases} {longIs32bit} { expr {-1 % $min} } {-1} test expr-34.75 {expr edge cases} {longIs32bit} { expr {0 / $min} } {0} test expr-34.76 {expr edge cases} {longIs32bit} { expr {0 % $min} } {0} test expr-34.77 {expr edge cases} {longIs32bit} { expr {0 / ($min + 1)} } {0} test expr-34.78 {expr edge cases} {longIs32bit} { expr {0 % ($min + 1)} } {0} test expr-34.79 {expr edge cases} {longIs32bit} { expr {1 / $min} } {-1} test expr-34.80 {expr edge cases} {longIs32bit} { expr {1 % $min} } {-2147483647} test expr-34.81 {expr edge cases} {longIs32bit} { expr {1 / ($min + 1)} } {-1} test expr-34.82 {expr edge cases} {longIs32bit} { expr {1 % ($min + 1)} } {-2147483646} test expr-34.83 {expr edge cases} {longIs32bit} { expr {2 / $min} } {-1} test expr-34.84 {expr edge cases} {longIs32bit} { expr {2 % $min} } {-2147483646} test expr-34.85 {expr edge cases} {longIs32bit} { expr {2 / ($min + 1)} } {-1} test expr-34.86 {expr edge cases} {longIs32bit} { expr {2 % ($min + 1)} } {-2147483645} test expr-34.87 {expr edge cases} {longIs32bit} { expr {3 / $min} } {-1} test expr-34.88 {expr edge cases} {longIs32bit} { expr {3 % $min} } {-2147483645} test expr-34.89 {expr edge cases} {longIs32bit} { expr {3 / ($min + 1)} } {-1} test expr-34.90 {expr edge cases} {longIs32bit} { expr {3 % ($min + 1)} } {-2147483644} # Euclidean property: # quotient * divisor + remainder = dividend test expr-35.1 {expr edge cases} {longIs32bit} { set dividend $max set divisor 2 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($divisor * $q) + $r}] } {1073741823 * 2 + 1 = 2147483647} test expr-35.2 {expr edge cases} {longIs32bit} { set dividend [expr {$max - 1}] set divisor 2 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {1073741823 * 2 + 0 = 2147483646} test expr-35.3 {expr edge cases} {longIs32bit} { set dividend [expr {$max - 2}] set divisor 2 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {1073741822 * 2 + 1 = 2147483645} test expr-35.4 {expr edge cases} {longIs32bit} { set dividend $max set divisor 3 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {715827882 * 3 + 1 = 2147483647} test expr-35.5 {expr edge cases} {longIs32bit} { set dividend [expr {$max - 1}] set divisor 3 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {715827882 * 3 + 0 = 2147483646} test expr-35.6 {expr edge cases} {longIs32bit} { set dividend [expr {$max - 2}] set divisor 3 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {715827881 * 3 + 2 = 2147483645} test expr-35.7 {expr edge cases} {longIs32bit} { set dividend $min set divisor 2 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {-1073741824 * 2 + 0 = -2147483648} test expr-35.8 {expr edge cases} {longIs32bit} { set dividend [expr {$min + 1}] set divisor 2 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {-1073741824 * 2 + 1 = -2147483647} test expr-35.9 {expr edge cases} {longIs32bit} { set dividend [expr {$min + 2}] set divisor 2 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {-1073741823 * 2 + 0 = -2147483646} test expr-35.10 {expr edge cases} {longIs32bit} { # Two things could happen here. The multiplication # could overflow a 32 bit type, so that when # 1 is added it overflows again back to min. # The multiplication could also use a wide type # to hold ($min - 1) until 1 is added and # the number becomes $min again. set dividend $min set divisor 3 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {-715827883 * 3 + 1 = -2147483648} test expr-35.11 {expr edge cases} {longIs32bit} { set dividend $min set divisor -3 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {715827882 * -3 + -2 = -2147483648} test expr-35.12 {expr edge cases} {longIs32bit} { set dividend $min set divisor $min set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {1 * -2147483648 + 0 = -2147483648} test expr-35.13 {expr edge cases} {longIs32bit} { set dividend $min set divisor [expr {$min + 1}] set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {1 * -2147483647 + -1 = -2147483648} test expr-35.14 {expr edge cases} {longIs32bit} { set dividend $min set divisor [expr {$min + 2}] set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {1 * -2147483646 + -2 = -2147483648} # 64bit wide integer checks set min -9223372036854775808 set max 9223372036854775807 test expr-36.1 {expr edge cases} {wideIs64bit} { expr {$min / $min} } {1} test expr-36.2 {expr edge cases} {wideIs64bit} { expr {$min % $min} } {0} test expr-36.3 {expr edge cases} {wideIs64bit} { expr {$min / ($min + 1)} } {1} test expr-36.4 {expr edge cases} {wideIs64bit} { expr {$min % ($min + 1)} } {-1} test expr-36.5 {expr edge cases} {wideIs64bit} { expr {$min / ($min + 2)} } {1} test expr-36.6 {expr edge cases} {wideIs64bit} { expr {$min % ($min + 2)} } {-2} test expr-36.7 {expr edge cases} {wideIs64bit} { expr {$min / ($min + 3)} } {1} test expr-36.8 {expr edge cases} {wideIs64bit} { expr {$min % ($min + 3)} } {-3} test expr-36.9 {expr edge cases} {wideIs64bit} { expr {$min / -3} } {3074457345618258602} test expr-36.10 {expr edge cases} {wideIs64bit} { expr {$min % -3} } {-2} test expr-36.11 {expr edge cases} {wideIs64bit} { expr {$min / -2} } {4611686018427387904} test expr-36.12 {expr edge cases} {wideIs64bit} { expr {$min % -2} } {0} test expr-36.13 {expr edge cases} {wideIs64bit} { expr {$min / -1} } $min test expr-36.14 {expr edge cases} {wideIs64bit} { expr {$min % -1} } {0} test expr-36.15 {expr edge cases} {wideIs64bit} { expr {$min * -1} } $min test expr-36.16 {expr edge cases} {wideIs64bit} { expr {-$min} } $min test expr-36.17 {expr edge cases} {wideIs64bit} { expr {$min / 1} } $min test expr-36.18 {expr edge cases} {wideIs64bit} { expr {$min % 1} } {0} test expr-36.19 {expr edge cases} {wideIs64bit} { expr {$min / 2} } {-4611686018427387904} test expr-36.20 {expr edge cases} {wideIs64bit} { expr {$min % 2} } {0} test expr-36.21 {expr edge cases} {wideIs64bit} { expr {$min / 3} } {-3074457345618258603} test expr-36.22 {expr edge cases} {wideIs64bit} { expr {$min % 3} } {1} test expr-36.23 {expr edge cases} {wideIs64bit} { expr {$min / ($max - 3)} } {-2} test expr-36.24 {expr edge cases} {wideIs64bit} { expr {$min % ($max - 3)} } {9223372036854775800} test expr-36.25 {expr edge cases} {wideIs64bit} { expr {$min / ($max - 2)} } {-2} test expr-36.26 {expr edge cases} {wideIs64bit} { expr {$min % ($max - 2)} } {9223372036854775802} test expr-36.27 {expr edge cases} {wideIs64bit} { expr {$min / ($max - 1)} } {-2} test expr-36.28 {expr edge cases} {wideIs64bit} { expr {$min % ($max - 1)} } {9223372036854775804} test expr-36.29 {expr edge cases} {wideIs64bit} { expr {$min / $max} } {-2} test expr-36.30 {expr edge cases} {wideIs64bit} { expr {$min % $max} } {9223372036854775806} test expr-36.31 {expr edge cases} {wideIs64bit} { expr {$max / $max} } {1} test expr-36.32 {expr edge cases} {wideIs64bit} { expr {$max % $max} } {0} test expr-36.33 {expr edge cases} {wideIs64bit} { expr {$max / ($max - 1)} } {1} test expr-36.34 {expr edge cases} {wideIs64bit} { expr {$max % ($max - 1)} } {1} test expr-36.35 {expr edge cases} {wideIs64bit} { expr {$max / ($max - 2)} } {1} test expr-36.36 {expr edge cases} {wideIs64bit} { expr {$max % ($max - 2)} } {2} test expr-36.37 {expr edge cases} {wideIs64bit} { expr {$max / ($max - 3)} } {1} test expr-36.38 {expr edge cases} {wideIs64bit} { expr {$max % ($max - 3)} } {3} test expr-36.39 {expr edge cases} {wideIs64bit} { expr {$max / 3} } {3074457345618258602} test expr-36.40 {expr edge cases} {wideIs64bit} { expr {$max % 3} } {1} test expr-36.41 {expr edge cases} {wideIs64bit} { expr {$max / 2} } {4611686018427387903} test expr-36.42 {expr edge cases} {wideIs64bit} { expr {$max % 2} } {1} test expr-36.43 {expr edge cases} {wideIs64bit} { expr {$max / 1} } $max test expr-36.44 {expr edge cases} {wideIs64bit} { expr {$max % 1} } {0} test expr-36.45 {expr edge cases} {wideIs64bit} { expr {$max / -1} } "-$max" test expr-36.46 {expr edge cases} {wideIs64bit} { expr {$max % -1} } {0} test expr-36.47 {expr edge cases} {wideIs64bit} { expr {$max / -2} } {-4611686018427387904} test expr-36.48 {expr edge cases} {wideIs64bit} { expr {$max % -2} } {-1} test expr-36.49 {expr edge cases} {wideIs64bit} { expr {$max / -3} } {-3074457345618258603} test expr-36.50 {expr edge cases} {wideIs64bit} { expr {$max % -3} } {-2} test expr-36.51 {expr edge cases} {wideIs64bit} { expr {$max / ($min + 3)} } {-2} test expr-36.52 {expr edge cases} {wideIs64bit} { expr {$max % ($min + 3)} } {-9223372036854775803} test expr-36.53 {expr edge cases} {wideIs64bit} { expr {$max / ($min + 2)} } {-2} test expr-36.54 {expr edge cases} {wideIs64bit} { expr {$max % ($min + 2)} } {-9223372036854775805} test expr-36.55 {expr edge cases} {wideIs64bit} { expr {$max / ($min + 1)} } {-1} test expr-36.56 {expr edge cases} {wideIs64bit} { expr {$max % ($min + 1)} } {0} test expr-36.57 {expr edge cases} {wideIs64bit} { expr {$max / $min} } {-1} test expr-36.58 {expr edge cases} {wideIs64bit} { expr {$max % $min} } {-1} test expr-36.59 {expr edge cases} {wideIs64bit} { expr {($min + 1) / ($max - 1)} } {-2} test expr-36.60 {expr edge cases} {wideIs64bit} { expr {($min + 1) % ($max - 1)} } {9223372036854775805} test expr-36.61 {expr edge cases} {wideIs64bit} { expr {($max - 1) / ($min + 1)} } {-1} test expr-36.62 {expr edge cases} {wideIs64bit} { expr {($max - 1) % ($min + 1)} } {-1} test expr-36.63 {expr edge cases} {wideIs64bit} { expr {($max - 1) / $min} } {-1} test expr-36.64 {expr edge cases} {wideIs64bit} { expr {($max - 1) % $min} } {-2} test expr-36.65 {expr edge cases} {wideIs64bit} { expr {($max - 2) / $min} } {-1} test expr-36.66 {expr edge cases} {wideIs64bit} { expr {($max - 2) % $min} } {-3} test expr-36.67 {expr edge cases} {wideIs64bit} { expr {($max - 3) / $min} } {-1} test expr-36.68 {expr edge cases} {wideIs64bit} { expr {($max - 3) % $min} } {-4} test expr-36.69 {expr edge cases} {wideIs64bit} { expr {-3 / $min} } {0} test expr-36.70 {expr edge cases} {wideIs64bit} { expr {-3 % $min} } {-3} test expr-36.71 {expr edge cases} {wideIs64bit} { expr {-2 / $min} } {0} test expr-36.72 {expr edge cases} {wideIs64bit} { expr {-2 % $min} } {-2} test expr-36.73 {expr edge cases} {wideIs64bit} { expr {-1 / $min} } {0} test expr-36.74 {expr edge cases} {wideIs64bit} { expr {-1 % $min} } {-1} test expr-36.75 {expr edge cases} {wideIs64bit} { expr {0 / $min} } {0} test expr-36.76 {expr edge cases} {wideIs64bit} { expr {0 % $min} } {0} test expr-36.77 {expr edge cases} {wideIs64bit} { expr {0 / ($min + 1)} } {0} test expr-36.78 {expr edge cases} {wideIs64bit} { expr {0 % ($min + 1)} } {0} test expr-36.79 {expr edge cases} {wideIs64bit} { expr {1 / $min} } {-1} test expr-36.80 {expr edge cases} {wideIs64bit} { expr {1 % $min} } {-9223372036854775807} test expr-36.81 {expr edge cases} {wideIs64bit} { expr {1 / ($min + 1)} } {-1} test expr-36.82 {expr edge cases} {wideIs64bit} { expr {1 % ($min + 1)} } {-9223372036854775806} test expr-36.83 {expr edge cases} {wideIs64bit} { expr {2 / $min} } {-1} test expr-36.84 {expr edge cases} {wideIs64bit} { expr {2 % $min} } {-9223372036854775806} test expr-36.85 {expr edge cases} {wideIs64bit} { expr {2 / ($min + 1)} } {-1} test expr-36.86 {expr edge cases} {wideIs64bit} { expr {2 % ($min + 1)} } {-9223372036854775805} test expr-36.87 {expr edge cases} {wideIs64bit} { expr {3 / $min} } {-1} test expr-36.88 {expr edge cases} {wideIs64bit} { expr {3 % $min} } {-9223372036854775805} test expr-36.89 {expr edge cases} {wideIs64bit} { expr {3 / ($min + 1)} } {-1} test expr-36.90 {expr edge cases} {wideIs64bit} { expr {3 % ($min + 1)} } {-9223372036854775804} test expr-37.1 {expr edge cases} {wideIs64bit} { set dividend $max set divisor 2 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($divisor * $q) + $r}] } {4611686018427387903 * 2 + 1 = 9223372036854775807} test expr-37.2 {expr edge cases} {wideIs64bit} { set dividend [expr {$max - 1}] set divisor 2 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {4611686018427387903 * 2 + 0 = 9223372036854775806} test expr-37.3 {expr edge cases} {wideIs64bit} { set dividend [expr {$max - 2}] set divisor 2 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {4611686018427387902 * 2 + 1 = 9223372036854775805} test expr-37.4 {expr edge cases} {wideIs64bit} { set dividend $max set divisor 3 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {3074457345618258602 * 3 + 1 = 9223372036854775807} test expr-37.5 {expr edge cases} {wideIs64bit} { set dividend [expr {$max - 1}] set divisor 3 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {3074457345618258602 * 3 + 0 = 9223372036854775806} test expr-37.6 {expr edge cases} {wideIs64bit} { set dividend [expr {$max - 2}] set divisor 3 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {3074457345618258601 * 3 + 2 = 9223372036854775805} test expr-37.7 {expr edge cases} {wideIs64bit} { set dividend $min set divisor 2 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {-4611686018427387904 * 2 + 0 = -9223372036854775808} test expr-37.8 {expr edge cases} {wideIs64bit} { set dividend [expr {$min + 1}] set divisor 2 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {-4611686018427387904 * 2 + 1 = -9223372036854775807} test expr-37.9 {expr edge cases} {wideIs64bit} { set dividend [expr {$min + 2}] set divisor 2 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {-4611686018427387903 * 2 + 0 = -9223372036854775806} test expr-37.10 {expr edge cases} {wideIs64bit} { # Multiplication overflows 64 bit type here, # so when the 1 is added it overflows # again and we end up back at min. set dividend $min set divisor 3 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {-3074457345618258603 * 3 + 1 = -9223372036854775808} test expr-37.11 {expr edge cases} {wideIs64bit} { set dividend $min set divisor -3 set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {3074457345618258602 * -3 + -2 = -9223372036854775808} test expr-37.12 {expr edge cases} {wideIs64bit} { set dividend $min set divisor $min set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {1 * -9223372036854775808 + 0 = -9223372036854775808} test expr-37.13 {expr edge cases} {wideIs64bit} { set dividend $min set divisor [expr {$min + 1}] set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {1 * -9223372036854775807 + -1 = -9223372036854775808} test expr-37.14 {expr edge cases} {wideIs64bit} { set dividend $min set divisor [expr {$min + 2}] set q [expr {$dividend / $divisor}] set r [expr {$dividend % $divisor}] list $q * $divisor + $r = [expr {($q * $divisor) + $r}] } {1 * -9223372036854775806 + -2 = -9223372036854775808} test expr-38.1 {abs of smallest 32-bit integer [Bug 1241572]} {wideIs64bit} { expr {abs(-2147483648)} } 2147483648 testConstraint testexprlongobj [llength [info commands testexprlongobj]] testConstraint testexprdoubleobj [llength [info commands testexprdoubleobj]] test expr-39.1 {Check that Tcl_ExprLongObj doesn't modify interpreter result if no error} testexprlongobj { testexprlongobj 4+1 } {This is a result: 5} #Check for [Bug 1109484] test expr-39.2 {Tcl_ExprLongObj handles wide ints gracefully} testexprlongobj { testexprlongobj wide(1)+2 } {This is a result: 3} test expr-39.3 {Tcl_ExprLongObj on the empty string} \ -constraints testexprlongobj \ -body { list [catch {testexprlongobj ""} result] $result } \ -match glob \ -result {1 {syntax error*}} test expr-39.4 {Tcl_ExprLongObj coerces doubles} testexprlongobj { testexprlongobj 3+.14159 } {This is a result: 3} test expr-39.5 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { testexprlongobj 0x80000000 } {This is a result: -2147483648} test expr-39.6 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { testexprlongobj 0xffffffff } {This is a result: -1} test expr-39.7 {Tcl_ExprLongObj handles overflows} \ -constraints {testexprlongobj longIs32bit} \ -match glob \ -body { list [catch {testexprlongobj 0x100000000} result] $result } \ -result {1 {integer value too large to represent*}} test expr-39.8 {Tcl_ExprLongObj handles overflows} testexprlongobj { testexprlongobj -0x80000000 } {This is a result: -2147483648} test expr-39.9 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { testexprlongobj -0xffffffff } {This is a result: 1} test expr-39.10 {Tcl_ExprLongObj handles overflows} \ -constraints {testexprlongobj longIs32bit} \ -match glob \ -body { list [catch {testexprlongobj -0x100000000} result] $result } \ -result {1 {integer value too large to represent*}} test expr-39.11 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { testexprlongobj 2147483648. } {This is a result: -2147483648} test expr-39.12 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { testexprlongobj 4294967295. } {This is a result: -1} test expr-39.13 {Tcl_ExprLongObj handles overflows} \ -constraints {testexprlongobj longIs32bit} \ -match glob \ -body { list [catch {testexprlongobj 4294967296.} result] $result } \ -result {1 {integer value too large to represent*}} test expr-39.14 {Tcl_ExprLongObj handles overflows} testexprlongobj { testexprlongobj -2147483648. } {This is a result: -2147483648} test expr-39.15 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { testexprlongobj -4294967295. } {This is a result: 1} test expr-39.16 {Tcl_ExprLongObj handles overflows} \ -constraints {testexprlongobj longIs32bit} \ -match glob \ -body { list [catch {testexprlongobj 4294967296.} result] $result } \ -result {1 {integer value too large to represent*}} test expr-39.17 {Check that Tcl_ExprDoubleObj doesn't modify interpreter result if no error} testexprdoubleobj { testexprdoubleobj 4.+1. } {This is a result: 5.0} #Check for [Bug 1109484] test expr-39.18 {Tcl_ExprDoubleObj on the empty string} \ -constraints testexprdoubleobj \ -match glob \ -body { list [catch {testexprdoubleobj ""} result] $result } \ -result {1 {syntax error*}} test expr-39.19 {Tcl_ExprDoubleObj coerces wides} testexprdoubleobj { testexprdoubleobj 1[string repeat 0 17] } {This is a result: 1e+17} test expr-39.20 {Tcl_ExprDoubleObj coerces bignums} testexprdoubleobj { testexprdoubleobj 1[string repeat 0 38] } {This is a result: 1e+38} test expr-39.21 {Tcl_ExprDoubleObj handles overflows} \ testexprdoubleobj&&ieeeFloatingPoint { testexprdoubleobj 17976931348623157[string repeat 0 292]. } {This is a result: 1.7976931348623157e+308} test expr-39.22 {Tcl_ExprDoubleObj handles overflows that look like int} \ testexprdoubleobj&&ieeeFloatingPoint { testexprdoubleobj 17976931348623157[string repeat 0 292] } {This is a result: 1.7976931348623157e+308} test expr-39.23 {Tcl_ExprDoubleObj handles overflows} \ testexprdoubleobj&&ieeeFloatingPoint { testexprdoubleobj 17976931348623165[string repeat 0 292]. } {This is a result: Inf} test expr-39.24 {Tcl_ExprDoubleObj handles overflows that look like int} \ testexprdoubleobj&&ieeeFloatingPoint { testexprdoubleobj 17976931348623165[string repeat 0 292] } {This is a result: Inf} test expr-39.25 {Tcl_ExprDoubleObj and NaN} \ testexprdoubleobj&&ieeeFloatingPoint { list [catch {testexprdoubleobj 0.0/0.0} result] $result } {1 {floating point value is Not a Number}} test expr-40.1 {large octal shift} { expr 0100000000000000000000000000000000 } [expr 0x1000000000000000000000000] test expr-40.2 {large octal shift} { expr 0100000000000000000000000000000001 } [expr 0x1000000000000000000000001] test expr-41.1 {exponent overflow} { expr 1.0e2147483630 } Inf test expr-41.2 {exponent underflow} { expr 1.0e-2147483630 } 0.0 test expr-42.1 {denormals} ieeeFloatingPoint { expr 7e-324 } 5e-324 # TIP 114 test expr-43.1 {0b notation} { expr 0b0 } 0 test expr-43.2 {0b notation} { expr 0b1 } 1 test expr-43.3 {0b notation} { expr 0b10 } 2 test expr-43.4 {0b notation} { expr 0b11 } 3 test expr-43.5 {0b notation} { expr 0b100 } 4 test expr-43.6 {0b notation} { expr 0b101 } 5 test expr-43.7 {0b notation} { expr 0b1000 } 8 test expr-43.8 {0b notation} { expr 0b1001 } 9 test expr-43.9 {0b notation} { expr 0b1[string repeat 0 31] } 2147483648 test expr-43.10 {0b notation} { expr 0b1[string repeat 0 30]1 } 2147483649 test expr-43.11 {0b notation} { expr 0b[string repeat 1 64] } 18446744073709551615 test expr-43.12 {0b notation} { expr 0b1[string repeat 0 64] } 18446744073709551616 test expr-43.13 {0b notation} { expr 0b1[string repeat 0 63]1 } 18446744073709551617 test expr-44.1 {0o notation} { expr 0o0 } 0 test expr-44.2 {0o notation} { expr 0o1 } 1 test expr-44.3 {0o notation} { expr 0o7 } 7 test expr-44.4 {0o notation} { expr 0o10 } 8 test expr-44.5 {0o notation} { expr 0o11 } 9 test expr-44.6 {0o notation} { expr 0o100 } 64 test expr-44.7 {0o notation} { expr 0o101 } 65 test expr-44.8 {0o notation} { expr 0o1000 } 512 test expr-44.9 {0o notation} { expr 0o1001 } 513 test expr-44.10 {0o notation} { expr 0o1[string repeat 7 21] } 18446744073709551615 test expr-44.11 {0o notation} { expr 0o2[string repeat 0 21] } 18446744073709551616 test expr-44.12 {0o notation} { expr 0o2[string repeat 0 20]1 } 18446744073709551617 # TIP 237 again test expr-45.1 {entier} { expr entier(0) } 0 test expr-45.2 {entier} { expr entier(0.5) } 0 test expr-45.3 {entier} { expr entier(1.0) } 1 test expr-45.4 {entier} { expr entier(1.5) } 1 test expr-45.5 {entier} { expr entier(2.0) } 2 test expr-45.6 {entier} { expr entier(1e+22) } 10000000000000000000000 test expr-45.7 {entier} { list [catch {expr entier(Inf)} result] $result } {1 {integer value too large to represent}} test expr-45.8 {entier} ieeeFloatingPoint { list [catch {expr {entier($ieeeValues(NaN))}} result] $result } {1 {floating point value is Not a Number}} test expr-45.9 {entier} ieeeFloatingPoint { list [catch {expr {entier($ieeeValues(-NaN))}} result] $result } {1 {floating point value is Not a Number}} test expr-46.1 {round() rounds to +-infinity} { expr round(0.5) } 1 test expr-46.2 {round() rounds to +-infinity} { expr round(1.5) } 2 test expr-46.3 {round() rounds to +-infinity} { expr round(-0.5) } -1 test expr-46.4 {round() rounds to +-infinity} { expr round(-1.5) } -2 test expr-46.5 {round() overflow} { list [catch {expr round(9.2233720368547758e+018)} result] $result } {1 {integer value too large to represent}} test expr-46.6 {round() overflow} { list [catch {expr round(-9.2233720368547758e+018)} result] $result } {1 {integer value too large to represent}} test expr-46.7 {round() bad value} { set x trash list [catch {expr {round($x)}} result] $result } {1 {argument to math function didn't have numeric value}} test expr-46.8 {round() already an integer} { set x 123456789012 incr x expr round($x) } 123456789013 test expr-46.9 {round() boundary case - 1/2 - 1 ulp} { set x 0.25 set bit 0.125 while 1 { set newx [expr {$x + $bit}] if { $newx == $x || $newx == 0.5 } break set x $newx set bit [expr { $bit / 2.0 }] } expr {round($x)} } 0 test expr-46.10 {round() boundary case - 1/2 + 1 ulp} { set x 0.75 set bit 0.125 while 1 { set newx [expr {$x - $bit}] if { $newx == $x || $newx == 0.5 } break set x $newx set bit [expr { $bit / 2.0 }] } expr {round($x)} } 1 test expr-46.11 {round() boundary case - -1/2 - 1 ulp} { set x -0.75 set bit 0.125 while 1 { set newx [expr {$x + $bit}] if { $newx == $x || $newx == -0.5 } break set x $newx set bit [expr { $bit / 2.0 }] } expr {round($x)} } -1 test expr-46.12 {round() boundary case - -1/2 + 1 ulp} { set x -0.25 set bit 0.125 while 1 { set newx [expr {$x - $bit}] if { $newx == $x || $newx == -0.5 } break set x $newx set bit [expr { $bit / 2.0 }] } expr {round($x)} } 0 # cleanup if {[info exists a]} { unset a } catch {unset min} catch {unset max} ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
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 | # 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.44.2.2 2005/10/08 13:44:38 dgp Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } |
︙ | ︙ | |||
1631 1632 1633 1634 1635 1636 1637 | file mkdir tfa tfad/tfa/file set r1 [catch {file rename tfa tfad}] set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] file delete -force tfa tfad set result } {1} test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} \ | | | 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 | file mkdir tfa tfad/tfa/file set r1 [catch {file rename tfa tfad}] set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] file delete -force tfa tfad set result } {1} test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} \ {notRoot notNetworkFilesystem} { catch {file delete -force -- tfa tfad} file mkdir tfa tfad/tfa/file set r1 [catch {file rename -force tfa tfad}] set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]] file delete -force tfa tfad set result } {1} |
︙ | ︙ | |||
1762 1763 1764 1765 1766 1767 1768 | set result } {1} test fCmd-20.2 {TraverseUnixTree : recursive delete of large directory: Bug 1034337} \ {unix notRoot} { catch {file delete -force -- tfa} file mkdir tfa | | | 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 | set result } {1} test fCmd-20.2 {TraverseUnixTree : recursive delete of large directory: Bug 1034337} \ {unix notRoot} { catch {file delete -force -- tfa} file mkdir tfa for {set i 1} {$i <= 300} {incr i} {createfile tfa/testfile_$i} set result [catch {file delete -force tfa} msg] while {[catch {file delete -force tfa}]} {} list $result $msg } {0 {}} # # Feature testing for TclCopyFilesCmd |
︙ | ︙ |
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.45.2.2 2005/08/02 18:16:40 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]] |
︙ | ︙ | |||
662 663 664 665 666 667 668 | list [catch {testtranslatefilename foo//bar} msg] $msg } {0 {foo\bar}} if {[testConstraint testsetplatform]} { testsetplatform $platform } | | | | 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 | list [catch {testtranslatefilename foo//bar} msg] $msg } {0 {foo\bar}} if {[testConstraint testsetplatform]} { testsetplatform $platform } test filename-10.23 {Tcl_TranslateFileName} {nonPortable} { # this test fails if ~ouster is not /home/ouster list [catch {testtranslatefilename ~ouster} msg] $msg } {0 /home/ouster} test filename-10.24 {Tcl_TranslateFileName} {nonPortable} { # this test fails if ~ouster is not /home/ouster list [catch {testtranslatefilename ~ouster/foo} msg] $msg } {0 /home/ouster/foo} test filename-11.1 {Tcl_GlobCmd} { list [catch {glob} msg] $msg |
︙ | ︙ | |||
1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 | set res [glob -nocomplain -dir [temporaryDirectory]/execglob \ -tails -types x *] removeFile execglob/abc.exe removeFile execglob/abc.notexecutable removeDirectory execglob set res } {abc.exe} # cleanup catch {file delete -force C:/globTest} cd [temporaryDirectory] file delete -force globTest cd $oldpwd set env(HOME) $oldhome | > > > > > > > | 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 | set res [glob -nocomplain -dir [temporaryDirectory]/execglob \ -tails -types x *] removeFile execglob/abc.exe removeFile execglob/abc.notexecutable removeDirectory execglob set res } {abc.exe} test fileName-18.1 {windows - split ADS name correctly} {win} { # bug 1194458 set x [file split c:/c:d] set y [eval [linsert $x 0 file join]] list $x $y } {{c:/ ./c:d} c:/c:d} # cleanup catch {file delete -force C:/globTest} cd [temporaryDirectory] file delete -force globTest cd $oldpwd set env(HOME) $oldhome |
︙ | ︙ |
Changes to tests/fileSystem.test.
︙ | ︙ | |||
909 910 911 912 913 914 915 | set absolute [file join [pwd] $relative] set res [list [file tail $absolute] "test"] } file delete -force dgp cd $origdir set res } {test test} | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | set absolute [file join [pwd] $relative] set res [list [file tail $absolute] "test"] } file delete -force dgp cd $origdir set res } {test test} test filesystem-9.6 {path objects and file tail and object rep} win { set res {} set p "C:\\toto" lappend res [file join $p toto] file isdirectory $p lappend res [file join $p toto] } {C:/toto/toto C:/toto/toto} test filesystem-9.7 {path objects and glob and file tail and tilde} { set res {} set origdir [pwd] cd [tcltest::temporaryDirectory] file mkdir tilde close [open tilde/~testNotExist w] cd tilde set file [lindex [glob *test*] 0] lappend res [file exists $file] [catch {file tail $file} r] $r lappend res $file lappend res [file exists $file] [catch {file tail $file} r] $r lappend res [catch {file tail $file} r] $r cd .. file delete -force tilde cd $origdir set res } {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} test filesystem-9.8 {path objects and glob and file tail and tilde} { set res {} set origdir [pwd] cd [tcltest::temporaryDirectory] file mkdir tilde close [open tilde/~testNotExist w] cd tilde set file1 [lindex [glob *test*] 0] set file2 "~testNotExist" lappend res $file1 $file2 lappend res [catch {file tail $file1} r] $r lappend res [catch {file tail $file2} r] $r cd .. file delete -force tilde cd $origdir set res } {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} test filesystem-9.9 {path objects and glob and file tail and tilde} { set res {} set origdir [pwd] cd [tcltest::temporaryDirectory] file mkdir tilde close [open tilde/~testNotExist w] cd tilde set file1 [lindex [glob *test*] 0] set file2 "~testNotExist" lappend res [catch {file exists $file1} r] $r lappend res [catch {file exists $file2} r] $r lappend res [string equal $file1 $file2] cd .. file delete -force tilde cd $origdir set res } {0 0 0 0 1} cleanupTests unset -nocomplain drive } namespace delete ::tcl::test::fileSystem return |
Changes to tests/for.test.
1 2 3 4 5 6 7 8 9 10 11 | # Commands covered: for, continue, break # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 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 | # Commands covered: for, continue, break # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 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: for.test,v 1.10.2.2 2005/07/12 20:37:09 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # Basic "for" operation. |
︙ | ︙ | |||
655 656 657 658 659 660 661 | list [catch {$z {set} {$i < 5} {incr i} {body}} msg] $msg $errorInfo } -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" while *ing "set" ("for" initial command) invoked from within "$z {set} {$i < 5} {incr i} {body}"}} | | | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 | list [catch {$z {set} {$i < 5} {incr i} {body}} msg] $msg $errorInfo } -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" while *ing "set" ("for" initial command) invoked from within "$z {set} {$i < 5} {incr i} {body}"}} test for-6.7 {Tcl_ForObjCmd: error in test expression} -match glob -body { set z for list [catch {$z {set i 0} {i < 5} {incr i} {body}} msg] $msg $errorInfo } -result {1 {syntax error in expression "i < 5": * preceding $*} {syntax error in expression "i < 5": * preceding $* while executing "$z {set i 0} {i < 5} {incr i} {body}"}} test for-6.8 {Tcl_ForObjCmd: test expression is enclosed in quotes} { set z for set i 0 $z {set i 6} "$i > 5" {incr i} {set y $i} set i |
︙ | ︙ | |||
759 760 761 762 763 764 765 | set a } {} test for-6.16 {Tcl_ForObjCmd: for command result} { set z for set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}] set a } {} | > > > > > > > > > > > > > > > | > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | set a } {} test for-6.16 {Tcl_ForObjCmd: for command result} { set z for set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}] set a } {} test for-6.17 {Tcl_ForObjCmd: for command result} { list \ [catch {for {break} {1} {} {}} err] $err \ [catch {for {continue} {1} {} {}} err] $err \ [catch {for {} {[break]} {} {}} err] $err \ [catch {for {} {[continue]} {} {}} err] $err \ [catch {for {} {1} {break} {}} err] $err \ [catch {for {} {1} {continue} {}} err] $err \ } [list \ 3 {} \ 4 {} \ 3 {} \ 4 {} \ 0 {} \ 4 {} \ ] test for-6.18 {Tcl_ForObjCmd: for command result} { proc p6181 {} { for {break} {1} {} {} } proc p6182 {} { for {continue} {1} {} {} } proc p6183 {} { for {} {[break]} {} {} } proc p6184 {} { for {} {[continue]} {} {} } proc p6185 {} { for {} {1} {break} {} } proc p6186 {} { for {} {1} {continue} {} } list \ [catch {p6181} err] $err \ [catch {p6182} err] $err \ [catch {p6183} err] $err \ [catch {p6184} err] $err \ [catch {p6185} err] $err \ [catch {p6186} err] $err } [list \ 1 {invoked "break" outside of a loop} \ 1 {invoked "continue" outside of a loop} \ 1 {invoked "break" outside of a loop} \ 1 {invoked "continue" outside of a loop} \ 0 {} \ 1 {invoked "continue" outside of a loop} \ ] # cleanup ::tcltest::cleanupTests return |
Changes to tests/format.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: format # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | < < < < < < < | > > | > > > | > > > | > > > | > > > | > > > | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 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 | # 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.19.2.3 2005/08/22 12:55:10 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 } { 34 16923 -12 -1} test format-1.2 {integer formatting} { format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 } { 6 34 16923 -12 -1 0xe 0XC} # %u output depends on word length, so this test is not portable. testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] test format-1.3 {integer formatting} longIs32bit { format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 } { 6 34 16923 4294967284 -1 0} test format-1.3.1 {integer formatting} longIs64bit { format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 } { 6 34 16923 18446744073709551604 -1 0} test format-1.4 {integer formatting} { format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1 } {6 34 16923 -12 } test format-1.5 {integer formatting} { format "%04d %04d %04d %04i" 6 34 16923 -12 -1 } {0006 0034 16923 -012} test format-1.6 {integer formatting} { format "%00*d" 6 34 } {000034} # Printing negative numbers in hex or octal format depends on word # length, so these tests are not portable. test format-1.7 {integer formatting} longIs32bit { format "%4x %4x %4x %4x" 6 34 16923 -12 -1 } { 6 22 421b fffffff4} test format-1.7.1 {integer formatting} longIs64bit { format "%4x %4x %4x %4x" 6 34 16923 -12 -1 } { 6 22 421b fffffffffffffff4} test format-1.8 {integer formatting} longIs32bit { format "%#x %#X %#X %#x" 6 34 16923 -12 -1 } {0x6 0X22 0X421B 0xfffffff4} test format-1.8.1 {integer formatting} longIs64bit { format "%#x %#X %#X %#x" 6 34 16923 -12 -1 } {0x6 0X22 0X421B 0xfffffffffffffff4} test format-1.9 {integer formatting} longIs32bit { format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1 } { 0x6 0x22 0x421b 0xfffffff4} test format-1.9.1 {integer formatting} longIs64bit { format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1 } { 0x6 0x22 0x421b 0xfffffffffffffff4} test format-1.10 {integer formatting} longIs32bit { format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1 } {0x6 0x22 0x421b 0xfffffff4 } test format-1.10.1 {integer formatting} longIs64bit { format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1 } {0x6 0x22 0x421b 0xfffffffffffffff4 } test format-1.11 {integer formatting} longIs32bit { format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1 } {06 042 041033 037777777764 } test format-1.11.1 {integer formatting} longIs64bit { format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1 } {06 042 041033 01777777777777777777764} test format-2.1 {string formatting} { format "%s %s %c %s" abcd {This is a very long test string.} 120 x } {abcd This is a very long test string. x x} test format-2.2 {string formatting} { format "%20s %20s %20c %20s" abcd {This is a very long test string.} 120 x } { abcd This is a very long test string. x x} |
︙ | ︙ | |||
126 127 128 129 130 131 132 | test format-4.1 {e and f formats} {eformat} { format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053 } {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} test format-4.2 {e and f formats} {eformat} { format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053 } { 3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} | | | | | | | 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 | test format-4.1 {e and f formats} {eformat} { format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053 } {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} test format-4.2 {e and f formats} {eformat} { format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053 } { 3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} test format-4.3 {e and f formats} {eformat} { format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053 } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04} test format-4.4 {e and f formats} {eformat} { format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053 } {000000003.420000e+13 000000006.851400e+01 -00000001.260000e-01 -00000001.600000e+04} test format-4.5 {e and f formats} {eformat} { format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053 } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04} test format-4.6 {e and f formats} { format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053 } {34200000000000.000000 68.514000 -0.125000 -16000.000000} test format-4.7 {e and f formats} { format "%.4f %.4f %.4f %.4f %.4f" 34.2e12 68.514 -.125 -16000. .000053 } {34200000000000.0000 68.5140 -0.1250 -16000.0000 0.0001} test format-4.8 {e and f formats} {eformat} { format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996 } {-1.0000e+01 -9.99996e+00 9.999960e+00} test format-4.9 {e and f formats} { format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996 |
︙ | ︙ | |||
351 352 353 354 355 356 357 | } {expected integer but got "xyz"} test format-9.1 {long result} { set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s} $a $a } {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} | | | | > > > > | 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 | } {expected integer but got "xyz"} test format-9.1 {long result} { set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s} $a $a } {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} test format-10.1 {"h" format specifier} { format %hd 0xffff } -1 test format-10.2 {"h" format specifier} { format %hx 0x10fff } fff test format-10.3 {"h" format specifier} { format %hd 0x10000 } 0 test format-10.4 {"h" format specifier} { # Bug 1154163: This is minimal behaviour for %hx specifier! format %hx 1 } 1 test format-11.1 {XPG3 %$n specifiers} { format {%2$d %1$d} 4 5 } {5 4} test format-11.2 {XPG3 %$n specifiers} { format {%2$d %1$d %1$d %3$d} 4 5 6 } {5 4 4 6} |
︙ | ︙ | |||
482 483 484 485 486 487 488 | 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" } | | | | | | | | 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 | 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 wideIs64bit \ [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] ::tcltest::testConstraint wideBiggerThanInt \ [expr {wide(0x80000000) != int(0x80000000)}] test format-17.1 {testing %d with wide} {wideIs64bit wideBiggerThanInt} { list [catch {format %d 7810179016327718216} msg] $msg } {1 {integer value too large to represent}} test format-17.2 {testing %ld with wide} {wideIs64bit} { format %ld 7810179016327718216 } 7810179016327718216 test format-17.3 {testing %ld with non-wide} {wideIs64bit} { format %ld 42 } 42 test format-17.4 {testing %l with non-integer} { format %lf 1 } 1.000000 test format-18.1 {do not demote existing numeric values} { |
︙ | ︙ | |||
517 518 519 520 521 522 523 | set b 0xaaaa append b aaaa lappend result [expr {$a == $b}] format %08x $b lappend result [expr {$a == $b}] } {1 1 1 1} | | | 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 | set b 0xaaaa append b aaaa lappend result [expr {$a == $b}] format %08x $b lappend result [expr {$a == $b}] } {1 1 1 1} test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} { set a [expr {0xaaaaaaaaaa + 1}] set b 0xaaaaaaaaab list [catch {format %08x $a} msg] $msg [expr {$a == $b}] } {1 {integer value too large to represent} 1} test format-19.1 { regression test - tcl-core message by Brian Griffin on |
︙ | ︙ |
Changes to tests/get.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: none # # This file contains a collection of tests for the procedures in the # file tclGet.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | > | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 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 | # Commands covered: none # # This file contains a collection of tests for the procedures in the # file tclGet.c. 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: get.test,v 1.9.2.2 2005/08/15 18:14:01 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } testConstraint testgetint [llength [info commands testgetint]] testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] test get-1.1 {Tcl_GetInt procedure} testgetint { testgetint 44 { 22} } {66} test get-1.2 {Tcl_GetInt procedure} testgetint { testgetint 44 -3 } {41} test get-1.3 {Tcl_GetInt procedure} testgetint { testgetint 44 +8 } {52} test get-1.4 {Tcl_GetInt procedure} testgetint { list [catch {testgetint 44 foo} msg] $msg } {1 {expected integer but got "foo"}} test get-1.5 {Tcl_GetInt procedure} testgetint { list [catch {testgetint 44 {16 }} msg] $msg } {0 60} test get-1.6 {Tcl_GetInt procedure} testgetint { list [catch {testgetint 44 {16 x}} msg] $msg } {1 {expected integer but got "16 x"}} test get-1.7 {Tcl_GetInt procedure} {testgetint longIs64bit} { list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} { list [catch {testgetint 18446744073709551614} msg] $msg } {0 -2} test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} { list [catch {testgetint +18446744073709551614} msg] $msg } {0 -2} test get-1.10 {Tcl_GetInt procedure} {testgetint longIs64bit} { list [catch {testgetint -18446744073709551614} msg] $msg } {0 2} test get-1.11 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint 44 4294967296} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test get-1.12 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint 4294967294} msg] $msg } {0 -2} test get-1.13 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint +4294967294} msg] $msg } {0 -2} test get-1.14 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint -4294967294} msg] $msg } {0 2} test get-2.1 {Tcl_GetInt procedure} { format %g 1.23 } {1.23} test get-2.2 {Tcl_GetInt procedure} { format %g { 1.23 } } {1.23} test get-2.3 {Tcl_GetInt procedure} { list [catch {format %g clip} msg] $msg } {1 {expected floating-point number but got "clip"}} test get-2.4 {Tcl_GetInt procedure} { format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001 } 0 test get-3.1 {Tcl_GetInt(FromObj), bad numbers} { # SF bug #634856 set result "" set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1" "+12345678987654321" "++12345678987654321"] foreach num $numbers { lappend result [catch {format %ld $num} msg] $msg |
︙ | ︙ |
Changes to tests/http.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # # RCS: @(#) $Id: http.test,v 1.38.2.1 2005/10/08 13:44:39 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } if {[catch {package require http 2} version]} { |
︙ | ︙ | |||
479 480 481 482 483 484 485 | test http-5.3 {http::formatQuery} { http::formatQuery lines "line1\nline2\nline3" } {lines=line1%0d%0aline2%0d%0aline3} test http-5.4 {http::formatQuery} { http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 | | | | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 | test http-5.3 {http::formatQuery} { http::formatQuery lines "line1\nline2\nline3" } {lines=line1%0d%0aline2%0d%0aline3} test http-5.4 {http::formatQuery} { http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 } {name1=~bwelch&name2=%c2%a1%c2%a2%c2%a2} test http-5.5 {http::formatQuery} { set enc [http::config -urlencoding] http::config -urlencoding iso8859-1 set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2] http::config -urlencoding $enc set res } {name1=~bwelch&name2=%a1%a2%a2} test http-6.1 {http::ProxyRequired} { http::config -proxyhost [info hostname] -proxyport $port set token [http::geturl $url] http::wait $token http::config -proxyhost {} -proxyport {} upvar #0 $token data |
︙ | ︙ |
Changes to tests/info.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: info # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # 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.29.2.3 2005/10/08 13:44:39 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. catch {namespace delete test_ns_info1 test_ns_info2} |
︙ | ︙ | |||
147 148 149 150 151 152 153 154 155 156 157 158 159 160 | lsort [info commands _t*] } {_t1_ _t2_} catch {rename _t1_ {}} catch {rename _t2_ {}} test info-4.5 {info commands option} { list [catch {info commands a b} msg] $msg } {1 {wrong # args: should be "info commands ?pattern?"}} test info-5.1 {info complete option} { list [catch {info complete} msg] $msg } {1 {wrong # args: should be "info complete command"}} test info-5.2 {info complete option} { info complete abc } 1 | > | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 | lsort [info commands _t*] } {_t1_ _t2_} catch {rename _t1_ {}} catch {rename _t2_ {}} test info-4.5 {info commands option} { list [catch {info commands a b} msg] $msg } {1 {wrong # args: should be "info commands ?pattern?"}} # Also some tests in namespace.test test info-5.1 {info complete option} { list [catch {info complete} msg] $msg } {1 {wrong # args: should be "info complete command"}} test info-5.2 {info complete option} { info complete abc } 1 |
︙ | ︙ | |||
287 288 289 290 291 292 293 294 295 296 297 298 299 300 | test info-8.3 {info globals option} { list [catch {info globals 1 2} msg] $msg } {1 {wrong # args: should be "info globals ?pattern?"}} test info-8.4 {info globals option: may have leading namespace qualifiers} { set x 0 list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x] } {x {} x x x} test info-9.1 {info level option} { info level } 0 test info-9.2 {info level option} { proc t1 {a b} { set x [info le] | > > > > > > > > > > > > > | 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 | test info-8.3 {info globals option} { list [catch {info globals 1 2} msg] $msg } {1 {wrong # args: should be "info globals ?pattern?"}} test info-8.4 {info globals option: may have leading namespace qualifiers} { set x 0 list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x] } {x {} x x x} test info-8.5 {info globals option: only return existing global variables} { -setup { catch {unset ::NO_SUCH_VAR} proc evalInProc script {eval $script} } -body { evalInProc {global NO_SUCH_VAR; info globals NO_SUCH_VAR} } -cleanup { rename evalInProc {} } -result {} } test info-9.1 {info level option} { info level } 0 test info-9.2 {info level option} { proc t1 {a b} { set x [info le] |
︙ | ︙ | |||
609 610 611 612 613 614 615 | namespace eval x info vars foo } -cleanup { namespace delete x } -result {} # Check whether the extra testing functions are defined... if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { | | | | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 | namespace eval x info vars foo } -cleanup { namespace delete x } -result {} # Check whether the extra testing functions are defined... if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { set functions {abs acos asin atan atan2 bool ceil cos cosh double exp floor fmod hypot int log log10 max min pow rand round sin sinh sqrt srand tan tanh wide} } else { set functions {T1 T2 T3 abs acos asin atan atan2 bool ceil cos cosh double exp floor fmod hypot int log log10 max min pow rand round sin sinh sqrt srand tan tanh wide} } test info-20.1 {info functions option} {info functions sin} sin test info-20.2 {info functions option} {lsort [info functions]} $functions test info-20.3 {info functions option} { lsort [info functions a*] } {abs acos asin atan atan2} test info-20.4 {info functions option} { |
︙ | ︙ |
Changes to tests/init.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Functionality covered: this file contains a collection of tests for the # auto loading and namespaces. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # Functionality covered: this file contains a collection of tests for the # auto loading and namespaces. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: init.test,v 1.13.2.1 2005/07/12 20:37:11 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # Clear out any namespaces called test_ns_* |
︙ | ︙ | |||
191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 | catch {parray ::junk::$arg} set second $::errorInfo string equal $first $second } 1 incr count } cleanupTests } ;# End of [interp eval $testInterp] # cleanup interp delete $testInterp ::tcltest::cleanupTests return | > > > > > > > > > > > > > | 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 | catch {parray ::junk::$arg} set second $::errorInfo string equal $first $second } 1 incr count } test init-5.0 {return options passed through ::unknown} -setup { catch {rename xxx {}} set ::auto_index(::xxx) {proc ::xxx {} { return -code error -level 2 xxx }} } -body { set code [catch {::xxx} foo bar] set code2 [catch {::xxx} foo2 bar2] list $code $foo $bar $code2 $foo2 $bar2 } -cleanup { unset ::auto_index(::xxx) } -result {2 xxx {-code 1 -level 1} 2 xxx {-code 1 -level 1}} cleanupTests } ;# End of [interp eval $testInterp] # cleanup interp delete $testInterp ::tcltest::cleanupTests return |
Changes to tests/interp.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the multiple interpreter facility of Tcl # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # 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.43.2.2 2005/07/12 20:37:11 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } testConstraint testinterpdelete [llength [info commands testinterpdelete]] |
︙ | ︙ | |||
3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 | } } list $n [interp exists $i] } -result {4 0} -cleanup { rename cb3 {} rename cb4 {} } test interp-35.1 {interp limit syntax} -body { interp limit } -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"} test interp-35.2 {interp limit syntax} -body { interp limit {} } -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"} | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } } list $n [interp exists $i] } -result {4 0} -cleanup { rename cb3 {} rename cb4 {} } # Bug 1085023 test interp-34.8 {time limits trigger in vwaits} -body { set i [interp create] interp limit $i time -seconds [expr {[clock seconds]+1}] -granularity 1 $i eval { set x {} vwait x } } -cleanup { interp delete $i } -returnCodes error -result {limit exceeded} test interp-34.9 {time limits trigger in blocking after} { set i [interp create] set t0 [clock seconds] interp limit $i time -seconds [expr {$t0 + 1}] -granularity 1 set code [catch { $i eval {after 10000} } msg] set t1 [clock seconds] interp delete $i list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] } {1 {time limit exceeded} OK} test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { set i [interp create] # Assume someone hasn't set the clock to early 1970! $i limit time -seconds 1 -granularity 4 interp alias $i log {} lappend result set result {} catch { $i eval { log 1 after 100 log 2 } } msg interp delete $i lappend result $msg } -result {1 {time limit exceeded}} test interp-35.1 {interp limit syntax} -body { interp limit } -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"} test interp-35.2 {interp limit syntax} -body { interp limit {} } -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"} |
︙ | ︙ |
Changes to tests/io.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # Functionality covered: operation of all IO commands, and all procedures # defined in generic/tclIO.c. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | > | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | # -*- tcl -*- # Functionality covered: operation of all IO commands, and all procedures # defined in generic/tclIO.c. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: io.test,v 1.65.2.3 2005/08/25 15:46:53 dgp Exp $ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } namespace eval ::tcl::test::io { namespace import ::tcltest::cleanupTests namespace import ::tcltest::interpreter namespace import ::tcltest::makeFile namespace import ::tcltest::removeFile namespace import ::tcltest::test namespace import ::tcltest::testConstraint namespace import ::tcltest::viewFile testConstraint testchannel [llength [info commands testchannel]] testConstraint exec [llength [info commands exec]] testConstraint openpipe 1 testConstraint fileevent [llength [info commands fileevent]] testConstraint fcopy [llength [info commands fcopy]] testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... testConstraint largefileSupport 0 # some tests can only be run is umask is 2 # if "umask" cannot be run, the tests will be skipped. |
︙ | ︙ | |||
1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 | 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} emptyTest { } {} test io-16.1 {Tcl_DeleteCloseHandler} emptyTest { | > > > > > > | 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 | set f [open "|[list [info nameofexecutable] $path(cat) $path(test1)]" r] puts [gets $f] } close $f set f [open "|[list [interpreter] $path(script) [array get path]]" r] set c [gets $f] close $f # Added delay to give Windows time to stop the spawned process and clean # up its grip on the file test1. Added delete as proper test cleanup. # The failing tests were 18.1 and 18.2 as first re-users of file "test1". after 10000 file delete $path(script) file delete $path(test1) set c } hello test io-15.1 {Tcl_CreateCloseHandler} emptyTest { } {} test io-16.1 {Tcl_DeleteCloseHandler} emptyTest { |
︙ | ︙ | |||
4782 4783 4784 4785 4786 4787 4788 | lappend l [fconfigure $f -buffersize] fconfigure $f -buffersize 100000 lappend l [fconfigure $f -buffersize] fconfigure $f -buffersize 10000000 lappend l [fconfigure $f -buffersize] close $f set l | | | 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 | lappend l [fconfigure $f -buffersize] fconfigure $f -buffersize 100000 lappend l [fconfigure $f -buffersize] fconfigure $f -buffersize 10000000 lappend l [fconfigure $f -buffersize] close $f set l } {4096 10000 1 1 1 100000 100000} test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { # This test crashes the interp if Bug #427196 is not fixed set chan [open [info script] r] fconfigure $chan -buffersize 10 set var [read $chan 2] fconfigure $chan -buffersize 32 |
︙ | ︙ | |||
7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 7111 7112 7113 7114 7115 7116 | #lappend res [read $f; tell $f] close $f set res } -cleanup { removeFile eofchar } -result {77 = 23431} # cleanup foreach file [list fooBar longfile script output test1 pipe my_script foo \ bar test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { removeFile $file } cleanupTests } namespace delete ::tcl::test::io return | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 7108 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 7123 7124 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 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 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 | #lappend res [read $f; tell $f] close $f set res } -cleanup { removeFile eofchar } -result {77 = 23431} # Test the cutting and splicing of channels, this is incidentially the # attach/detach facility of package Thread, but __without any # safeguards__. It can also be used to emulate transfer of channels # between threads, and is used for that here. test io-70.0 {Cutting & Splicing channels} {testchannel} { set f [makeFile {... dummy ...} cutsplice] set c [open $f r] set res {} lappend res [catch {seek $c 0 start}] testchannel cut $c lappend res [catch {seek $c 0 start}] testchannel splice $c lappend res [catch {seek $c 0 start}] close $c removeFile cutsplice set res } {0 1 0} # Duplicate of code in "thread.test". Find a better way of doing this # without duplication. Maybe placement into a proc which transforms to # nop after the first call, and placement of its defintion in a # central location. testConstraint testthread [expr {[info commands testthread] != {}}] if {[testConstraint testthread]} { testthread errorproc ThreadError proc ThreadError {id info} { global threadError set threadError $info } proc ThreadNullError {id info} { # ignore } } test io-70.1 {Transfer channel} {testchannel testthread} { set f [makeFile {... dummy ...} cutsplice] set c [open $f r] set res {} lappend res [catch {seek $c 0 start}] testchannel cut $c lappend res [catch {seek $c 0 start}] set tid [testthread create] testthread send $tid [list set c $c] lappend res [testthread send $tid { testchannel splice $c set res [catch {seek $c 0 start}] close $c set res }] tcltest::threadReap removeFile cutsplice set res } {0 1 0} # ### ### ### ######### ######### ######### foreach {n msg expected} { 0 {} {} 1 {{message only}} {{message only}} 2 {-options x} {-options x} 3 {-options {x y} {the message}} {-options {x y} {the message}} 4 {-code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 5 {-code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 6 {-code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7 {-code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 8 {-code error -level 0 -f ba snarf} {-code error -level 0 -f ba snarf} 9 {-code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 10 {-code error -level 5 -f ba snarf} {-code error -level 0 -f ba snarf} 11 {-code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 12 {-code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 13 {-code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 14 {-code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} 15 {-code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} 16 {-code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} 17 {-code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} 18 {-code error -level 0 -f ba} {-code error -level 0 -f ba} 19 {-code ok -level 0 -f ba} {-code 1 -level 0 -f ba} 20 {-code error -level 5 -f ba} {-code error -level 0 -f ba} 21 {-code ok -level 5 -f ba} {-code 1 -level 0 -f ba} 22 {-code boss -level 0 -f ba} {-code 1 -level 0 -f ba} 23 {-code boss -level 5 -f ba} {-code 1 -level 0 -f ba} 24 {-code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 25 {-code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 26 {-code error -level X -f ba snarf} {-code error -level 0 -f ba snarf} 27 {-code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 28 {-code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 29 {-code 1 -level X -f ba} {-code 1 -level 0 -f ba} 30 {-code 0 -level X -f ba} {-code 1 -level 0 -f ba} 31 {-code error -level X -f ba} {-code error -level 0 -f ba} 32 {-code ok -level X -f ba} {-code 1 -level 0 -f ba} 33 {-code boss -level X -f ba} {-code 1 -level 0 -f ba} 34 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} 35 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 36 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} 37 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 38 {-code 1 -code error -level 0 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} 39 {-code 1 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 40 {-code 1 -code error -level 5 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} 41 {-code 1 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 42 {-code 1 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 43 {-code 1 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 44 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba} 45 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} 46 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba} 47 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} 48 {-code 1 -code error -level 0 -f ba} {-code 1 -code error -level 0 -f ba} 49 {-code 1 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba} 50 {-code 1 -code error -level 5 -f ba} {-code 1 -code error -level 0 -f ba} 51 {-code 1 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba} 52 {-code 1 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba} 53 {-code 1 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba} 54 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} 55 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 56 {-code 1 -code error -level X -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} 57 {-code 1 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 58 {-code 1 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 59 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba} 60 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} 61 {-code 1 -code error -level X -f ba} {-code 1 -code error -level 0 -f ba} 62 {-code 1 -code ok -level X -f ba} {-code 1 -level 0 -f ba} 63 {-code 1 -code boss -level X -f ba} {-code 1 -level 0 -f ba} 64 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 65 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 66 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 67 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 68 {-code 0 -code error -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 69 {-code 0 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 70 {-code 0 -code error -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 71 {-code 0 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 72 {-code 0 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 73 {-code 0 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 74 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} 75 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} 76 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} 77 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} 78 {-code 0 -code error -level 0 -f ba} {-code 1 -level 0 -f ba} 79 {-code 0 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba} 80 {-code 0 -code error -level 5 -f ba} {-code 1 -level 0 -f ba} 81 {-code 0 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba} 82 {-code 0 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba} 83 {-code 0 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba} 84 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 85 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 86 {-code 0 -code error -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 87 {-code 0 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 88 {-code 0 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 89 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba} 90 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} 91 {-code 0 -code error -level X -f ba} {-code 1 -level 0 -f ba} 92 {-code 0 -code ok -level X -f ba} {-code 1 -level 0 -f ba} 93 {-code 0 -code boss -level X -f ba} {-code 1 -level 0 -f ba} 94 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} 95 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 96 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} 97 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 98 {-code error -code 1 -level 0 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} 99 {-code ok -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} a0 {-code error -code 1 -level 5 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} a1 {-code ok -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} a2 {-code boss -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} a3 {-code boss -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} a4 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba} a5 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} a6 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba} a7 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} a8 {-code error -code 1 -level 0 -f ba} {-code error -code 1 -level 0 -f ba} a9 {-code ok -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} b0 {-code error -code 1 -level 5 -f ba} {-code error -code 1 -level 0 -f ba} b1 {-code ok -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} b2 {-code boss -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} b3 {-code boss -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} b4 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} b5 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} b6 {-code error -code 1 -level X -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} b7 {-code ok -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} b8 {-code boss -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} b9 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba} c0 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba} c1 {-code error -code 1 -level X -f ba} {-code error -code 1 -level 0 -f ba} c2 {-code ok -code 1 -level X -f ba} {-code 1 -level 0 -f ba} c3 {-code boss -code 1 -level X -f ba} {-code 1 -level 0 -f ba} c4 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} c5 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} c6 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} c7 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} c8 {-code error -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} c9 {-code ok -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} d0 {-code error -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} d1 {-code ok -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} d2 {-code boss -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} d3 {-code boss -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} d4 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} d5 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} d6 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} d7 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} d8 {-code error -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} d9 {-code ok -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} e0 {-code error -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} e1 {-code ok -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} e2 {-code boss -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} e3 {-code boss -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} e4 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} e5 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} e6 {-code error -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} e7 {-code ok -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} e8 {-code boss -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} e9 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} f0 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} f1 {-code error -code 0 -level X -f ba} {-code 1 -level 0 -f ba} f2 {-code ok -code 0 -level X -f ba} {-code 1 -level 0 -f ba} f3 {-code boss -code 0 -level X -f ba} {-code 1 -level 0 -f ba} } { test io-71.$n {Tcl_SetChannelError} {testchannel} { set f [makeFile {... dummy ...} cutsplice] set c [open $f r] set res [testchannel setchannelerror $c [lrange $msg 0 end]] close $c removeFile cutsplice set res } [lrange $expected 0 end] test io-72.$n {Tcl_SetChannelErrorInterp} {testchannel} { set f [makeFile {... dummy ...} cutsplice] set c [open $f r] set res [testchannel setchannelerrorinterp $c [lrange $msg 0 end]] close $c removeFile cutsplice set res } [lrange $expected 0 end] } # ### ### ### ######### ######### ######### # cleanup foreach file [list fooBar longfile script output test1 pipe my_script foo \ bar test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { removeFile $file } cleanupTests } namespace delete ::tcl::test::io return |
Changes to tests/ioCmd.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, # fblocked, fconfigure, open, channel, fcopy # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # -*- tcl -*- # Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, # fblocked, fconfigure, open, channel, fcopy # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: ioCmd.test,v 1.21.2.2 2005/08/25 15:46:53 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } testConstraint fcopy [llength [info commands fcopy]] |
︙ | ︙ | |||
422 423 424 425 426 427 428 | } "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 | | > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } "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, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC}} test iocmd-12.8 {POSIX open access modes: errors} { list [catch {open $path(test3) {TRUNC CREAT}} msg] $msg } {1 {access mode must include either RDONLY, WRONLY, or RDWR}} close [open $path(test3) w] test iocmd-12.9 {POSIX open access modes: BINARY} { list [catch {open $path(test1) BINARY} msg] $msg } {1 {access mode must include either RDONLY, WRONLY, or RDWR}} test iocmd-12.10 {POSIX open access modes: BINARY} { set f [open $path(test1) {WRONLY BINARY TRUNC}] puts $f a puts $f b puts -nonewline $f c ;# contents are now 5 bytes: a\nb\nc close $f set f [open $path(test1) r] fconfigure $f -translation binary set result [string length [read $f]] close $f set result } 5 test iocmd-12.11 {POSIX open access modes: BINARY} { set f [open $path(test1) {WRONLY BINARY TRUNC}] puts $f \u0248 ;# gets truncated to \u0048 close $f set f [open $path(test1) r] fconfigure $f -translation binary set result [read -nonewline $f] close $f set result } \u0048 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?"}} |
︙ | ︙ | |||
448 449 450 451 452 453 454 455 456 457 458 459 460 461 | list [catch {open $path(test1) r+1} msg] $msg } {1 {illegal access mode "r+1"}} test iocmd-13.6 {errors in open command} { set msg [list [catch {open _non_existent_} msg] $msg $errorCode] regsub [file join {} _non_existent_] $msg "_non_existent_" msg string tolower $msg } {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} test iocmd-14.1 {file id parsing errors} { list [catch {eof gorp} msg] $msg $errorCode } {1 {can not find channel named "gorp"} NONE} test iocmd-14.2 {file id parsing errors} { list [catch {eof filex} msg] $msg } {1 {can not find channel named "filex"}} | > > > > > > > > > | 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 | list [catch {open $path(test1) r+1} msg] $msg } {1 {illegal access mode "r+1"}} test iocmd-13.6 {errors in open command} { set msg [list [catch {open _non_existent_} msg] $msg $errorCode] regsub [file join {} _non_existent_] $msg "_non_existent_" msg string tolower $msg } {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} test iocmd-13.7 {errors in open command} { list [catch {open $path(test1) b} msg] $msg } {1 {illegal access mode "b"}} test iocmd-13.8 {errors in open command} { list [catch {open $path(test1) rbb} msg] $msg } {1 {illegal access mode "rbb"}} test iocmd-13.9 {errors in open command} { list [catch {open $path(test1) r++} msg] $msg } {1 {illegal access mode "r++"}} test iocmd-14.1 {file id parsing errors} { list [catch {eof gorp} msg] $msg $errorCode } {1 {can not find channel named "gorp"} NONE} test iocmd-14.2 {file id parsing errors} { list [catch {eof filex} msg] $msg } {1 {can not find channel named "filex"}} |
︙ | ︙ | |||
534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 | test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg } {1 {expected integer but got "foo"}} close $rfile close $wfile # cleanup foreach file [list test1 test2 test3 test4] { removeFile $file } # delay long enough for background processes to finish after 500 foreach file [list test5] { removeFile $file } cleanupTests return | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg } {1 {expected integer but got "foo"}} close $rfile close $wfile # ### ### ### ######### ######### ######### ## Testing the reflected channel. test iocmd-20.0 {chan, wrong#args} { catch {chan} msg set msg } {wrong # args: should be "chan subcommand ?argument ...?"} test iocmd-20.1 {chan, unknown method} { catch {chan foo} msg set msg } {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, postevent, puts, read, seek, tell, or truncate} # --- --- --- --------- --------- --------- # chan create, and method "initalize" test iocmd-21.0 {chan create, wrong#args, not enough} { catch {chan create} msg set msg } {wrong # args: should be "chan create mode cmdprefix"} test iocmd-21.1 {chan create, wrong#args, too many} { catch {chan create a b c} msg set msg } {wrong # args: should be "chan create mode cmdprefix"} test iocmd-21.2 {chan create, invalid r/w mode, empty} { proc foo {} {} catch {chan create {} foo} msg rename foo {} set msg } {bad mode list: is empty} test iocmd-21.3 {chan create, invalid r/w mode, bad string} { proc foo {} {} catch {chan create {c} foo} msg rename foo {} set msg } {bad mode "c": must be read or write} test iocmd-21.4 {chan create, bad handler, not a list} { catch {chan create {r w} "foo \{"} msg set msg } {unmatched open brace in list} test iocmd-21.5 {chan create, bad handler, not a command} { catch {chan create {r w} foo} msg set msg } {Initialize failure: invalid command name "foo"} test iocmd-21.6 {chan create, initialize failed, bad signature} { proc foo {} {} catch {chan create {r w} foo} msg rename foo {} set msg } {Initialize failure: wrong # args: should be "foo"} test iocmd-21.7 {chan create, initialize failed, bad signature} { proc foo {} {} catch {chan create {r w} ::foo} msg rename foo {} set msg } {Initialize failure: wrong # args: should be "::foo"} test iocmd-21.8 {chan create, initialize failed, bad result, not a list} { proc foo {args} {return "\{"} catch {chan create {r w} foo} msg rename foo {} set msg } {Initialize failure: unmatched open brace in list} test iocmd-21.9 {chan create, initialize failed, bad result, not a list} { proc foo {args} {return \{\{\}} catch {chan create {r w} foo} msg rename foo {} set msg } {Initialize failure: unmatched open brace in list} test iocmd-21.10 {chan create, initialize failed, bad result, empty list} { proc foo {args} {} catch {chan create {r w} foo} msg rename foo {} set msg } {Initialize failure: Not all required methods supported} test iocmd-21.11 {chan create, initialize failed, bad result, bogus method name} { proc foo {args} {return 1} catch {chan create {r w} foo} msg rename foo {} set msg } {Initialize failure: bad method "1": must be blocking, cget, cgetall, configure, finalize, initialize, read, seek, watch, or write} test iocmd-21.12 {chan create, initialize failed, bad result, ambiguous method name} { proc foo {args} {return {a b c}} catch {chan create {r w} foo} msg rename foo {} set msg } {Initialize failure: ambiguous method "c": must be blocking, cget, cgetall, configure, finalize, initialize, read, seek, watch, or write} test iocmd-21.13 {chan create, initialize failed, bad result, required methods missing} { proc foo {args} {return {initialize finalize}} catch {chan create {r w} foo} msg rename foo {} set msg } {Initialize failure: Not all required methods supported} test iocmd-21.14 {chan create, initialize failed, bad result, mode/handler mismatch} { proc foo {args} {return {initialize finalize watch read}} catch {chan create {r w} foo} msg rename foo {} set msg } {Initialize failure: Writing not supported, but requested} test iocmd-21.15 {chan create, initialize failed, bad result, mode/handler mismatch} { proc foo {args} {return {initialize finalize watch write}} catch {chan create {r w} foo} msg rename foo {} set msg } {Initialize failure: Reading not supported, but requested} test iocmd-21.16 {chan create, initialize failed, bad result, cget(all) mismatch} { proc foo {args} {return {initialize finalize watch cget write read}} catch {chan create {r w} foo} msg rename foo {} set msg } {Initialize failure: 'cgetall' not supported, but should be, as 'cget' is} test iocmd-21.17 {chan create, initialize failed, bad result, cget(all) mismatch} { proc foo {args} {return {initialize finalize watch cgetall read write}} catch {chan create {r w} foo} msg rename foo {} set msg } {Initialize failure: 'cget' not supported, but should be, as 'cgetall' is} test iocmd-21.18 {chan create, initialize ok, creates channel} -match glob -body { proc foo {args} { global res lappend res $args if {[lindex $args 0] ne "initialize"} {return} return {initialize finalize watch read write} } set res {} lappend res [file channel rc*] lappend res [chan create {r w} foo] lappend res [close [lindex $res end]] lappend res [file channel rc*] rename foo {} set res } -result {{} {initialize rc* {read write}} rc* {finalize rc*} {} {}} test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match glob -body { proc foo {args} { global res lappend res $args return {} } set res {} lappend res [file channel rc*] lappend res [catch {chan create {r w} foo} msg] lappend res $msg lappend res [file channel rc*] rename foo {} set res } -result {{} {initialize rc* {read write}} 1 {Initialize failure: Not all required methods supported} {}} # --- --- --- --------- --------- --------- # Helper commands to record the arguments to handler methods. proc note {item} {global res ; lappend res $item ; return} proc track {} {upvar args item ; note $item; return} proc notes {items} {foreach i $items {note $i}} # Helper command, canned result for 'initialize' method. # Gets the optional methods as arguments. Use return features # to post the result higher up. proc init {args} { lappend args initialize finalize watch read write return -code return $args } proc oninit {args} { upvar args hargs if {[lindex $hargs 0] ne "initialize"} {return} lappend args initialize finalize watch read write return -code return $args } proc onfinal {} { upvar args hargs if {[lindex $hargs 0] ne "finalize"} {return} return -code return "" } # --- --- --- --------- --------- --------- # method finalize test iocmd-22.1 {chan finalize, handler destruction has no effect on channel} -match glob -body { set res {} proc foo {args} {track ; oninit; return} note [set c [chan create {r w} foo]] rename foo {} note [file channels rc*] note [catch {close $c} msg] ; note $msg note [file channels rc*] set res } -result {{initialize rc* {read write}} rc* rc* 1 {invalid command name "foo"} {}} test iocmd-22.2 {chan finalize, for close} -match glob -body { set res {} proc foo {args} {track ; oninit ; return {}} note [set c [chan create {r w} foo]] close $c # Close deleted the channel. note [file channels rc*] # Channel destruction does not kill handler command! note [info command foo] rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} test iocmd-22.3 {chan finalize, for close, error, close error} -match glob -body { set res {} proc foo {args} {track ; oninit ; return -code error 5} note [set c [chan create {r w} foo]] note [catch {close $c} msg] ; note $msg # Channel is gone despite error. note [file channels rc*] rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} test iocmd-22.4 {chan finalize, for close, error, close error} -match glob -body { set res {} proc foo {args} {track ; oninit ; error FOO} note [set c [chan create {r w} foo]] note [catch {close $c} msg] ; note $msg rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO} test iocmd-22.5 {chan finalize, for close, arbitrary result, ignored} -match glob -body { set res {} proc foo {args} {track ; oninit ; return SOMETHING} note [set c [chan create {r w} foo]] note [catch {close $c} msg]; note $msg rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} test iocmd-22.6 {chan finalize, for close, break, close error} -match glob -body { set res {} proc foo {args} {track ; oninit ; return -code 3} note [set c [chan create {r w} foo]] note [catch {close $c} msg] ; note $msg rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} test iocmd-22.7 {chan finalize, for close, continue, close error} -match glob -body { set res {} proc foo {args} {track ; oninit ; return -code 4} note [set c [chan create {r w} foo]] note [catch {close $c} msg] ; note $msg rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} test iocmd-22.8 {chan finalize, for close, custom code, close error} -match glob -body { set res {} proc foo {args} {track ; oninit ; return -code 777 BANG} note [set c [chan create {r w} foo]] note [catch {close $c} msg] ; note $msg rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG} test iocmd-22.9 {chan finalize, for close, ignore level, close error} -match glob -body { set res {} proc foo {args} {track ; oninit ; return -level 5 -code 777 BANG} note [set c [chan create {r w} foo]] note [catch {close $c} msg opt] ; note $msg ; note $opt rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} # --- === *** ########################### # method read test iocmd-23.1 {chan read, regular data return} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return snarf } set c [chan create {r w} foo] note [read $c 10] close $c rename foo {} set res } -result {{read rc* 4096} {read rc* 4096} snarfsnarf} test iocmd-23.2 {chan read, bad data return, to much} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return [string repeat snarf 1000] } set c [chan create {r w} foo] note [catch {read $c 2} msg] ; note $msg close $c rename foo {} set res } -result {{read rc* 4096} 1 {read delivered more than requested}} test iocmd-23.3 {chan read, for non-readable channel} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track note MUST_NOT_HAPPEN } set c [chan create {w} foo] note [catch {read $c 2} msg] ; note $msg close $c rename foo {} set res } -result {1 {channel "rc*" wasn't opened for reading}} test iocmd-23.4 {chan read, error return} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return -code error BOOM! } set c [chan create {r w} foo] note [catch {read $c 2} msg] ; note $msg close $c rename foo {} set res } -result {{read rc* 4096} 1 BOOM!} test iocmd-23.5 {chan read, break return is error} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return -code break BOOM! } set c [chan create {r w} foo] note [catch {read $c 2} msg] ; note $msg close $c rename foo {} set res } -result {{read rc* 4096} 1 BOOM!} test iocmd-23.6 {chan read, continue return is error} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return -code continue BOOM! } set c [chan create {r w} foo] note [catch {read $c 2} msg] ; note $msg close $c rename foo {} set res } -result {{read rc* 4096} 1 BOOM!} test iocmd-23.7 {chan read, custom return is error} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return -code 777 BOOM! } set c [chan create {r w} foo] note [catch {read $c 2} msg] ; note $msg close $c rename foo {} set res } -result {{read rc* 4096} 1 BOOM!} test iocmd-23.8 {chan read, level is squashed} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return -level 55 -code 777 BOOM! } set c [chan create {r w} foo] note [catch {read $c 2} msg opt] ; note $msg ; note $opt close $c rename foo {} set res } -result {{read rc* 4096} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} # --- === *** ########################### # method write test iocmd-24.1 {chan write, regular write} -match glob -body { set res {} proc foo {args} { oninit; onfinal ; track set written [string length [lindex $args 2]] note $written return $written } set c [chan create {r w} foo] puts -nonewline $c snarf ; flush $c close $c rename foo {} set res } -result {{write rc* snarf} 5} test iocmd-24.2 {chan write, partial write is ok} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track set written [string length [lindex $args 2]] if {$written > 10} {set written [expr {$written / 2}]} note $written return $written } set c [chan create {r w} foo] puts -nonewline $c snarfsnarfsnarf ; flush $c close $c rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} test iocmd-24.3 {chan write, failed write} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note -1 ; return -1} set c [chan create {r w} foo] puts -nonewline $c snarfsnarfsnarf ; flush $c close $c rename foo {} set res } -result {{write rc* snarfsnarfsnarf} -1} test iocmd-24.4 {chan write, non-writable channel} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r} foo] note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] ; note $msg close $c rename foo {} set res } -result {1 {channel "rc*" wasn't opened for writing}} test iocmd-24.5 {chan write, bad result, more written than data} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return 10000} set c [chan create {r w} foo] note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg close $c rename foo {} set res } -result {{write rc* snarf} 1 {write wrote more than requested}} test iocmd-24.6 {chan write, bad result, zero-length write} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return 0} set c [chan create {r w} foo] note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg close $c rename foo {} set res } -result {{write rc* snarf} 1 {write wrote more than requested}} test iocmd-24.7 {chan write, failed write, error return} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!} set c [chan create {r w} foo] note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] note $msg close $c rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} test iocmd-24.8 {chan write, failed write, error return} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; error BOOM!} set c [chan create {r w} foo] notes [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] note $msg close $c rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} test iocmd-24.9 {chan write, failed write, break return is error} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return -code break BOOM!} set c [chan create {r w} foo] note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] note $msg close $c rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} test iocmd-24.10 {chan write, failed write, continue return is error} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return -code continue BOOM!} set c [chan create {r w} foo] note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] note $msg close $c rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} test iocmd-24.11 {chan write, failed write, custom return is error} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return -code 777 BOOM!} set c [chan create {r w} foo] note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] note $msg close $c rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} test iocmd-24.12 {chan write, failed write, non-numeric return is error} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return BANG} set c [chan create {r w} foo] note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] note $msg close $c rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} test iocmd-24.13 {chan write, failed write, level is ignored} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return -level 55 -code 777 BOOM!} set c [chan create {r w} foo] note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg opt] note $msg note $opt close $c rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} # --- === *** ########################### # method cgetall test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r w} foo] note [fconfigure $c] close $c rename foo {} set res } -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall ; onfinal ; track ; return ""} set c [chan create {r w} foo] note [fconfigure $c] close $c rename foo {} set res } -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return "-bar foo -snarf x" } set c [chan create {r w} foo] note [fconfigure $c] close $c rename foo {} set res } -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return "-bar" } set c [chan create {r w} foo] note [catch {fconfigure $c} msg] ; note $msg close $c rename foo {} set res } -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} test iocmd-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return "\{" } set c [chan create {r w} foo] note [catch {fconfigure $c} msg] ; note $msg close $c rename foo {} set res } -result {{cgetall rc*} 1 {unmatched open brace in list}} test iocmd-25.6 {chan configure, cgetall, error return} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code error BOOM! } set c [chan create {r w} foo] note [catch {fconfigure $c} msg] ; note $msg close $c rename foo {} set res } -result {{cgetall rc*} 1 BOOM!} test iocmd-25.7 {chan configure, cgetall, break return is error} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code break BOOM! } set c [chan create {r w} foo] note [catch {fconfigure $c} msg] ; note $msg close $c rename foo {} set res } -result {{cgetall rc*} 1 BOOM!} test iocmd-25.8 {chan configure, cgetall, continue return is error} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code continue BOOM! } set c [chan create {r w} foo] note [catch {fconfigure $c} msg] ; note $msg close $c rename foo {} set res } -result {{cgetall rc*} 1 BOOM!} test iocmd-25.9 {chan configure, cgetall, custom return is error} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code 777 BOOM! } set c [chan create {r w} foo] note [catch {fconfigure $c} msg] ; note $msg close $c rename foo {} set res } -result {{cgetall rc*} 1 BOOM!} test iocmd-25.10 {chan configure, cgetall, level is ignored} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -level 55 -code 777 BANG } set c [chan create {r w} foo] note [catch {fconfigure $c} msg opt] ; note $msg ; note $opt close $c rename foo {} set res } -result {{cgetall rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} # --- === *** ########################### # method configure test iocmd-26.1 {chan configure, set standard option} -match glob -body { set res {} proc foo {args} { oninit configure ; onfinal ; track ; note MUST_NOT_HAPPEN return } set c [chan create {r w} foo] note [fconfigure $c -translation lf] close $c rename foo {} set res } -result {{}} test iocmd-26.2 {chan configure, set option, error return} -match glob -body { set res {} proc foo {args} { oninit configure ; onfinal ; track return -code error BOOM! } set c [chan create {r w} foo] note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg close $c rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 BOOM!} test iocmd-26.3 {chan configure, set option, ok return} -match glob -body { set res {} proc foo {args} {oninit configure ; onfinal ; track ; return} set c [chan create {r w} foo] note [fconfigure $c -rc-foo bar] close $c rename foo {} set res } -result {{configure rc* -rc-foo bar} {}} test iocmd-26.4 {chan configure, set option, break return is error} -match glob -body { set res {} proc foo {args} { oninit configure ; onfinal ; track return -code break BOOM! } set c [chan create {r w} foo] note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg close $c rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 BOOM!} test iocmd-26.5 {chan configure, set option, continue return is error} -match glob -body { set res {} proc foo {args} { oninit configure ; onfinal ; track return -code continue BOOM! } set c [chan create {r w} foo] note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg close $c rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 BOOM!} test iocmd-26.6 {chan configure, set option, custom return is error} -match glob -body { set res {} proc foo {args} { oninit configure ; onfinal ; track return -code 444 BOOM! } set c [chan create {r w} foo] note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg close $c rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 BOOM!} test iocmd-26.7 {chan configure, set option, level is ignored} -match glob -body { set res {} proc foo {args} { oninit configure ; onfinal ; track return -level 55 -code 444 BANG } set c [chan create {r w} foo] note [catch {fconfigure $c -rc-foo bar} msg opt] ; note $msg ; note $opt close $c rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} # --- === *** ########################### # method cget test iocmd-27.1 {chan configure, get option, ok return} -match glob -body { set res {} proc foo {args} {oninit cget cgetall ; onfinal ; track ; return foo} set c [chan create {r w} foo] note [fconfigure $c -rc-foo] close $c rename foo {} set res } -result {{cget rc* -rc-foo} foo} test iocmd-27.2 {chan configure, get option, error return} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code error BOOM! } set c [chan create {r w} foo] note [catch {fconfigure $c -rc-foo} msg] ; note $msg close $c rename foo {} set res } -result {{cget rc* -rc-foo} 1 BOOM!} test iocmd-27.3 {chan configure, get option, break return is error} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code error BOOM! } set c [chan create {r w} foo] note [catch {fconfigure $c -rc-foo} msg] ; note $msg close $c rename foo {} set res } -result {{cget rc* -rc-foo} 1 BOOM!} test iocmd-27.4 {chan configure, get option, continue return is error} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code continue BOOM! } set c [chan create {r w} foo] note [catch {fconfigure $c -rc-foo} msg] ; note $msg close $c rename foo {} set res } -result {{cget rc* -rc-foo} 1 BOOM!} test iocmd-27.5 {chan configure, get option, custom return is error} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code 333 BOOM! } set c [chan create {r w} foo] note [catch {fconfigure $c -rc-foo} msg] ; note $msg close $c rename foo {} set res } -result {{cget rc* -rc-foo} 1 BOOM!} test iocmd-27.6 {chan configure, get option, level is ignored} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -level 77 -code 333 BANG } set c [chan create {r w} foo] note [catch {fconfigure $c -rc-foo} msg opt] ; note $msg ; note $opt close $c rename foo {} set res } -result {{cget rc* -rc-foo} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} # --- === *** ########################### # method seek test iocmd-28.1 {chan tell, not supported by handler} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r w} foo] note [tell $c] close $c rename foo {} set res } -result {-1} test iocmd-28.2 {chan tell, error return} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!} set c [chan create {r w} foo] note [catch {tell $c} msg] ; note $msg close $c rename foo {} set res } -result {{seek rc* 0 current} 1 BOOM!} test iocmd-28.3 {chan tell, break return is error} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!} set c [chan create {r w} foo] note [catch {tell $c} msg] ; note $msg close $c rename foo {} set res } -result {{seek rc* 0 current} 1 BOOM!} test iocmd-28.4 {chan tell, continue return is error} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!} set c [chan create {r w} foo] note [catch {tell $c} msg] ; note $msg close $c rename foo {} set res } -result {{seek rc* 0 current} 1 BOOM!} test iocmd-28.5 {chan tell, custom return is error} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code 222 BOOM!} set c [chan create {r w} foo] note [catch {tell $c} msg] ; note $msg close $c rename foo {} set res } -result {{seek rc* 0 current} 1 BOOM!} test iocmd-28.6 {chan tell, level is ignored} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -level 11 -code 222 BANG} set c [chan create {r w} foo] note [catch {tell $c} msg opt] ; note $msg ; note $opt close $c rename foo {} set res } -result {{seek rc* 0 current} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} test iocmd-28.7 {chan tell, regular return} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return 88} set c [chan create {r w} foo] note [tell $c] close $c rename foo {} set res } -result {{seek rc* 0 current} 88} test iocmd-28.8 {chan tell, negative return} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -1} set c [chan create {r w} foo] note [catch {tell $c} msg] ; note $msg close $c rename foo {} set res } -result {{seek rc* 0 current} 1 {Tried to seek before origin}} test iocmd-28.9 {chan tell, string return} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS} set c [chan create {r w} foo] note [catch {tell $c} msg] ; note $msg close $c rename foo {} set res } -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} test iocmd-28.10 {chan seek, not supported by handler} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r w} foo] note [catch {seek $c 0 start} msg] ; note $msg close $c rename foo {} set res } -result {1 {error during seek on "rc*": invalid argument}} test iocmd-28.11 {chan seek, error return} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!} set c [chan create {r w} foo] note [catch {seek $c 0 start} msg] ; note $msg close $c rename foo {} set res } -result {{seek rc* 0 start} 1 BOOM!} test iocmd-28.12 {chan seek, break return is error} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!} set c [chan create {r w} foo] note [catch {seek $c 0 start} msg] ; note $msg close $c rename foo {} set res } -result {{seek rc* 0 start} 1 BOOM!} test iocmd-28.13 {chan seek, continue return is error} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!} set c [chan create {r w} foo] note [catch {seek $c 0 start} msg] ; note $msg close $c rename foo {} set res } -result {{seek rc* 0 start} 1 BOOM!} test iocmd-28.14 {chan seek, custom return is error} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code 99 BOOM!} set c [chan create {r w} foo] note [catch {seek $c 0 start} msg] ; note $msg close $c rename foo {} set res } -result {{seek rc* 0 start} 1 BOOM!} test iocmd-28.15 {chan seek, level is ignored} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -level 33 -code 99 BANG} set c [chan create {r w} foo] note [catch {seek $c 0 start} msg opt] ; note $msg ; note $opt close $c rename foo {} set res } -result {{seek rc* 0 start} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} test iocmd-28.16 {chan seek, bogus return, negative location} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -45} set c [chan create {r w} foo] note [catch {seek $c 0 start} msg] ; note $msg close $c rename foo {} set res } -result {{seek rc* 0 start} 1 {Tried to seek before origin}} test iocmd-28.17 {chan seek, bogus return, string return} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS} set c [chan create {r w} foo] note [catch {seek $c 0 start} msg] ; note $msg close $c rename foo {} set res } -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} test iocmd-28.18 {chan seek, ok result} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return 23} set c [chan create {r w} foo] note [seek $c 0 current] close $c rename foo {} set res } -result {{seek rc* 0 current} {}} foreach {n code} { 0 start 1 current 2 end } { test iocmd-28.19.$n "chan seek, base conversion, $code" -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return 0} set c [chan create {r w} foo] note [seek $c 0 $code] close $c rename foo {} set res } -result [list [list seek rc* 0 $code] {}] } # --- === *** ########################### # method blocking test iocmd-29.1 {chan blocking, no handler support} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r w} foo] note [fconfigure $c -blocking] close $c rename foo {} set res } -result {1} test iocmd-29.2 {chan blocking, no handler support} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r w} foo] note [fconfigure $c -blocking 0] note [fconfigure $c -blocking] close $c rename foo {} set res } -result {{} 0} test iocmd-29.3 {chan blocking, retrieval, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r w} foo] note [fconfigure $c -blocking] close $c rename foo {} set res } -result {1} test iocmd-29.4 {chan blocking, resetting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return} set c [chan create {r w} foo] note [fconfigure $c -blocking 0] note [fconfigure $c -blocking] close $c rename foo {} set res } -result {{blocking rc* 0} {} 0} test iocmd-29.5 {chan blocking, setting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return} set c [chan create {r w} foo] note [fconfigure $c -blocking 1] note [fconfigure $c -blocking] close $c rename foo {} set res } -result {{blocking rc* 1} {} 1} test iocmd-29.6 {chan blocking, error return} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; error BOOM!} set c [chan create {r w} foo] note [catch {fconfigure $c -blocking 0} msg] ; note $msg # Catch the close. It changes blocking mode internally, and runs into the error result. catch {close $c} rename foo {} set res } -result {{blocking rc* 0} 1 BOOM!} test iocmd-29.7 {chan blocking, break return is error} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return -code break BOOM!} set c [chan create {r w} foo] note [catch {fconfigure $c -blocking 0} msg] ; note $msg catch {close $c} rename foo {} set res } -result {{blocking rc* 0} 1 BOOM!} test iocmd-29.8 {chan blocking, continue return is error} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return -code continue BOOM!} set c [chan create {r w} foo] note [catch {fconfigure $c -blocking 0} msg] ; note $msg catch {close $c} rename foo {} set res } -result {{blocking rc* 0} 1 BOOM!} test iocmd-29.9 {chan blocking, custom return is error} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return -code 44 BOOM!} set c [chan create {r w} foo] note [catch {fconfigure $c -blocking 0} msg] ; note $msg catch {close $c} rename foo {} set res } -result {{blocking rc* 0} 1 BOOM!} test iocmd-29.10 {chan blocking, level is ignored} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return -level 99 -code 44 BANG} set c [chan create {r w} foo] note [catch {fconfigure $c -blocking 0} msg opt] ; note $msg ; note $opt catch {close $c} rename foo {} set res } -result {{blocking rc* 0} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} test iocmd-29.11 {chan blocking, regular return ok, value ignored} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return BOGUS} set c [chan create {r w} foo] note [catch {fconfigure $c -blocking 0} msg] ; note $msg catch {close $c} rename foo {} set res } -result {{blocking rc* 0} 0 {}} # --- === *** ########################### # method watch test iocmd-30.1 {chan watch, read interest, some return} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return IGNORED} set c [chan create {r w} foo] note [fileevent $c readable {set tick $tick}] close $c ;# 2nd watch, interest zero. rename foo {} set res } -result {{watch rc* read} {} {watch rc* {}}} test iocmd-30.2 {chan watch, write interest, error return} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!_IGNORED} set c [chan create {r w} foo] note [fileevent $c writable {set tick $tick}] note [fileevent $c writable {}] close $c rename foo {} set res } -result {{watch rc* write} {} {watch rc* {}} {}} test iocmd-30.3 {chan watch, accumulated interests} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return} set c [chan create {r w} foo] note [fileevent $c writable {set tick $tick}] note [fileevent $c readable {set tick $tick}] note [fileevent $c writable {}] note [fileevent $c readable {}] close $c rename foo {} set res } -result {{watch rc* write} {} {watch rc* {read write}} {} {watch rc* read} {} {watch rc* {}} {}} test iocmd-30.4 {chan watch, unchanged interest not forwarded} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return} set c [chan create {r w} foo] note [fileevent $c writable {set tick $tick}] note [fileevent $c readable {set tick $tick}] ;# Script is changing, note [fileevent $c readable {set tock $tock}] ;# interest does not. close $c ;# 3rd and 4th watch, removing the event handlers. rename foo {} set res } -result {{watch rc* write} {} {watch rc* {read write}} {} {} {watch rc* write} {watch rc* {}}} # --- === *** ########################### # chan postevent test iocmd-31.1 {chan postevent, restricted to reflected channels} -match glob -body { set c [open [makeFile {} goo] r] catch {chan postevent $c {r w}} msg close $c removeFile goo set msg } -result {channel "file*" is not a reflected channel} test iocmd-31.2 {chan postevent, unwanted events} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return} set c [chan create {r w} foo] catch {chan postevent $c {r w}} msg ; note $msg close $c rename foo {} set res } -result {{tried to post events channel "rc*" is not interested in}} test iocmd-31.3 {chan postevent, bad input, empty list} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return} set c [chan create {r w} foo] catch {chan postevent $c {}} msg ; note $msg close $c rename foo {} set res } -result {{bad event list: is empty}} test iocmd-31.4 {chan postevent, bad input, illlegal keyword} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return} set c [chan create {r w} foo] catch {chan postevent $c goo} msg ; note $msg close $c rename foo {} set res } -result {{bad event "goo": must be read or write}} test iocmd-31.5 {chan postevent, bad input, not a list} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return} set c [chan create {r w} foo] catch {chan postevent $c "\{"} msg ; note $msg close $c rename foo {} set res } -result {{unmatched open brace in list}} test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return} set c [chan create {r w} foo] note [fileevent $c readable {note TOCK}] set stop [after 10000 {note TIMEOUT}] after 1000 {note [chan postevent $c r]} vwait ::res catch {after cancel $stop} close $c rename foo {} set res } -result {{watch rc* read} {} TOCK {} {watch rc* {}}} test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return} set c [chan create {r w} foo] note [fileevent $c writable {note TOCK}] set stop [after 10000 {note TIMEOUT}] after 1000 {note [chan postevent $c w]} vwait ::res catch {after cancel $stop} close $c rename foo {} set res } -result {{watch rc* write} {} TOCK {} {watch rc* {}}} # ### ### ### ######### ######### ######### ## Same tests as above, but exercising the code forwarding and ## receiving driver operations to the originator thread. # -*- tcl -*- # ### ### ### ######### ######### ######### ## Testing the reflected channel (Thread forwarding). # ## The id numbers refer to the original test without thread ## forwarding, and gaps due to tests not applicable to forwarding are ## left to keep this asociation. testConstraint testchannel [llength [info commands testchannel]] # Duplicate of code in "thread.test". Find a better way of doing this # without duplication. Maybe placement into a proc which transforms to # nop after the first call, and placement of its defintion in a # central location. testConstraint testthread [expr {[info commands testthread] != {}}] if {[testConstraint testthread]} { testthread errorproc ThreadError proc ThreadError {id info} { global threadError set threadError $info } proc ThreadNullError {id info} { # ignore } } # ### ### ### ######### ######### ######### ## Helper command. Runs a script in a separate thread and returns the ## result. A channel is transfered into the thread as well, and list of ## configuation variables proc inthread {chan script args} { # Test thread. set tid [testthread create] # Init thread configuration. # - Listed variables # - Id of main thread # - A number of helper commands foreach v $args { upvar 1 $v x testthread send $tid [list set $v $x] } testthread send $tid [list set mid $tcltest::mainThread] testthread send $tid { proc note {item} {global notes ; lappend notes $item} proc notes {} {global notes ; return $notes} } testthread send $tid [list proc s {} [list uplevel 1 $script]] ; # (*) # Transfer channel (cut/splice aka detach/attach) testchannel cut $chan testthread send $tid [list testchannel splice $chan] # Run test script, also run local event loop! # The local event loop waits for the result to come back. # It is also necessary for the execution of forwarded channel # operations. set ::tres "" testthread send -async $tid { after 500 catch {s} res ; # This runs the script, 's' was defined at (*) testthread send -async $mid [list set ::tres $res] } vwait ::tres # Remove test thread, and return the captured result. tcltest::threadReap return $::tres } # ### ### ### ######### ######### ######### # ### ### ### ######### ######### ######### test iocmd.tf-22.2 {chan finalize, for close} -match glob -body { set res {} proc foo {args} {track ; oninit ; return {}} note [set c [chan create {r w} foo]] note [inthread $c { close $c # Close the deleted the channel. file channels rc* } c] # Channel destruction does not kill handler command! note [info command foo] rename foo {} set res } -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -body { set res {} proc foo {args} {track ; oninit ; return -code error 5} note [set c [chan create {r w} foo]] notes [inthread $c { note [catch {close $c} msg] ; note $msg # Channel is gone despite error. note [file channels rc*] notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob -body { set res {} proc foo {args} {track ; oninit ; error FOO} note [set c [chan create {r w} foo]] notes [inthread $c { note [catch {close $c} msg] ; note $msg notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO} test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -body { set res {} proc foo {args} {track ; oninit ; return SOMETHING} note [set c [chan create {r w} foo]] notes [inthread $c { note [catch {close $c} msg]; note $msg notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -body { set res {} proc foo {args} {track ; oninit ; return -code 3} note [set c [chan create {r w} foo]] notes [inthread $c { note [catch {close $c} msg] ; note $msg notes } c] rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} \ -constraints {testchannel testthread} test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob -body { set res {} proc foo {args} {track ; oninit ; return -code 4} note [set c [chan create {r w} foo]] notes [inthread $c { note [catch {close $c} msg] ; note $msg notes } c] rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} \ -constraints {testchannel testthread} test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match glob -body { set res {} proc foo {args} {track ; oninit ; return -code 777 BANG} note [set c [chan create {r w} foo]] notes [inthread $c { note [catch {close $c} msg] ; note $msg notes } c] rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG} \ -constraints {testchannel testthread} test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match glob -body { set res {} proc foo {args} {track ; oninit ; return -level 5 -code 777 BANG} note [set c [chan create {r w} foo]] notes [inthread $c { note [catch {close $c} msg opt] ; note $msg ; note $opt notes } c] rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ -constraints {testchannel testthread} # --- === *** ########################### # method read test iocmd.tf-23.1 {chan read, regular data return} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return snarf } set c [chan create {r w} foo] notes [inthread $c { note [read $c 10] close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return [string repeat snarf 1000] } set c [chan create {r w} foo] notes [inthread $c { note [catch {[read $c 2]} msg] ; note $msg close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{read rc* 4096} 1 {read delivered more than requested}} test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track note MUST_NOT_HAPPEN } set c [chan create {w} foo] notes [inthread $c { note [catch {[read $c 2]} msg] ; note $msg close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for reading}} test iocmd.tf-23.4 {chan read, error return} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return -code error BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {read $c 2} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{read rc* 4096} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-23.5 {chan read, break return is error} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return -code break BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {read $c 2} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{read rc* 4096} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return -code continue BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {read $c 2} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{read rc* 4096} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return -code 777 BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {read $c 2} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{read rc* 4096} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track return -level 55 -code 777 BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {read $c 2} msg opt] ; note $msg ; note $opt close $c notes } c] rename foo {} set res } -result {{read rc* 4096} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} \ -constraints {testchannel testthread} # --- === *** ########################### # method write test iocmd.tf-24.1 {chan write, regular write} -match glob -body { set res {} proc foo {args} { oninit; onfinal ; track set written [string length [lindex $args 2]] note $written return $written } set c [chan create {r w} foo] inthread $c { puts -nonewline $c snarf ; flush $c close $c } c rename foo {} set res } -constraints {testchannel testthread} -result {{write rc* snarf} 5} test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body { set res {} proc foo {args} { oninit ; onfinal ; track set written [string length [lindex $args 2]] if {$written > 10} {set written [expr {$written / 2}]} note $written return $written } set c [chan create {r w} foo] inthread $c { puts -nonewline $c snarfsnarfsnarf ; flush $c close $c } c rename foo {} set res } -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} test iocmd.tf-24.3 {chan write, failed write} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note -1 ; return -1} set c [chan create {r w} foo] inthread $c { puts -nonewline $c snarfsnarfsnarf ; flush $c close $c } c rename foo {} set res } -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} -1} test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r} foo] notes [inthread $c { note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for writing}} test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return 10000} set c [chan create {r w} foo] notes [inthread $c { note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}} test iocmd.tf-24.6 {chan write, zero writes} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return 0} set c [chan create {r w} foo] notes [inthread $c { note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}} test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] note $msg close $c notes } c] rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; error BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] note $msg close $c notes } c] rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return -code break BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] note $msg close $c notes } c] rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return -code continue BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] note $msg close $c notes } c] rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return -code 777 BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] note $msg close $c notes } c] rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return BANG} set c [chan create {r w} foo] notes [inthread $c { note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] note $msg close $c notes } c] rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} \ -constraints {testchannel testthread} test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return -level 55 -code 777 BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg opt] note $msg note $opt close $c notes } c] rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} \ -constraints {testchannel testthread} # --- === *** ########################### # method cgetall test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r w} foo] notes [inthread $c { note [fconfigure $c] close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} \ -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall ; onfinal ; track ; return ""} set c [chan create {r w} foo] notes [inthread $c { note [fconfigure $c] close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} \ -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return "-bar foo -snarf x" } set c [chan create {r w} foo] notes [inthread $c { note [fconfigure $c] close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} \ -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return "-bar" } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return "\{" } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{cgetall rc*} 1 {unmatched open brace in list}} test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code error BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{cgetall rc*} 1 BOOM!} test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code break BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{cgetall rc*} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code continue BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{cgetall rc*} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code 777 BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{cgetall rc*} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -level 55 -code 777 BANG } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c} msg opt] ; note $msg ; note $opt close $c notes } c] rename foo {} set res } -result {{cgetall rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ -constraints {testchannel testthread} # --- === *** ########################### # method configure test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body { set res {} proc foo {args} { oninit configure ; onfinal ; track ; note MUST_NOT_HAPPEN return } set c [chan create {r w} foo] notes [inthread $c { note [fconfigure $c -translation lf] close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{}} test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body { set res {} proc foo {args} { oninit configure ; onfinal ; track return -code error BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} 1 BOOM!} test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body { set res {} proc foo {args} {oninit configure ; onfinal ; track ; return} set c [chan create {r w} foo] notes [inthread $c { note [fconfigure $c -rc-foo bar] close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} {}} test iocmd.tf-26.4 {chan configure, set option, break return is error} -match glob -body { set res {} proc foo {args} { oninit configure ; onfinal ; track return -code break BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match glob -body { set res {} proc foo {args} { oninit configure ; onfinal ; track return -code continue BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match glob -body { set res {} proc foo {args} { oninit configure ; onfinal ; track return -code 444 BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -body { set res {} proc foo {args} { oninit configure ; onfinal ; track return -level 55 -code 444 BANG } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -rc-foo bar} msg opt] ; note $msg ; note $opt close $c notes } c] rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ -constraints {testchannel testthread} # --- === *** ########################### # method cget test iocmd.tf-27.1 {chan configure, get option, ok return} -match glob -body { set res {} proc foo {args} {oninit cget cgetall ; onfinal ; track ; return foo} set c [chan create {r w} foo] notes [inthread $c { note [fconfigure $c -rc-foo] close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{cget rc* -rc-foo} foo} test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code error BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -rc-foo} msg] ; note $msg close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{cget rc* -rc-foo} 1 BOOM!} test iocmd.tf-27.3 {chan configure, get option, break return is error} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code error BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -rc-foo} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{cget rc* -rc-foo} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code continue BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -rc-foo} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{cget rc* -rc-foo} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -code 333 BOOM! } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -rc-foo} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{cget rc* -rc-foo} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -body { set res {} proc foo {args} { oninit cget cgetall ; onfinal ; track return -level 77 -code 333 BANG } set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -rc-foo} msg opt] ; note $msg ; note $opt close $c notes } c] rename foo {} set res } -result {{cget rc* -rc-foo} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ -constraints {testchannel testthread} # --- === *** ########################### # method seek test iocmd.tf-28.1 {chan tell, not supported by handler} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r w} foo] notes [inthread $c { note [tell $c] close $c notes } c] rename foo {} set res } -result {-1} \ -constraints {testchannel testthread} test iocmd.tf-28.2 {chan tell, error return} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {tell $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{seek rc* 0 current} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {tell $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{seek rc* 0 current} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {tell $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{seek rc* 0 current} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code 222 BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {tell $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{seek rc* 0 current} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -level 11 -code 222 BANG} set c [chan create {r w} foo] notes [inthread $c { note [catch {tell $c} msg opt] ; note $msg ; note $opt close $c notes } c] rename foo {} set res } -result {{seek rc* 0 current} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ -constraints {testchannel testthread} test iocmd.tf-28.7 {chan tell, regular return} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return 88} set c [chan create {r w} foo] notes [inthread $c { note [tell $c] close $c notes } c] rename foo {} set res } -result {{seek rc* 0 current} 88} \ -constraints {testchannel testthread} test iocmd.tf-28.8 {chan tell, negative return} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -1} set c [chan create {r w} foo] notes [inthread $c { note [catch {tell $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{seek rc* 0 current} 1 {Tried to seek before origin}} \ -constraints {testchannel testthread} test iocmd.tf-28.9 {chan tell, string return} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS} set c [chan create {r w} foo] notes [inthread $c { note [catch {tell $c} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} \ -constraints {testchannel testthread} test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r w} foo] notes [inthread $c { note [catch {seek $c 0 start} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {1 {error during seek on "rc*": invalid argument}} \ -constraints {testchannel testthread} test iocmd.tf-28.11 {chan seek, error return} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {seek $c 0 start} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{seek rc* 0 start} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {seek $c 0 start} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{seek rc* 0 start} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {seek $c 0 start} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{seek rc* 0 start} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -code 99 BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {seek $c 0 start} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{seek rc* 0 start} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -level 33 -code 99 BANG} set c [chan create {r w} foo] notes [inthread $c { note [catch {seek $c 0 start} msg opt] ; note $msg ; note $opt close $c notes } c] rename foo {} set res } -result {{seek rc* 0 start} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ -constraints {testchannel testthread} test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return -45} set c [chan create {r w} foo] notes [inthread $c { note [catch {seek $c 0 start} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{seek rc* 0 start} 1 {Tried to seek before origin}} \ -constraints {testchannel testthread} test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS} set c [chan create {r w} foo] notes [inthread $c { note [catch {seek $c 0 start} msg] ; note $msg close $c notes } c] rename foo {} set res } -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} \ -constraints {testchannel testthread} test iocmd.tf-28.18 {chan seek, ok result} -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return 23} set c [chan create {r w} foo] notes [inthread $c { note [seek $c 0 current] close $c notes } c] rename foo {} set res } -result {{seek rc* 0 current} {}} \ -constraints {testchannel testthread} foreach {n code} { 0 start 1 current 2 end } { test iocmd.tf-28.19.$n "chan seek, base conversion, $code" -match glob -body { set res {} proc foo {args} {oninit seek ; onfinal ; track ; return 0} set c [chan create {r w} foo] notes [inthread $c { note [seek $c 0 $code] close $c notes } c code] rename foo {} set res } -result [list [list seek rc* 0 $code] {}] \ -constraints {testchannel testthread} } # --- === *** ########################### # method blocking test iocmd.tf-29.1 {chan blocking, no handler support} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r w} foo] notes [inthread $c { note [fconfigure $c -blocking] close $c notes } c] rename foo {} set res } -result {1} \ -constraints {testchannel testthread} test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r w} foo] notes [inthread $c { note [fconfigure $c -blocking 0] note [fconfigure $c -blocking] close $c notes } c] rename foo {} set res } -result {{} 0} \ -constraints {testchannel testthread} test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} set c [chan create {r w} foo] notes [inthread $c { note [fconfigure $c -blocking] close $c notes } c] rename foo {} set res } -result {1} \ -constraints {testchannel testthread} test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return} set c [chan create {r w} foo] notes [inthread $c { note [fconfigure $c -blocking 0] note [fconfigure $c -blocking] close $c notes } c] rename foo {} set res } -result {{blocking rc* 0} {} 0} \ -constraints {testchannel testthread} test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return} set c [chan create {r w} foo] notes [inthread $c { note [fconfigure $c -blocking 1] note [fconfigure $c -blocking] close $c notes } c] rename foo {} set res } -result {{blocking rc* 1} {} 1} \ -constraints {testchannel testthread} test iocmd.tf-29.6 {chan blocking, error return} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; error BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -blocking 0} msg] ; note $msg # Catch the close. It changes blocking mode internally, and runs into the error result. catch {close $c} notes } c] rename foo {} set res } -result {{blocking rc* 0} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return -code break BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -blocking 0} msg] ; note $msg catch {close $c} notes } c] rename foo {} set res } -result {{blocking rc* 0} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return -code continue BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -blocking 0} msg] ; note $msg catch {close $c} notes } c] rename foo {} set res } -result {{blocking rc* 0} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return -code 44 BOOM!} set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -blocking 0} msg] ; note $msg catch {close $c} notes } c] rename foo {} set res } -result {{blocking rc* 0} 1 BOOM!} \ -constraints {testchannel testthread} test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return -level 99 -code 44 BANG} set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -blocking 0} msg opt] ; note $msg ; note $opt catch {close $c} notes } c] rename foo {} set res } -result {{blocking rc* 0} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ -constraints {testchannel testthread} test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glob -body { set res {} proc foo {args} {oninit blocking ; onfinal ; track ; return BOGUS} set c [chan create {r w} foo] notes [inthread $c { note [catch {fconfigure $c -blocking 0} msg] ; note $msg catch {close $c} notes } c] rename foo {} set res } -result {{blocking rc* 0} 0 {}} \ -constraints {testchannel testthread} # --- === *** ########################### # method watch test iocmd.tf-30.1 {chan watch, read interest, some return} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return IGNORED} set c [chan create {r w} foo] notes [inthread $c { note [fileevent $c readable {set tick $tick}] close $c ;# 2nd watch, interest zero. notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{watch rc* read} {watch rc* {}} {}} test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!_IGNORED} set c [chan create {r w} foo] notes [inthread $c { note [fileevent $c writable {set tick $tick}] note [fileevent $c writable {}] close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} -result {{watch rc* write} {watch rc* {}} {} {}} test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return} set c [chan create {r w} foo] notes [inthread $c { note [fileevent $c writable {set tick $tick}] note [fileevent $c readable {set tick $tick}] note [fileevent $c writable {}] note [fileevent $c readable {}] close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} \ -result {{watch rc* write} {watch rc* {read write}} {watch rc* read} {watch rc* {}} {} {} {} {}} test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return} set c [chan create {r w} foo] notes [inthread $c { note [fileevent $c writable {set tick $tick}] note [fileevent $c readable {set tick $tick}] ;# Script is changing, note [fileevent $c readable {set tock $tock}] ;# interest does not. close $c ;# 3rd and 4th watch, removing the event handlers. notes } c] rename foo {} set res } -constraints {testchannel testthread} \ -result {{watch rc* write} {watch rc* {read write}} {watch rc* write} {watch rc* {}} {} {} {}} # --- === *** ########################### # postevent # Not possible from a thread not containing the command handler. # Check that this is rejected. test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body { set res {} proc foo {args} {oninit ; onfinal ; track ; return} set c [chan create {r w} foo] notes [inthread $c { catch {chan postevent $c r} msg ; note $msg close $c notes } c] rename foo {} set res } -constraints {testchannel testthread} \ -result {{postevent for channel "rc*" called from outside interpreter}} # ### ### ### ######### ######### ######### # ### ### ### ######### ######### ######### rename track {} # cleanup foreach file [list test1 test2 test3 test4] { removeFile $file } # delay long enough for background processes to finish after 500 foreach file [list test5] { removeFile $file } cleanupTests return |
Changes to tests/iogt.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # Commands covered: transform, and stacking in general # # This file contains a collection of tests for Giot # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2000 Ajuba Solutions. # Copyright (c) 2000 Andreas Kupries. # All rights reserved. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # -*- tcl -*- # Commands covered: transform, and stacking in general # # This file contains a collection of tests for Giot # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2000 Ajuba Solutions. # Copyright (c) 2000 Andreas Kupries. # All rights reserved. # # RCS: @(#) $Id: iogt.test,v 1.11.2.1 2005/04/25 21:37:29 kennykb Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." return } namespace eval ::tcl::test::iogt { |
︙ | ︙ | |||
494 495 496 497 498 499 500 | set fout [open $path(dummyout) w] set ain [list] ; set aout [list] audit_ops ain -attach $fin audit_ops aout -attach $fout fconfigure $fin -buffersize 10 | | | 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 | set fout [open $path(dummyout) w] set ain [list] ; set aout [list] audit_ops ain -attach $fin audit_ops aout -attach $fout fconfigure $fin -buffersize 10 fconfigure $fout -buffersize 10 fcopy $fin $fout close $fin close $fout set res "[join $ain \n]\n--------\n[join $aout \n]" |
︙ | ︙ | |||
544 545 546 547 548 549 550 | set fout [open $path(dummyout) w] set ain [list] ; set aout [list] audit_flow ain -attach $fin audit_flow aout -attach $fout fconfigure $fin -buffersize 10 | | | 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 | set fout [open $path(dummyout) w] set ain [list] ; set aout [list] audit_flow ain -attach $fin audit_flow aout -attach $fout fconfigure $fin -buffersize 10 fconfigure $fout -buffersize 10 fcopy $fin $fout close $fin close $fout set res "[join $ain \n]\n--------\n[join $aout \n]" |
︙ | ︙ |
Changes to tests/lindex.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: lindex.test,v 1.11.2.1 2005/05/05 17:56:17 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } set minus - |
︙ | ︙ | |||
45 46 47 48 49 50 51 | list [testevalex {lindex {{a b c} {d e f}} $x}] \ [testevalex {lindex {{a b c} {d e f}} $x}] } {f f} test lindex-2.4 {malformed index list} testevalex { set x \{ list [catch { testevalex {lindex {a b c} $x} } result] $result | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | list [testevalex {lindex {{a b c} {d e f}} $x}] \ [testevalex {lindex {{a b c} {d e f}} $x}] } {f f} test lindex-2.4 {malformed index list} testevalex { set x \{ list [catch { testevalex {lindex {a b c} $x} } result] $result } {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?} # Indices that are integers or convertible to integers test lindex-3.1 {integer -1} testevalex { set x ${minus}1 list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{} {}} |
︙ | ︙ | |||
72 73 74 75 76 77 78 | set x [string range 33 0 0] list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{} {}} test lindex-3.5 {bad octal} testevalex { set x 08 list [catch { testevalex {lindex {a b c} $x} } result] $result | | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | set x [string range 33 0 0] list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{} {}} test lindex-3.5 {bad octal} testevalex { set x 08 list [catch { testevalex {lindex {a b c} $x} } result] $result } {1 {bad index "08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test lindex-3.6 {bad octal} testevalex { set x -09 list [catch { testevalex {lindex {a b c} $x} } result] $result } {1 {bad index "-09": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test lindex-3.7 {indexes don't shimmer wide ints} { set x [expr {(wide(1)<<31) - 2}] list $x [lindex {1 2 3} $x] [incr x] [incr x] } {2147483646 {} 2147483647 2147483648} # Indices relative to end |
︙ | ︙ | |||
114 115 116 117 118 119 120 | set x end-3 list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{} {}} test lindex-4.6 {bad octal} testevalex { set x end-08 list [catch { testevalex {lindex {a b c} $x} } result] $result | | | | | | | | | 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 | set x end-3 list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{} {}} test lindex-4.6 {bad octal} testevalex { set x end-08 list [catch { testevalex {lindex {a b c} $x} } result] $result } {1 {bad index "end-08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test lindex-4.7 {bad octal} testevalex { set x end--09 list [catch { testevalex {lindex {a b c} $x} } result] $result } {1 {bad index "end--09": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-4.8 {bad integer, not octal} testevalex { set x end-0a2 list [catch { testevalex {lindex {a b c} $x} } result] $result } {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-4.9 {obsolete test} testevalex { set x end list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {c c} test lindex-4.10 {incomplete end-} testevalex { set x end- list [catch { testevalex {lindex {a b c} $x} } result] $result } {1 {bad index "end-": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-5.1 {bad second index} testevalex { list [catch { testevalex {lindex {a b c} 0 0a2} } result] $result } {1 {bad index "0a2": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-5.2 {good second index} testevalex { testevalex {lindex {{a b c} {d e f} {g h i}} 1 2} } f test lindex-5.3 {three indices} testevalex { testevalex {lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1} |
︙ | ︙ | |||
241 242 243 244 245 246 247 | } result set result } {f f} test lindex-10.4 {malformed index list} { set x \{ list [catch { lindex {a b c} $x } result] $result | | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | } result set result } {f f} test lindex-10.4 {malformed index list} { set x \{ list [catch { lindex {a b c} $x } result] $result } {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?} # Indices that are integers or convertible to integers test lindex-11.1 {integer -1} { set x ${minus}1 catch { list [lindex {a b c} $x] [lindex {a b c} $x] |
︙ | ︙ | |||
280 281 282 283 284 285 286 | } result set result } {{} {}} test lindex-11.5 {bad octal} { set x 08 list [catch { lindex {a b c} $x } result] $result | | | | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 | } result set result } {{} {}} test lindex-11.5 {bad octal} { set x 08 list [catch { lindex {a b c} $x } result] $result } {1 {bad index "08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test lindex-11.6 {bad octal} { set x -09 list [catch { lindex {a b c} $x } result] $result } {1 {bad index "-09": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} # Indices relative to end test lindex-12.1 {index = end} { set x end catch { list [lindex {a b c} $x] [lindex {a b c} $x] |
︙ | ︙ | |||
332 333 334 335 336 337 338 | } result set result } {{} {}} test lindex-12.6 {bad octal} { set x end-08 list [catch { lindex {a b c} $x } result] $result | | | | | | | | | 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 | } result set result } {{} {}} test lindex-12.6 {bad octal} { set x end-08 list [catch { lindex {a b c} $x } result] $result } {1 {bad index "end-08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test lindex-12.7 {bad octal} { set x end--09 list [catch { lindex {a b c} $x } result] $result } {1 {bad index "end--09": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-12.8 {bad integer, not octal} { set x end-0a2 list [catch { lindex {a b c} $x } result] $result } {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-12.9 {obsolete test} { set x end catch { list [lindex {a b c} $x] [lindex {a b c} $x] } result set result } {c c} test lindex-12.10 {incomplete end-} { set x end- list [catch { lindex {a b c} $x } result] $result } {1 {bad index "end-": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-13.1 {bad second index} { list [catch { lindex {a b c} 0 0a2 } result] $result } {1 {bad index "0a2": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-13.2 {good second index} { catch { lindex {{a b c} {d e f} {g h i}} 1 2 } result set result } f |
︙ | ︙ |
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 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 | # 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.7.6.1 2005/09/09 18:48:40 dgp 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 testlink set 43 1.23 4 - 12341234 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list $int $real $bool $string $wide } {43 1.23 1 NULL 12341234} test link-1.2 {reading C variables from Tcl} {testlink} { testlink delete testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set -3 2 0 "A long string with spaces" 43214321 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 list $int $real $bool $string $wide $int $real $bool $string $wide } {-3 2.0 0 {A long string with spaces} 43214321 -3 2.0 0 {A long string with spaces} 43214321} test link-2.1 {writing C variables from Tcl} {testlink} { testlink delete testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234 testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 set int "00721" set real -10.5 set bool true set string abcdef set wide 135135 set char 79 set uchar 161 set short 8000 set ushort 40000 set uint 0xc001babe set long 34543 set ulong 567890 set float 1.0987654321 set uwide 357357357357 concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide } {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 357357357357 | 00721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 357357357357} test link-2.2 {writing bad values into variables} {testlink} { testlink delete testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list [catch {set int 09a} msg] $msg $int } {1 {can't set "int": variable must have integer value} 43} test link-2.3 {writing bad values into variables} {testlink} { testlink delete testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list [catch {set real 1.x3} msg] $msg $real } {1 {can't set "real": variable must have real value} 1.23} test link-2.4 {writing bad values into variables} {testlink} { testlink delete testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list [catch {set bool gorp} msg] $msg $bool } {1 {can't set "bool": variable must have boolean value} 1} test link-2.5 {writing bad values into variables} {testlink} { testlink delete testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list [catch {set wide gorp} msg] $msg $bool } {1 {can't set "wide": variable must have integer value} 1} test link-3.1 {read-only variables} {testlink} { testlink delete testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 0 1 1 0 0 0 0 0 0 0 0 0 0 0 list [catch {set int 4} msg] $msg $int \ [catch {set real 10.6} msg] $msg $real \ [catch {set bool no} msg] $msg $bool \ [catch {set string "new value"} msg] $msg $string \ [catch {set wide 12341234} msg] $msg $wide } {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL 1 {can't set "wide": linked variable is read-only} 56785678} test link-3.2 {read-only variables} {testlink} { testlink delete testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 1 0 0 1 1 0 0 0 0 0 0 0 0 0 list [catch {set int 4} msg] $msg $int \ [catch {set real 10.6} msg] $msg $real \ [catch {set bool no} msg] $msg $bool \ [catch {set string "new value"} msg] $msg $string\ [catch {set wide 12341234} msg] $msg $wide } {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value} 0 12341234 12341234} test link-4.1 {unsetting linked variables} {testlink} { testlink delete testlink set -6 -2.5 0 stringValue 13579 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 unset int real bool string wide list [catch {set int} msg] $msg [catch {set real} msg] $msg \ [catch {set bool} msg] $msg [catch {set string} msg] $msg \ [catch {set wide} msg] $msg } {0 -6 0 -2.5 0 0 0 stringValue 0 13579} test link-4.2 {unsetting linked variables} {testlink} { testlink delete testlink set -6 -2.1 0 stringValue 97531 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 unset int real bool string wide set int 102 set real 16 set bool true set string newValue set wide 333555 lrange [testlink get] 0 4 } {102 16.0 1 newValue 333555} test link-5.1 {unlinking variables} {testlink} { testlink delete testlink set -6 -2.25 0 stringValue 13579 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink delete set int xx1 set real qrst set bool bogus set string 12345 set wide 875421 set char skjdf set uchar dslfjk set short slkf set ushort skrh set uint sfdkfkh set long srkjh set ulong sjkg set float dskjfbjfd set uwide isdfsngs testlink get } {-6 -2.25 0 stringValue 13579 64 250 30000 60000 -1091585346 12321 32123 3.25 1231231234} test link-5.2 {unlinking variables} {testlink} { testlink delete testlink set -6 -2.25 0 stringValue 97531 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink delete testlink set 25 14.7 7 - 999999 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340 list $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide } {-6 -2.25 0 stringValue 97531 64 250 30000 60000 3203381950 12321 32123 3.25 1231231234} test link-6.1 {errors in setting up link} {testlink} { testlink delete catch {unset int} set int(44) 1 list [catch {testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1} msg] $msg } {1 {can't set "int": variable is array}} catch {unset int} test link-7.1 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y unset y } testlink delete testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0 testlink set 14 {} {} {} {} {} {} {} {} {} {} {} {} {} x list [catch {set int} msg] $msg } {0 14} test link-7.2 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y return [set y] } testlink delete testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0 testlink set 0 {} {} {} {} {} {} {} {} {} {} {} {} {} set int testlink set 23 {} {} {} {} {} {} {} {} {} {} {} {} {} x list [x] $int } {23 23} test link-7.3 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y set y 44 } testlink delete testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0 testlink set 11 {} {} {} {} {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $int } {1 {can't set "y": linked variable is read-only} 11} test link-7.4 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y set y abc } testlink delete testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set -4 {} {} {} {} {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $int } {1 {can't set "y": variable must have integer value} -4} test link-7.5 {access to linked variables via upvar} {testlink} { proc x {} { upvar real y set y abc } testlink delete testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set -4 16.75 {} {} {} {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $real } {1 {can't set "y": variable must have real value} 16.75} test link-7.6 {access to linked variables via upvar} {testlink} { proc x {} { upvar bool y set y abc } testlink delete testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set -4 16.3 1 {} {} {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $bool } {1 {can't set "y": variable must have boolean value} 1} test link-7.7 {access to linked variables via upvar} {testlink} { proc x {} { upvar wide y set y abc } testlink delete testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $wide } {1 {can't set "y": variable must have integer value} 778899} test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { global x int real bool string wide lappend x $args $int $real $bool $string $wide } set x {} testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 trace var int w x testlink update 32 4.0 3 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340 trace vdelete int w x set x } {{int {} w} 32 -2.0 0 xyzzy 995511} test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { global x int real bool string wide lappend x $args $int $real $bool $string $wide } set x {} testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink delete trace var int w x testlink update 32 4.0 6 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340 trace vdelete int w x set x } {} test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0 list [catch { testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {} } msg] $msg $int } {0 {} 47} catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0} catch {testlink delete} foreach i {int real bool string wide} { catch {unset $i} } # cleanup ::tcltest::cleanupTests return |
Changes to tests/linsert.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: linsert # # 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: linsert # # 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: linsert.test,v 1.8.28.1 2005/05/05 17:56:18 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } catch {unset lis} |
︙ | ︙ | |||
86 87 88 89 90 91 92 | list [catch linsert msg] $msg } {1 {wrong # args: should be "linsert list index element ?element ...?"}} test linsert-2.2 {linsert errors} { list [catch {linsert a b} msg] $msg } {1 {wrong # args: should be "linsert list index element ?element ...?"}} test linsert-2.3 {linsert errors} { list [catch {linsert a 12x 2} msg] $msg | | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | list [catch linsert msg] $msg } {1 {wrong # args: should be "linsert list index element ?element ...?"}} test linsert-2.2 {linsert errors} { list [catch {linsert a b} msg] $msg } {1 {wrong # args: should be "linsert list index element ?element ...?"}} test linsert-2.3 {linsert errors} { list [catch {linsert a 12x 2} msg] $msg } {1 {bad index "12x": must be integer?[+-]integer? or end?[+-]integer?}} test linsert-2.4 {linsert errors} { list [catch {linsert \{ 12 2} msg] $msg } {1 {unmatched open brace in list}} test linsert-3.1 {linsert won't modify shared argument objects} { proc p {} { linsert "a b c" 1 "x y" |
︙ | ︙ |
Changes to tests/listObj.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Functionality covered: operation of the procedures in tclListObj.c that # implement the Tcl type manager for the list object type. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | < < | < < | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | # Functionality covered: operation of the procedures in tclListObj.c that # implement the Tcl type manager for the list object type. # # 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: listObj.test,v 1.6.2.2 2005/08/02 18:16:41 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } catch {unset x} test listobj-1.1 {Tcl_GetListObjType} emptyTest { # Test removed; tested an internal detail # that's no longer correct, and duplicated test obj-1.1 } {} test listobj-2.1 {Tcl_SetListObj, use in lappend} { catch {unset x} list [lappend x 1 abc def] [lappend x 1 ghi jkl] $x } {{1 abc def} {1 abc def 1 ghi jkl} {1 abc def 1 ghi jkl}} test listobj-2.2 {Tcl_SetListObj, use in ObjInterpProc} { proc return_args {args} { |
︙ | ︙ |
Changes to tests/load.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: load # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # Commands covered: load # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: load.test,v 1.13.2.1 2005/08/02 18:16:41 dgp 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 |
︙ | ︙ | |||
125 126 127 128 129 130 131 | set result [info loaded x] interp delete x set result } [list [list [file join $testDir pkga$ext] Pkga]] # On some platforms, like SunOS 4.1.3, these tests can't be run because # they cause the process to exit. | | > > | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | set result [info loaded x] interp delete x set result } [list [list [file join $testDir pkga$ext] Pkga]] # On some platforms, like SunOS 4.1.3, these tests can't be run because # they cause the process to exit. # # As of 2005, such ancient broken systems no longer matter. test load-6.1 {errors loading file} [list $dll $loaded] { catch {load foo foo} } {1} test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] { set x "not loaded" teststaticpkg Test 1 0 load {} Test |
︙ | ︙ |
Changes to tests/lrange.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: lrange # # 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: lrange # # 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: lrange.test,v 1.7.28.1 2005/05/05 17:56:18 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } test lrange-1.1 {range of list elements} { |
︙ | ︙ | |||
39 40 41 42 43 44 45 | test lrange-1.7 {range of list elements} { lrange {a b c d e} -1 2 } {a b c} test lrange-1.8 {range of list elements} { lrange {a b c d e} -2 -1 } {} test lrange-1.9 {range of list elements} { | | | | | | 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 | test lrange-1.7 {range of list elements} { lrange {a b c d e} -1 2 } {a b c} test lrange-1.8 {range of list elements} { lrange {a b c d e} -2 -1 } {} test lrange-1.9 {range of list elements} { lrange {a b c d e} -2 end } {a b c d e} test lrange-1.10 {range of list elements} { lrange "a b\{c d" 1 2 } "b\\{c d" test lrange-1.11 {range of list elements} { lrange "a b c d" end end } d test lrange-1.12 {range of list elements} { lrange "a b c d" end 100000 } d test lrange-1.13 {range of list elements} { lrange "a b c d" end 3 } d test lrange-1.14 {range of list elements} { lrange "a b c d" end 2 } {} test lrange-1.15 {range of list elements} { concat \"[lrange {a b \{\ } 0 2]" } {"a b \{\ "} test lrange-1.16 {list element quoting} { lrange {[append a .b]} 0 end } {{[append} a .b\]} test lrange-2.1 {error conditions} { list [catch {lrange a b} msg] $msg } {1 {wrong # args: should be "lrange list first last"}} test lrange-2.2 {error conditions} { list [catch {lrange a b 6 7} msg] $msg } {1 {wrong # args: should be "lrange list first last"}} test lrange-2.3 {error conditions} { list [catch {lrange a b 6} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} test lrange-2.4 {error conditions} { list [catch {lrange a 0 enigma} msg] $msg } {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}} test lrange-2.5 {error conditions} { list [catch {lrange "a \{b c" 3 4} msg] $msg } {1 {unmatched open brace in list}} test lrange-2.6 {error conditions} { list [catch {lrange "a b c \{ d e" 1 4} msg] $msg } {1 {unmatched open brace in list}} # cleanup ::tcltest::cleanupTests return |
Changes to tests/lreplace.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: lreplace # # 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: lreplace # # 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: lreplace.test,v 1.7.28.1 2005/05/05 17:56:18 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } test lreplace-1.1 {lreplace command} { |
︙ | ︙ | |||
106 107 108 109 110 111 112 | list [catch lreplace msg] $msg } {1 {wrong # args: should be "lreplace list first last ?element element ...?"}} test lreplace-2.2 {lreplace errors} { list [catch {lreplace a b} msg] $msg } {1 {wrong # args: should be "lreplace list first last ?element element ...?"}} test lreplace-2.3 {lreplace errors} { list [catch {lreplace x a 10} msg] $msg | | | | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | list [catch lreplace msg] $msg } {1 {wrong # args: should be "lreplace list first last ?element element ...?"}} test lreplace-2.2 {lreplace errors} { list [catch {lreplace a b} msg] $msg } {1 {wrong # args: should be "lreplace list first last ?element element ...?"}} test lreplace-2.3 {lreplace errors} { list [catch {lreplace x a 10} msg] $msg } {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}} test lreplace-2.4 {lreplace errors} { list [catch {lreplace x 10 x} msg] $msg } {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}} test lreplace-2.5 {lreplace errors} { list [catch {lreplace x 10 1x} msg] $msg } {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}} test lreplace-2.6 {lreplace errors} { list [catch {lreplace x 3 2} msg] $msg } {1 {list doesn't contain element 3}} test lreplace-2.7 {lreplace errors} { list [catch {lreplace x 1 1} msg] $msg } {1 {list doesn't contain element 1}} |
︙ | ︙ |
Changes to tests/lsearch.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: lsearch # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Commands covered: lsearch # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: lsearch.test,v 1.13.2.2 2005/07/12 20:37:11 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } set x {abcd bbcd 123 234 345} |
︙ | ︙ | |||
57 58 59 60 61 62 63 | lsearch -glob {xyz bbcc *bc*} *bc* } 1 test lsearch-2.9 {search modes} { lsearch -glob {b.x ^bc xy bcx} ^bc } 1 test lsearch-2.10 {search modes} { list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg | | > > > > > > > > > > > > > > > > > > | | | 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 | lsearch -glob {xyz bbcc *bc*} *bc* } 1 test lsearch-2.9 {search modes} { lsearch -glob {b.x ^bc xy bcx} ^bc } 1 test lsearch-2.10 {search modes} { list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg } {1 {bad option "-glib": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} test lsearch-2.11 {search modes with -nocase} { lsearch -exact -nocase {a b c A B C} A } 0 test lsearch-2.12 {search modes with -nocase} { lsearch -glob -nocase {a b c A B C} A* } 0 test lsearch-2.13 {search modes with -nocase} { lsearch -regexp -nocase {a b c A B C} ^A\$ } 0 test lsearch-2.14 {search modes without -nocase} { lsearch -exact {a b c A B C} A } 3 test lsearch-2.15 {search modes without -nocase} { lsearch -glob {a b c A B C} A* } 3 test lsearch-2.16 {search modes without -nocase} { lsearch -regexp {a b c A B C} ^A\$ } 3 test lsearch-3.1 {lsearch errors} { list [catch lsearch msg] $msg } {1 {wrong # args: should be "lsearch ?options? list pattern"}} test lsearch-3.2 {lsearch errors} { list [catch {lsearch a} msg] $msg } {1 {wrong # args: should be "lsearch ?options? list pattern"}} test lsearch-3.3 {lsearch errors} { list [catch {lsearch a b c} msg] $msg } {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} test lsearch-3.4 {lsearch errors} { list [catch {lsearch a b c d} msg] $msg } {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} test lsearch-3.5 {lsearch errors} { list [catch {lsearch "\{" b} msg] $msg } {1 {unmatched open brace in list}} test lsearch-3.6 {lsearch errors} { list [catch {lsearch -index a b} msg] $msg } {1 {"-index" option must be followed by list index}} test lsearch-3.7 {lsearch errors} { |
︙ | ︙ | |||
280 281 282 283 284 285 286 | lsearch -start 2 {a b c d e f} a } -1 test lsearch-10.3 {offset searching} { lsearch -start end-4 {a b c a b c} a } 3 test lsearch-10.4 {offset searching} { list [catch {lsearch -start foobar {a b c a b c} a} msg] $msg | | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 | lsearch -start 2 {a b c d e f} a } -1 test lsearch-10.3 {offset searching} { lsearch -start end-4 {a b c a b c} a } 3 test lsearch-10.4 {offset searching} { list [catch {lsearch -start foobar {a b c a b c} a} msg] $msg } {1 {bad index "foobar": must be integer?[+-]integer? or end?[+-]integer?}} test lsearch-10.5 {offset searching} { list [catch {lsearch -start 1 2} msg] $msg } {1 {missing starting index}} test lsearch-10.6 {binary search with offset} { set res {} for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -integer -start 2 -sorted $increasingIntegers $i] |
︙ | ︙ | |||
316 317 318 319 320 321 322 323 324 325 326 327 328 329 | test lsearch-13.1 {search for all matches} { lsearch -all {a b a c a d} 1 } {} test lsearch-13.2 {search for all matches} { lsearch -all {a b a c a d} a } {0 2 4} test lsearch-14.1 {combinations: -all and -inline} { lsearch -all -inline -glob {a1 b2 a3 c4 a5 d6} a* } {a1 a3 a5} test lsearch-14.2 {combinations: -all, -inline and -not} { lsearch -all -inline -not -glob {a1 b2 a3 c4 a5 d6} a* } {b2 c4 d6} | > > > > > > > > > | 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 | test lsearch-13.1 {search for all matches} { lsearch -all {a b a c a d} 1 } {} test lsearch-13.2 {search for all matches} { lsearch -all {a b a c a d} a } {0 2 4} test lsearch-13.3 {search for all matches with -nocase} { lsearch -all -exact -nocase {a b c A B C} A } {0 3} test lsearch-13.4 {search for all matches with -nocase} { lsearch -all -glob -nocase {a b c A B C} A* } {0 3} test lsearch-13.5 {search for all matches with -nocase} { lsearch -all -regexp -nocase {a b c A B C} ^A\$ } {0 3} test lsearch-14.1 {combinations: -all and -inline} { lsearch -all -inline -glob {a1 b2 a3 c4 a5 d6} a* } {a1 a3 a5} test lsearch-14.2 {combinations: -all, -inline and -not} { lsearch -all -inline -not -glob {a1 b2 a3 c4 a5 d6} a* } {b2 c4 d6} |
︙ | ︙ | |||
411 412 413 414 415 416 417 | } {{0 0 0} {1 0 0}} test lsearch-20.1 {lsearch -index option, index larger than sublists} { list [catch {lsearch -index 2 {{a c} {a b} {a a}} a} msg] $msg } {1 {element 2 missing from sublist "a c"}} test lsearch-20.2 {lsearch -index option, malformed index} { list [catch {lsearch -index foo {{a c} {a b} {a a}} a} msg] $msg | | | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 | } {{0 0 0} {1 0 0}} test lsearch-20.1 {lsearch -index option, index larger than sublists} { list [catch {lsearch -index 2 {{a c} {a b} {a a}} a} msg] $msg } {1 {element 2 missing from sublist "a c"}} test lsearch-20.2 {lsearch -index option, malformed index} { list [catch {lsearch -index foo {{a c} {a b} {a a}} a} msg] $msg } {1 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}} test lsearch-20.3 {lsearch -index option, malformed index} { list [catch {lsearch -index \{ {{a c} {a b} {a a}} a} msg] $msg } {1 {unmatched open brace in list}} # cleanup catch {unset res} catch {unset increasingIntegers} |
︙ | ︙ |
Changes to tests/lset.test.
︙ | ︙ | |||
47 48 49 50 51 52 53 | } {{3 1 2} {3 1 2}} test lset-2.2 {lset, not compiled, 3 args, second arg neither index nor list} testevalex { set x {0 1 2} list [catch { testevalex {lset x {{bad}1} 3} } msg] $msg | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | } {{3 1 2} {3 1 2}} test lset-2.2 {lset, not compiled, 3 args, second arg neither index nor list} testevalex { set x {0 1 2} list [catch { testevalex {lset x {{bad}1} 3} } msg] $msg } {1 {bad index "{bad}1": must be integer?[+-]integer? or end?[+-]integer?}} test lset-3.1 {lset, not compiled, 3 args, data duplicated} testevalex { set x {0 1 2} list [testevalex {lset x 0 $x}] $x } {{{0 1 2} 1 2} {{0 1 2} 1 2}} test lset-3.2 {lset, not compiled, 3 args, data duplicated} testevalex { |
︙ | ︙ | |||
95 96 97 98 99 100 101 | } {1 {unmatched open brace in list}} test lset-4.2 {lset, not compiled, 3 args, bad index} testevalex { set a {x y z} list [catch { testevalex {lset a [list 2a2] w} } msg] $msg | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | } {1 {unmatched open brace in list}} test lset-4.2 {lset, not compiled, 3 args, bad index} testevalex { set a {x y z} list [catch { testevalex {lset a [list 2a2] w} } msg] $msg } {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}} test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a [list -1] w} } msg] $msg } {1 {list index out of range}} |
︙ | ︙ | |||
137 138 139 140 141 142 143 | } {1 {unmatched open brace in list}} test lset-4.8 {lset, not compiled, 3 args, bad index} testevalex { set a {x y z} list [catch { testevalex {lset a 2a2 w} } msg] $msg | | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | } {1 {unmatched open brace in list}} test lset-4.8 {lset, not compiled, 3 args, bad index} testevalex { set a {x y z} list [catch { testevalex {lset a 2a2 w} } msg] $msg } {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}} test lset-4.9 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a -1 w} } msg] $msg } {1 {list index out of range}} |
︙ | ︙ | |||
296 297 298 299 300 301 302 | set a [list "a \{" b] list [catch {testevalex {lset a {0 1} c}} msg] $msg } {1 {unmatched open brace in list}} test lset-8.3 {lset, not compiled, bad second index} testevalex { set a {{b c} {d e}} list [catch {testevalex {lset a 0 2a2 f}} msg] $msg | | | | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | set a [list "a \{" b] list [catch {testevalex {lset a {0 1} c}} msg] $msg } {1 {unmatched open brace in list}} test lset-8.3 {lset, not compiled, bad second index} testevalex { set a {{b c} {d e}} list [catch {testevalex {lset a 0 2a2 f}} msg] $msg } {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}} test lset-8.4 {lset, not compiled, bad second index} testevalex { set a {{b c} {d e}} list [catch {testevalex {lset a {0 2a2} f}} msg] $msg } {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}} test lset-8.5 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a 2 -1 h}} msg] $msg } {1 {list index out of range}} test lset-8.6 {lset, not compiled, second index out of range} testevalex { |
︙ | ︙ |
Changes to tests/main.test.
1 2 | # This file contains a collection of tests for generic/tclMain.c. # | | | 1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for generic/tclMain.c. # # RCS: @(#) $Id: main.test,v 1.15.2.1 2005/05/05 17:56:19 kennykb 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 { |
︙ | ︙ | |||
901 902 903 904 905 906 907 908 909 910 911 912 913 914 | close stdin} >& result set f [open result] read $f } -cleanup { close $f file delete result } -result "1\n% " # Tests Tcl_Main-7.*: exiting test Tcl_Main-7.1 { Tcl_Main: [exit] defined as no-op -> still have exithandlers } -constraints { exec Tcltest | > > > > > > > > > > > > > > > > | 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 | close stdin} >& result set f [open result] read $f } -cleanup { close $f file delete result } -result "1\n% " test Tcl_Main-6.7 { [unknown]: interactive auto-completion. } -constraints { exec } -body { exec [interpreter] << { proc foo\{ x {} set tcl_interactive 1 foo y} >& result set f [open result] read $f } -cleanup { close $f file delete result } -result "1\n% % " # Tests Tcl_Main-7.*: exiting test Tcl_Main-7.1 { Tcl_Main: [exit] defined as no-op -> still have exithandlers } -constraints { exec Tcltest |
︙ | ︙ |
Changes to tests/msgcat.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. # | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # # 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.16.2.1 2004/12/08 18:24:36 kennykb 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.4.1}]} { |
︙ | ︙ | |||
392 393 394 395 396 397 398 | set msgdir [makeDirectory msgdir] foreach loc $locales { if { $loc eq {} } { set msg ROOT } else { set msg [string tolower $loc] } | | < | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 | set msgdir [makeDirectory msgdir] foreach loc $locales { if { $loc eq {} } { set msg ROOT } else { set msg [string tolower $loc] } makeFile [list ::msgcat::mcset $loc abc abc-$loc] $msg.msg $msgdir } variable count 1 foreach loc {foo foo_BAR foo_BAR_baz} { test msgcat-5.$count {mcload} -setup { variable locale [mclocale] mclocale $loc } -cleanup { |
︙ | ︙ | |||
490 491 492 493 494 495 496 | foreach loc $locales { if { $loc eq {} } { set msg ROOT } else { set msg [string tolower $loc] } | | | 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 | foreach loc $locales { if { $loc eq {} } { set msg ROOT } else { set msg [string tolower $loc] } removeFile $msg.msg $msgdir } 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 |
︙ | ︙ |
Changes to tests/namespace.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Functionality covered: this file contains a collection of tests for the # procedures in tclNamesp.c that implement Tcl's basic support for # namespaces. Other namespace-related tests appear in variable.test. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Functionality covered: this file contains a collection of tests for the # procedures in tclNamesp.c that implement Tcl's basic support for # namespaces. Other namespace-related tests appear in variable.test. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: namespace.test,v 1.43.2.1 2005/07/12 20:37:12 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # Clear out any namespaces called test_ns_* |
︙ | ︙ | |||
240 241 242 243 244 245 246 | namespace import ::test_ns_export::* proc p {} {return [cmd1 123]} } test_ns_import::p } {cmd1: 123} test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} { list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg | | | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 | namespace import ::test_ns_export::* proc p {} {return [cmd1 123]} } test_ns_import::p } {cmd1: 123} test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} { list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg } {0 {}} test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} { namespace eval test_ns_import { namespace import -force ::test_ns_export::* cmd1 555 } } {cmd1: 555} test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} { |
︙ | ︙ | |||
834 835 836 837 838 839 840 | test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace} msg] $msg } {1 {wrong # args: should be "namespace subcommand ?arg ...?"}} test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} { list [catch {namespace wombat {}} msg] $msg | | | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 | test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace} msg] $msg } {1 {wrong # args: should be "namespace subcommand ?arg ...?"}} test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} { list [catch {namespace wombat {}} msg] $msg } {1 {bad option "wombat": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, path, qualifiers, tail, or which}} test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} { namespace ch :: test_ns_* } {} test namespace-21.1 {NamespaceChildrenCmd, no args} { catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1::test_ns_2 {} |
︙ | ︙ | |||
941 942 943 944 945 946 947 | test namespace-25.1 {NamespaceEvalCmd, bad args} { catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace eval} msg] $msg } {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} test namespace-25.2 {NamespaceEvalCmd, bad args} { list [catch {namespace test_ns_1} msg] $msg | | | 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 | test namespace-25.1 {NamespaceEvalCmd, bad args} { catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace eval} msg] $msg } {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} test namespace-25.2 {NamespaceEvalCmd, bad args} { list [catch {namespace test_ns_1} msg] $msg } {1 {bad option "test_ns_1": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, path, qualifiers, tail, or which}} catch {unset v} test namespace-25.3 {NamespaceEvalCmd, new namespace} { set v 123 namespace eval test_ns_1 { variable v 314159 proc p {} { variable v |
︙ | ︙ | |||
1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 | proc x {} {a b; c b; a b; c b} x } -result {1 2 1 2} -cleanup { rename a {} rename c {} rename x {} } test namespace-50.1 {ensembles affect proc arguments error messages} -body { namespace ens cre -command a -map {b {bb foo}} proc bb {c d {e f} args} {list $c $args} a b } -returnCodes error -result "wrong # args: should be \"a b d ?e? ...\"" -cleanup { rename a {} | > > > > > > > > > > > > > | 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 | proc x {} {a b; c b; a b; c b} x } -result {1 2 1 2} -cleanup { rename a {} rename c {} rename x {} } test namespace-49.2 {strange delete crash} -body { namespace eval foo {namespace ensemble create -command ::bar} trace add command ::bar delete DeleteTrace proc DeleteTrace {old new op} { trace remove command ::bar delete DeleteTrace rename $old "" # This next line caused a bus error in [Bug 1220058] namespace delete foo } rename ::bar "" } -result "" -cleanup { rename DeleteTrace "" } test namespace-50.1 {ensembles affect proc arguments error messages} -body { namespace ens cre -command a -map {b {bb foo}} proc bb {c d {e f} args} {list $c $args} a b } -returnCodes error -result "wrong # args: should be \"a b d ?e? ...\"" -cleanup { rename a {} |
︙ | ︙ | |||
1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 | namespace ens cre -command a -map {b {c d}} namespace ens cre -command c -map {d {e f}} proc e f {} a b d } -returnCodes error -result "wrong # args: should be \"a b\"" -cleanup { rename a {} } # cleanup catch {rename cmd1 {}} catch {unset l} catch {unset msg} catch {unset trigger} namespace delete {expand}[namespace children :: test_ns_*] ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | namespace ens cre -command a -map {b {c d}} namespace ens cre -command c -map {d {e f}} proc e f {} a b d } -returnCodes error -result "wrong # args: should be \"a b\"" -cleanup { rename a {} } test namespace-51.1 {name resolution path control} -body { namespace eval ::test_ns_1 { namespace eval test_ns_2 { proc pathtestA {} { ::return [pathtestB],[pathtestC],[pathtestD],[namespace path] } proc pathtestC {} { ::return 2 } } proc pathtestB {} { return 1 } proc pathtestC {} { return 1 } namespace path ::test_ns_1 } proc ::pathtestB {} { return global } proc ::pathtestD {} { return global } test_ns_1::test_ns_2::pathtestA } -result "global,2,global," -cleanup { namespace delete ::test_ns_1 catch {rename ::pathtestB {}} catch {rename ::pathtestD {}} } test namespace-51.2 {name resolution path control} -body { namespace eval ::test_ns_1 { namespace eval test_ns_2 { namespace path ::test_ns_1 proc pathtestA {} { ::return [pathtestB],[pathtestC],[pathtestD],[namespace path] } proc pathtestC {} { ::return 2 } } proc pathtestB {} { return 1 } proc pathtestC {} { return 1 } } proc ::pathtestB {} { return global } proc ::pathtestD {} { return global } ::test_ns_1::test_ns_2::pathtestA } -result "1,2,global,::test_ns_1" -cleanup { namespace delete ::test_ns_1 catch {rename ::pathtestB {}} catch {rename ::pathtestD {}} } test namespace-51.3 {name resolution path control} -body { namespace eval ::test_ns_1 { namespace eval test_ns_2 { proc pathtestA {} { ::return [pathtestB],[pathtestC],[pathtestD],[namespace path] } proc pathtestC {} { ::return 2 } } proc pathtestB {} { return 1 } proc pathtestC {} { return 1 } } proc ::pathtestB {} { return global } proc ::pathtestD {} { return global } set result [::test_ns_1::test_ns_2::pathtestA] namespace eval ::test_ns_1::test_ns_2 { namespace path ::test_ns_1 } lappend result [::test_ns_1::test_ns_2::pathtestA] rename ::test_ns_1::pathtestB {} lappend result [::test_ns_1::test_ns_2::pathtestA] } -result "global,2,global, 1,2,global,::test_ns_1 global,2,global,::test_ns_1" -cleanup { namespace delete ::test_ns_1 catch {rename ::pathtestB {}} catch {rename ::pathtestD {}} } test namespace-51.4 {name resolution path control} -body { namespace eval ::test_ns_1 { namespace eval test_ns_2 { proc pathtestA {} { ::return [pathtestB],[pathtestC],[pathtestD],[namespace path] } proc pathtestC {} { ::return 2 } } proc pathtestB {} { return 1 } proc pathtestC {} { return 1 } } proc ::pathtestB {} { return global } proc ::pathtestD {} { return global } set result [::test_ns_1::test_ns_2::pathtestA] namespace eval ::test_ns_1::test_ns_2 { namespace path ::test_ns_1 } lappend result [::test_ns_1::test_ns_2::pathtestA] namespace eval ::test_ns_1::test_ns_2 { namespace path {} } lappend result [::test_ns_1::test_ns_2::pathtestA] } -result "global,2,global, 1,2,global,::test_ns_1 global,2,global," -cleanup { namespace delete ::test_ns_1 catch {rename ::pathtestB {}} catch {rename ::pathtestD {}} } test namespace-51.5 {name resolution path control} -body { namespace eval ::test_ns_1 { namespace eval test_ns_2 { proc pathtestA {} { ::return [pathtestB],[pathtestC],[pathtestD],[namespace path] } proc pathtestC {} { ::return 2 } namespace path ::test_ns_1 } proc pathtestB {} { return 1 } proc pathtestC {} { return 1 } proc pathtestD {} { return 1 } } proc ::pathtestB {} { return global } proc ::pathtestD {} { return global } set result [::test_ns_1::test_ns_2::pathtestA] namespace eval ::test_ns_1::test_ns_2 { namespace path {:: ::test_ns_1} } lappend result [::test_ns_1::test_ns_2::pathtestA] rename ::test_ns_1::test_ns_2::pathtestC {} lappend result [::test_ns_1::test_ns_2::pathtestA] } -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1}" -cleanup { namespace delete ::test_ns_1 catch {rename ::pathtestB {}} catch {rename ::pathtestD {}} } test namespace-51.6 {name resolution path control} -body { namespace eval ::test_ns_1 { namespace eval test_ns_2 { proc pathtestA {} { ::return [pathtestB],[pathtestC],[pathtestD],[namespace path] } proc pathtestC {} { ::return 2 } namespace path ::test_ns_1 } proc pathtestB {} { return 1 } proc pathtestC {} { return 1 } proc pathtestD {} { return 1 } } proc ::pathtestB {} { return global } proc ::pathtestD {} { return global } set result [::test_ns_1::test_ns_2::pathtestA] namespace eval ::test_ns_1::test_ns_2 { namespace path {:: ::test_ns_1} } lappend result [::test_ns_1::test_ns_2::pathtestA] rename ::test_ns_1::test_ns_2::pathtestC {} lappend result [::test_ns_1::test_ns_2::pathtestA] proc ::pathtestC {} { return global } lappend result [::test_ns_1::test_ns_2::pathtestA] } -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1} {global,global,global,:: ::test_ns_1}" -cleanup { namespace delete ::test_ns_1 catch {rename ::pathtestB {}} catch {rename ::pathtestD {}} } test namespace-51.7 {name resolution path control} -body { namespace eval ::test_ns_1 { } namespace eval ::test_ns_2 { namespace path ::test_ns_1 proc getpath {} {namespace path} } list [::test_ns_2::getpath] [namespace delete ::test_ns_1] [::test_ns_2::getpath] } -result {::test_ns_1 {} {}} -cleanup { catch {namespace delete ::test_ns_1} namespace delete ::test_ns_2 } test namespace-51.8 {name resolution path control} -body { namespace eval ::test_ns_1 { } namespace eval ::test_ns_2 { } namespace eval ::test_ns_3 { } namespace eval ::test_ns_4 { namespace path {::test_ns_1 ::test_ns_2 ::test_ns_3} proc getpath {} {namespace path} } list [::test_ns_4::getpath] [namespace delete ::test_ns_2] [::test_ns_4::getpath] } -result {{::test_ns_1 ::test_ns_2 ::test_ns_3} {} {::test_ns_1 ::test_ns_3}} -cleanup { catch {namespace delete ::test_ns_1} catch {namespace delete ::test_ns_2} catch {namespace delete ::test_ns_3} catch {namespace delete ::test_ns_4} } test namespace-51.9 {name resolution path control} -body { namespace eval ::test_ns_1 { } namespace eval ::test_ns_2 { } namespace eval ::test_ns_3 { } namespace eval ::test_ns_4 { namespace path {::test_ns_1 ::test_ns_2 ::test_ns_3} proc getpath {} {namespace path} } list [::test_ns_4::getpath] [namespace delete ::test_ns_2] [namespace eval ::test_ns_2 {}] [::test_ns_4::getpath] } -result {{::test_ns_1 ::test_ns_2 ::test_ns_3} {} {} {::test_ns_1 ::test_ns_3}} -cleanup { catch {namespace delete ::test_ns_1} catch {namespace delete ::test_ns_2} catch {namespace delete ::test_ns_3} catch {namespace delete ::test_ns_4} } test namespace-51.10 {name resolution path control} -body { namespace eval ::test_ns_1 { namespace path does::not::exist } } -returnCodes error -result {unknown namespace "does::not::exist"} -cleanup { catch {namespace delete ::test_ns_1} } test namespace-51.11 {name resolution path control} -body { namespace eval ::test_ns_1 { proc foo {} {return 1} } namespace eval ::test_ns_2 { proc foo {} {return 2} } namespace eval ::test_ns_3 { namespace path ::test_ns_1 } namespace eval ::test_ns_4 { namespace path {::test_ns_3 ::test_ns_2} foo } } -result 2 -cleanup { catch {namespace delete ::test_ns_1} catch {namespace delete ::test_ns_2} catch {namespace delete ::test_ns_3} catch {namespace delete ::test_ns_4} } test namespace-51.12 {name resolution path control} -body { namespace eval ::test_ns_1 { proc foo {} {return 1} } namespace eval ::test_ns_2 { proc foo {} {return 2} } namespace eval ::test_ns_3 { namespace path ::test_ns_1 } namespace eval ::test_ns_4 { namespace path {::test_ns_3 ::test_ns_2} list [foo] [namespace delete ::test_ns_3] [foo] } } -result {2 {} 2} -cleanup { catch {namespace delete ::test_ns_1} catch {namespace delete ::test_ns_2} catch {namespace delete ::test_ns_3} catch {namespace delete ::test_ns_4} } # Fails right now due to unrelated bug... test namespace-51.13 {name resolution path control} -constraints knownBug -body { set ::result {} namespace eval ::test_ns_1 { proc foo {} {lappend ::result 1} } namespace eval ::test_ns_2 { proc foo {} {lappend ::result 2} trace add command foo delete {namespace eval ::test_ns_3 foo;#} } namespace eval ::test_ns_3 { proc foo {} { lappend ::result 3 namespace delete [namespace current] ::test_ns_4::bar } } namespace eval ::test_ns_4 { namespace path {::test_ns_2 ::test_ns_3 ::test_ns_1} proc bar {} { list [foo] [namespace delete ::test_ns_2] [foo] } bar } # Should the result be "2 {} {2 3 1 1}" instead? } -result {2 {} {2 3 2 1}} -cleanup { catch {namespace delete ::test_ns_1} catch {namespace delete ::test_ns_2} catch {namespace delete ::test_ns_3} catch {namespace delete ::test_ns_4} } test namespace-51.14 {name resolution path control} -body { proc foo0 {} {} namespace eval ::test_ns_1 { proc foo1 {} {} } namespace eval ::test_ns_2 { proc foo2 {} {} } namespace eval ::test_ns_3 { variable result {} lappend result [info commands foo*] namespace path {::test_ns_1 ::test_ns_2} lappend result [info commands foo*] proc foo2 {} {} lappend result [info commands foo*] rename foo2 {} lappend result [info commands foo*] namespace delete ::test_ns_1 lappend result [info commands foo*] } } -result {foo0 {foo1 foo2 foo0} {foo2 foo1 foo0} {foo1 foo2 foo0} {foo2 foo0}} -cleanup { catch {namespace delete ::test_ns_1} catch {namespace delete ::test_ns_2} catch {namespace delete ::test_ns_3} } test namespace-51.15 {namespace resolution path control} -body { namespace eval ::test_ns_2 { proc foo {} {return 2} } namespace eval ::test_ns_1 { namespace eval test_ns_2 { proc foo {} {return 1_2} } namespace eval test_ns_3 { namespace path ::test_ns_1 test_ns_2::foo } } } -result 1_2 -cleanup { namespace delete ::test_ns_1 namespace delete ::test_ns_2 } # cleanup catch {rename cmd1 {}} catch {unset l} catch {unset msg} catch {unset trigger} namespace delete {expand}[namespace children :: test_ns_*] ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to tests/obj.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Functionality covered: this file contains a collection of tests for the # procedures in tclObj.c that implement Tcl's basic type support and the # type managers for the types boolean, double, and integer. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | < < < < < < < < < < < < < < < < < < < < < | | < > | < < < | | | | > > | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | # Functionality covered: this file contains a collection of tests for the # procedures in tclObj.c that implement Tcl's basic type support and the # type managers for the types boolean, double, and integer. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: obj.test,v 1.11.2.3 2005/08/02 18:16:41 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } testConstraint testobj [llength [info commands testobj]] testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 foreach {t} { {array search} bytearray bytecode cmdName dict end-offset nsName regexp string } { set first [string first $t [testobj types]] set r [expr {$r && ($first != -1)}] } set result $r } {1} test obj-2.1 {Tcl_GetObjType error} testobj { list [testintobj set 1 0] [catch {testobj convert 1 foo} msg] $msg } {0 1 {no type foo found}} test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 12] lappend result [testobj convert 1 bytearray] lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} 12 12 bytearray 3} test obj-3.1 {Tcl_ConvertToType error} testobj { list [testdoubleobj set 1 12.34] \ [catch {testobj convert 1 end-offset} msg] \ $msg } {12.34 1 {bad index "12.34": must be end?[+-]integer?}} test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj { list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg } {{} 1 {bad index "": must be end?[+-]integer?}} test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] lappend result [testobj type 1] lappend result [testobj refcount 1] |
︙ | ︙ | |||
171 172 173 174 175 176 177 | test obj-9.1 {Tcl_NewBooleanObj} testobj { set result "" lappend result [testobj freeallvars] lappend result [testbooleanobj set 1 0] lappend result [testobj type 1] lappend result [testobj refcount 1] | | | | | | | | | | | | 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 | test obj-9.1 {Tcl_NewBooleanObj} testobj { set result "" lappend result [testobj freeallvars] lappend result [testbooleanobj set 1 0] lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} 0 int 2} test obj-10.1 {Tcl_SetBooleanObj, existing "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] lappend result [testbooleanobj set 1 0] ;# makes existing obj boolean lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 0 int 2} test obj-10.2 {Tcl_SetBooleanObj, existing non-"empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 98765] lappend result [testbooleanobj set 1 1] ;# makes existing obj boolean lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} 98765 1 int 2} test obj-11.1 {Tcl_GetBooleanFromObj, existing boolean object} testobj { set result "" lappend result [testbooleanobj set 1 1] lappend result [testbooleanobj not 1] ;# gets existing boolean rep } {1 0} test obj-11.2 {Tcl_GetBooleanFromObj, convert to boolean} testobj { set result "" lappend result [testintobj set 1 47] lappend result [testbooleanobj not 1] ;# must convert to bool lappend result [testobj type 1] } {47 0 int} test obj-11.3 {Tcl_GetBooleanFromObj, error converting to boolean} testobj { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {abc 1 {expected boolean value but got "abc"}} test obj-11.4 {Tcl_GetBooleanFromObj, error converting from "empty string"} testobj { set result "" lappend result [testobj newobj 1] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {{} 1 {expected boolean value but got ""}} test obj-11.5 {Tcl_GetBooleanFromObj, convert hex to boolean} testobj { set result "" lappend result [teststringobj set 1 0xac] lappend result [testbooleanobj not 1] lappend result [testobj type 1] } {0xac 0 int} test obj-11.6 {Tcl_GetBooleanFromObj, convert float to boolean} testobj { set result "" lappend result [teststringobj set 1 5.42] lappend result [testbooleanobj not 1] lappend result [testobj type 1] } {5.42 0 int} test obj-12.1 {DupBooleanInternalRep} testobj { set result "" lappend result [testbooleanobj set 1 1] lappend result [testobj duplicate 1 2] ;# uses DupBooleanInternalRep lappend result [testbooleanobj get 2] } {1 1 1} test obj-13.1 {SetBooleanFromAny, int to boolean special case} testobj { set result "" lappend result [testintobj set 1 1234] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] } {1234 0 int} test obj-13.2 {SetBooleanFromAny, double to boolean special case} testobj { set result "" lappend result [testdoubleobj set 1 3.14159] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] } {3.14159 0 int} test obj-13.3 {SetBooleanFromAny, special case strings representing booleans} testobj { set result "" foreach s {yes no true false on off} { teststringobj set 1 $s lappend result [testbooleanobj not 1] } lappend result [testobj type 1] } {0 1 0 1 0 1 int} test obj-13.4 {SetBooleanFromAny, recompute string rep then parse it} testobj { set result "" lappend result [testintobj set 1 456] lappend result [testintobj div10 1] lappend result [testbooleanobj not 1] ;# converts with SetBooleanFromAny lappend result [testobj type 1] } {456 45 0 int} test obj-13.5 {SetBooleanFromAny, error parsing string} testobj { set result "" lappend result [teststringobj set 1 abc] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg } {abc 1 {expected boolean value but got "abc"}} test obj-13.6 {SetBooleanFromAny, error parsing string} testobj { |
︙ | ︙ | |||
441 442 443 444 445 446 447 | } {abc 1 {expected integer but got "abc"}} test obj-23.4 {Tcl_GetIntFromObj, error converting from "empty string"} testobj { set result "" lappend result [testobj newobj 1] lappend result [catch {testintobj div10 1} msg] lappend result $msg } {{} 1 {expected integer but got ""}} | | | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 | } {abc 1 {expected integer but got "abc"}} test obj-23.4 {Tcl_GetIntFromObj, error converting from "empty string"} testobj { set result "" lappend result [testobj newobj 1] lappend result [catch {testintobj div10 1} msg] lappend result $msg } {{} 1 {expected integer but got ""}} test obj-23.5 {Tcl_GetIntFromObj, integer too large to represent as non-long error} {testobj} { set result "" lappend result [testobj newobj 1] lappend result [testintobj inttoobigtest 1] } {{} 1} test obj-24.1 {DupIntInternalRep} testobj { set result "" |
︙ | ︙ | |||
485 486 487 488 489 490 491 | } {abc 1 {expected integer but got "abc"}} test obj-25.5 {SetIntFromAny, error parsing string} testobj { set result "" lappend result [teststringobj set 1 x17] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {x17 1 {expected integer but got "x17"}} | | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 | } {abc 1 {expected integer but got "abc"}} test obj-25.5 {SetIntFromAny, error parsing string} testobj { set result "" lappend result [teststringobj set 1 x17] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {x17 1 {expected integer but got "x17"}} test obj-25.6 {SetIntFromAny, integer too large} {testobj} { set result "" lappend result [teststringobj set 1 123456789012345678901] lappend result [catch {testintobj mult10 1} msg] lappend result $msg } {123456789012345678901 1 {integer value too large to represent}} test obj-25.7 {SetIntFromAny, error converting from "empty string"} testobj { set result "" |
︙ | ︙ | |||
567 568 569 570 571 572 573 | lappend result [testobj type 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] lappend result [testbooleanobj set 2 0] ;# must copy on write, now 2 objs lappend result [testobj type 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] | | | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 | lappend result [testobj type 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] lappend result [testbooleanobj set 2 0] ;# must copy on write, now 2 objs lappend result [testobj type 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] } {{} 1024 1024 int 4 4 0 int 3 2} test obj-31.1 {regenerate string rep of "end"} testobj { testobj freeallvars teststringobj set 1 end testobj convert 1 end-offset testobj invalidateStringRep 1 |
︙ | ︙ | |||
600 601 602 603 604 605 606 | } end-2147483647 test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj { testobj freeallvars teststringobj set 1 end--0x7fffffff testobj convert 1 end-offset testobj invalidateStringRep 1 } end--2147483647 | | | | | | | | | | 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 | } end-2147483647 test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj { testobj freeallvars teststringobj set 1 end--0x7fffffff testobj convert 1 end-offset testobj invalidateStringRep 1 } end--2147483647 test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj longIs32bit} { testobj freeallvars teststringobj set 1 end--0x80000000 testobj convert 1 end-offset testobj invalidateStringRep 1 } end--2147483648 test obj-32.1 {freeing very large object trees} { set x {} for {set i 0} {$i<100000} {incr i} { set x [list $x {}] } unset x } {} test obj-33.1 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x 0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 2147483648} test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x 0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 4294967295} test obj-33.3 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x 0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {0 4294967296} test obj-33.4 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x -0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 -2147483648} test obj-33.5 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x -0x8000; append x 0001 list [string is integer $x] [expr { wide($x) }] } {1 -2147483649} test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x -0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 -4294967295} test obj-33.7 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x -0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {0 -4294967296} if {[testConstraint testobj]} { testobj freeallvars } # cleanup ::tcltest::cleanupTests return |
Changes to tests/parse.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for the procedures in the # file tclParse.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # This file contains a collection of tests for the procedures in the # file tclParse.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: parse.test,v 1.19.2.1 2005/04/10 23:14:59 kennykb 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::parse { |
︙ | ︙ | |||
939 940 941 942 943 944 945 946 947 948 949 950 951 | set a } 2 test parse-18.30 {Tcl_SubstObj, side effects} { set a 0 catch {subst {foo[incr a; incr a parse error {}{}]bar}} set a } 1 cleanupTests } namespace delete ::tcl::test::parse return | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | set a } 2 test parse-18.30 {Tcl_SubstObj, side effects} { set a 0 catch {subst {foo[incr a; incr a parse error {}{}]bar}} set a } 1 test parse-19.1 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints { testevalex } -setup { interp create i load {} Tcltest i i eval {proc {} args {}} interp recursionlimit i 3 } -body { i eval {testevalex {[]}} } -cleanup { interp delete i } test parse-19.2 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints { testevalex } -setup { interp create i load {} Tcltest i i eval {proc {} args {}} interp recursionlimit i 3 } -body { i eval {testevalex {[[]]}} } -cleanup { interp delete i } -returnCodes error -match glob -result {too many nested*} test parse-19.3 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup { interp create i i eval {proc {} args {}} interp recursionlimit i 3 } -body { i eval {subst {[]}} } -cleanup { interp delete i } test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup { interp create i i eval {proc {} args {}} interp recursionlimit i 3 } -body { i eval {subst {[[]]}} } -cleanup { interp delete i } -returnCodes error -match glob -result {too many nested*} cleanupTests } namespace delete ::tcl::test::parse return |
Changes to tests/parseExpr.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for the procedures in the # file tclParseExpr.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | > | | > | > | | | > | > | | > | > | | > | > | | | > | > | | > | > | | | > | > | | > | > | | | > | > | | > | > | | | > | > | | > | > | | | > | > | | > | > | | | > | > | | > | > | | | > | > | | > | > | | | > | > | | > | > | | | > | > | | > | > | | | > | > | | | | > | > | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 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 | # 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.13.2.3 2005/08/02 18:16:42 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # Note that the Tcl expression parser (tclParseExpr.c) does not check # the semantic validity of the expressions it parses. It does not check, # for example, that a math function actually exists, or that the operands # of "<<" are integers. testConstraint testexprparser [llength [info commands testexprparser]] # Some tests only work if wide integers (>32bit) are not found to be # integers at all. testConstraint wideIs32bit [expr {0x80000000 < 0}] # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues binary scan [binary format dd -1.0 1.0] c* c switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ ieeeValues(-Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ ieeeValues(+Normal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ ieeeValues(+Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 } default { return 0 } } } ::tcltest::testConstraint ieeeFloatingPoint [testIEEE] ###################################################################### test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} testexprparser { testexprparser [bytestring "1+2\0 +3"] -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} testexprparser { testexprparser "1 + 2" -1 } {- {} 0 subexpr {1 + 2} 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {testexprparser wideIs32bit} { list [catch {testexprparser {12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-1.4 {Tcl_ParseExpr procedure, error in conditional expression} \ -constraints testexprparser -body { list [catch {testexprparser {foo+} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "foo+": *preceding $*}} test parseExpr-1.5 {Tcl_ParseExpr procedure, lexemes after the expression} testexprparser { list [catch {testexprparser {1+2 345} -1} msg] $msg } {1 {syntax error in expression "1+2 345": extra tokens at end of expression}} test parseExpr-2.1 {ParseCondExpr procedure, valid test subexpr} testexprparser { testexprparser {2>3? 1 : 0} -1 } {- {} 0 subexpr {2>3? 1 : 0} 11 operator ? 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-2.2 {ParseCondExpr procedure, error in test subexpr} \ -constraints testexprparser -body { list [catch {testexprparser {0 || foo} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "0 || foo": * preceding $*}} test parseExpr-2.3 {ParseCondExpr procedure, next lexeme isn't "?"} testexprparser { testexprparser {1+2} -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} test parseExpr-2.4 {ParseCondExpr procedure, next lexeme is "?"} testexprparser { testexprparser {1+2 ? 3 : 4} -1 } {- {} 0 subexpr {1+2 ? 3 : 4} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} test parseExpr-2.5 {ParseCondExpr procedure, bad lexeme after "?"} {testexprparser wideIs32bit} { list [catch {testexprparser {1+2 ? 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-2.6 {ParseCondExpr procedure, valid "then" subexpression} testexprparser { testexprparser {1? 3 : 4} -1 } {- {} 0 subexpr {1? 3 : 4} 7 operator ? 0 subexpr 1 1 text 1 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} test parseExpr-2.7 {ParseCondExpr procedure, error in "then" subexpression} \ -constraints testexprparser -body { list [catch {testexprparser {1? fred : martha} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1? fred : martha": *preceding $*}} test parseExpr-2.8 {ParseCondExpr procedure, lexeme after "then" subexpr isn't ":"} testexprparser { list [catch {testexprparser {1? 2 martha 3} -1} msg] $msg } {1 {syntax error in expression "1? 2 martha 3": missing colon from ternary conditional}} test parseExpr-2.9 {ParseCondExpr procedure, valid "else" subexpression} testexprparser { testexprparser {27||3? 3 : 4&&9} -1 } {- {} 0 subexpr {27||3? 3 : 4&&9} 15 operator ? 0 subexpr 27||3 5 operator || 0 subexpr 27 1 text 27 0 subexpr 3 1 text 3 0 subexpr 3 1 text 3 0 subexpr 4&&9 5 operator && 0 subexpr 4 1 text 4 0 subexpr 9 1 text 9 0 {}} test parseExpr-2.10 {ParseCondExpr procedure, error in "else" subexpression} \ -constraints testexprparser -body { list [catch {testexprparser {1? 2 : martha} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1? 2 : martha": * preceding $*}} test parseExpr-3.1 {ParseLorExpr procedure, valid logical and subexpr} testexprparser { testexprparser {1&&2 || 3} -1 } {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-3.2 {ParseLorExpr procedure, error in logical and subexpr} \ -constraints testexprparser -body { list [catch {testexprparser {1&&foo || 3} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1&&foo || 3": * preceding $*}} test parseExpr-3.3 {ParseLorExpr procedure, next lexeme isn't "||"} testexprparser { testexprparser {1&&2? 1 : 0} -1 } {- {} 0 subexpr {1&&2? 1 : 0} 11 operator ? 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-3.4 {ParseLorExpr procedure, next lexeme is "||"} testexprparser { testexprparser {1&&2 || 3} -1 } {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-3.5 {ParseLorExpr procedure, bad lexeme after "||"} {testexprparser wideIs32bit} { list [catch {testexprparser {1&&2 || 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-3.6 {ParseLorExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1&&2 || 3 || 4} -1 } {- {} 0 subexpr {1&&2 || 3 || 4} 13 operator || 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} test parseExpr-3.7 {ParseLorExpr procedure, error in RHS subexpression} \ -constraints testexprparser -body { list [catch {testexprparser {1&&2 || 3 || martha} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1&&2 || 3 || martha": * preceding $*}} test parseExpr-4.1 {ParseLandExpr procedure, valid LHS "|" subexpr} testexprparser { testexprparser {1|2 && 3} -1 } {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-4.2 {ParseLandExpr procedure, error in LHS "|" subexpr} \ -constraints testexprparser -body { list [catch {testexprparser {1&&foo && 3} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1&&foo && 3": * preceding $*}} test parseExpr-4.3 {ParseLandExpr procedure, next lexeme isn't "&&"} testexprparser { testexprparser {1|2? 1 : 0} -1 } {- {} 0 subexpr {1|2? 1 : 0} 11 operator ? 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-4.4 {ParseLandExpr procedure, next lexeme is "&&"} testexprparser { testexprparser {1|2 && 3} -1 } {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-4.5 {ParseLandExpr procedure, bad lexeme after "&&"} {testexprparser wideIs32bit} { list [catch {testexprparser {1|2 && 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-4.6 {ParseLandExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1|2 && 3 && 4} -1 } {- {} 0 subexpr {1|2 && 3 && 4} 13 operator && 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} test parseExpr-4.7 {ParseLandExpr procedure, error in RHS subexpression} \ -constraints testexprparser -body { list [catch {testexprparser {1|2 && 3 && martha} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1|2 && 3 && martha": * preceding $*}} test parseExpr-5.1 {ParseBitOrExpr procedure, valid LHS "^" subexpr} testexprparser { testexprparser {1^2 | 3} -1 } {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-5.2 {ParseBitOrExpr procedure, error in LHS "^" subexpr} \ -constraints testexprparser -body { list [catch {testexprparser {1|foo | 3} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1|foo | 3": * preceding $*}} test parseExpr-5.3 {ParseBitOrExpr procedure, next lexeme isn't "|"} testexprparser { testexprparser {1^2? 1 : 0} -1 } {- {} 0 subexpr {1^2? 1 : 0} 11 operator ? 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-5.4 {ParseBitOrExpr procedure, next lexeme is "|"} testexprparser { testexprparser {1^2 | 3} -1 } {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-5.5 {ParseBitOrExpr procedure, bad lexeme after "|"} {testexprparser wideIs32bit} { list [catch {testexprparser {1^2 | 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-5.6 {ParseBitOrExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1^2 | 3 | 4} -1 } {- {} 0 subexpr {1^2 | 3 | 4} 13 operator | 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} test parseExpr-5.7 {ParseBitOrExpr procedure, error in RHS subexpression} \ -constraints testexprparser -body { list [catch {testexprparser {1^2 | 3 | martha} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1^2 | 3 | martha": * preceding $*}} test parseExpr-6.1 {ParseBitXorExpr procedure, valid LHS "&" subexpr} testexprparser { testexprparser {1&2 ^ 3} -1 } {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-6.2 {ParseBitXorExpr procedure, error in LHS "&" subexpr} \ -constraints testexprparser -body { list [catch {testexprparser {1^foo ^ 3} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1^foo ^ 3": * preceding $*}} test parseExpr-6.3 {ParseBitXorExpr procedure, next lexeme isn't "^"} testexprparser { testexprparser {1&2? 1 : 0} -1 } {- {} 0 subexpr {1&2? 1 : 0} 11 operator ? 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-6.4 {ParseBitXorExpr procedure, next lexeme is "^"} testexprparser { testexprparser {1&2 ^ 3} -1 } {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-6.5 {ParseBitXorExpr procedure, bad lexeme after "^"} {testexprparser wideIs32bit} { list [catch {testexprparser {1&2 ^ 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-6.6 {ParseBitXorExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1&2 ^ 3 ^ 4} -1 } {- {} 0 subexpr {1&2 ^ 3 ^ 4} 13 operator ^ 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} test parseExpr-6.7 {ParseBitXorExpr procedure, error in RHS subexpression} \ -constraints testexprparser -body { list [catch {testexprparser {1&2 ^ 3 ^ martha} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1&2 ^ 3 ^ martha": * preceding $*}} test parseExpr-7.1 {ParseBitAndExpr procedure, valid LHS equality subexpr} testexprparser { testexprparser {1==2 & 3} -1 } {- {} 0 subexpr {1==2 & 3} 9 operator & 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-7.2 {ParseBitAndExpr procedure, error in LHS equality subexpr} \ -constraints testexprparser -body { list [catch {testexprparser {1!=foo & 3} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1!=foo & 3": * preceding $*}} test parseExpr-7.3 {ParseBitAndExpr procedure, next lexeme isn't "&"} testexprparser { testexprparser {1==2? 1 : 0} -1 } {- {} 0 subexpr {1==2? 1 : 0} 11 operator ? 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-7.4 {ParseBitAndExpr procedure, next lexeme is "&"} testexprparser { testexprparser {1>2 & 3} -1 } {- {} 0 subexpr {1>2 & 3} 9 operator & 0 subexpr 1>2 5 operator > 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-7.5 {ParseBitAndExpr procedure, bad lexeme after "&"} {testexprparser wideIs32bit} { list [catch {testexprparser {1==2 & 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-7.6 {ParseBitAndExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1<2 & 3 & 4} -1 } {- {} 0 subexpr {1<2 & 3 & 4} 13 operator & 0 subexpr {1<2 & 3} 9 operator & 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} test parseExpr-7.7 {ParseBitAndExpr procedure, error in RHS subexpression} \ -constraints testexprparser -body { list [catch {testexprparser {1==2 & 3>2 & martha} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1==2 & 3>2 & martha": * preceding $*}} test parseExpr-8.1 {ParseEqualityExpr procedure, valid LHS relational subexpr} testexprparser { testexprparser {1<2 == 3} -1 } {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-8.2 {ParseEqualityExpr procedure, error in LHS relational subexpr} \ -constraints testexprparser -body { list [catch {testexprparser {1>=foo == 3} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1>=foo == 3": * preceding $*}} test parseExpr-8.3 {ParseEqualityExpr procedure, next lexeme isn't "==" or "!="} testexprparser { testexprparser {1<2? 1 : 0} -1 } {- {} 0 subexpr {1<2? 1 : 0} 11 operator ? 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-8.4 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} testexprparser { testexprparser {1<2 == 3} -1 } {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-8.5 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} testexprparser { testexprparser {1<2 != 3} -1 } {- {} 0 subexpr {1<2 != 3} 9 operator != 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-8.6 {ParseEqualityExpr procedure, bad lexeme after "==" or "!="} {testexprparser wideIs32bit} { list [catch {testexprparser {1<2 == 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-8.7 {ParseEqualityExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1<2 == 3 == 4} -1 } {- {} 0 subexpr {1<2 == 3 == 4} 13 operator == 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} test parseExpr-8.8 {ParseEqualityExpr procedure, error in RHS subexpression} \ -constraints testexprparser -body { list [catch {testexprparser {1<2 == 3 != martha} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1<2 == 3 != martha": * preceding $*}} test parseExpr-9.1 {ParseRelationalExpr procedure, valid LHS shift subexpr} testexprparser { testexprparser {1<<2 < 3} -1 } {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-9.2 {ParseRelationalExpr procedure, error in LHS shift subexpr} \ -constraints testexprparser -body { list [catch {testexprparser {1>=foo < 3} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1>=foo < 3": * preceding $*}} test parseExpr-9.3 {ParseRelationalExpr procedure, next lexeme isn't relational op} testexprparser { testexprparser {1<<2? 1 : 0} -1 } {- {} 0 subexpr {1<<2? 1 : 0} 11 operator ? 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-9.4 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser { testexprparser {1<<2 < 3} -1 } {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-9.5 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser { testexprparser {1>>2 > 3} -1 } {- {} 0 subexpr {1>>2 > 3} 9 operator > 0 subexpr 1>>2 5 operator >> 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-9.6 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser { testexprparser {1<<2 <= 3} -1 } {- {} 0 subexpr {1<<2 <= 3} 9 operator <= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-9.7 {ParseRelationalExpr procedure, next lexeme is relational op} testexprparser { testexprparser {1<<2 >= 3} -1 } {- {} 0 subexpr {1<<2 >= 3} 9 operator >= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-9.8 {ParseRelationalExpr procedure, bad lexeme after relational op} {testexprparser wideIs32bit} { list [catch {testexprparser {1<<2 < 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-9.9 {ParseRelationalExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1<<2 < 3 < 4} -1 } {- {} 0 subexpr {1<<2 < 3 < 4} 13 operator < 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} test parseExpr-9.10 {ParseRelationalExpr procedure, error in RHS subexpression} \ -constraints testexprparser -body { list [catch {testexprparser {1<<2 < 3 > martha} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1<<2 < 3 > martha": * preceding $*}} test parseExpr-10.1 {ParseShiftExpr procedure, valid LHS add subexpr} testexprparser { testexprparser {1+2 << 3} -1 } {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-10.2 {ParseShiftExpr procedure, error in LHS add subexpr} \ -constraints testexprparser -body { list [catch {testexprparser {1-foo << 3} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1-foo << 3": * preceding $*}} test parseExpr-10.3 {ParseShiftExpr procedure, next lexeme isn't "<<" or ">>"} testexprparser { testexprparser {1+2? 1 : 0} -1 } {- {} 0 subexpr {1+2? 1 : 0} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-10.4 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} testexprparser { testexprparser {1+2 << 3} -1 } {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-10.5 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} testexprparser { testexprparser {1+2 >> 3} -1 } {- {} 0 subexpr {1+2 >> 3} 9 operator >> 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-10.6 {ParseShiftExpr procedure, bad lexeme after "<<" or ">>"} {testexprparser wideIs32bit} { list [catch {testexprparser {1+2 << 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-10.7 {ParseShiftExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1+2 << 3 << 4} -1 } {- {} 0 subexpr {1+2 << 3 << 4} 13 operator << 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} test parseExpr-10.8 {ParseShiftExpr procedure, error in RHS subexpression} \ -constraints testexprparser -body { list [catch {testexprparser {1+2 << 3 >> martha} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1+2 << 3 >> martha": * preceding $*}} test parseExpr-11.1 {ParseAddExpr procedure, valid LHS multiply subexpr} testexprparser { testexprparser {1*2 + 3} -1 } {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-11.2 {ParseAddExpr procedure, error in LHS multiply subexpr} \ -constraints testexprparser -body { list [catch {testexprparser {1/foo + 3} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1/foo + 3": * preceding $*}} test parseExpr-11.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} testexprparser { testexprparser {1*2? 1 : 0} -1 } {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-11.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser { testexprparser {1*2 + 3} -1 } {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-11.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser { testexprparser {1*2 - 3} -1 } {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-11.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {testexprparser wideIs32bit} { list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-11.7 {ParseAddExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1*2 + 3 + 4} -1 } {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} test parseExpr-11.8 {ParseAddExpr procedure, error in RHS subexpression} \ -constraints testexprparser -body { list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1*2 + 3 - martha": * preceding $*}} test parseExpr-12.1 {ParseAddExpr procedure, valid LHS multiply subexpr} testexprparser { testexprparser {1*2 + 3} -1 } {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-12.2 {ParseAddExpr procedure, error in LHS multiply subexpr} \ -constraints testexprparser -body { list [catch {testexprparser {1/foo + 3} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1/foo + 3": * preceding $*}} test parseExpr-12.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} testexprparser { testexprparser {1*2? 1 : 0} -1 } {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-12.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser { testexprparser {1*2 + 3} -1 } {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-12.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} testexprparser { testexprparser {1*2 - 3} -1 } {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-12.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {testexprparser wideIs32bit} { list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-12.7 {ParseAddExpr procedure, valid RHS subexpression} testexprparser { testexprparser {1*2 + 3 + 4} -1 } {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} test parseExpr-12.8 {ParseAddExpr procedure, error in RHS subexpression} \ -constraints testexprparser -body { list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "1*2 + 3 - martha": * preceding $*}} test parseExpr-13.1 {ParseMultiplyExpr procedure, valid LHS unary subexpr} testexprparser { testexprparser {+2 * 3} -1 } {- {} 0 subexpr {+2 * 3} 7 operator * 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}} test parseExpr-13.2 {ParseMultiplyExpr procedure, error in LHS unary subexpr} {testexprparser wideIs32bit} { list [catch {testexprparser {-12345678901234567890 * 3} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-13.3 {ParseMultiplyExpr procedure, next lexeme isn't "*", "/", or "%"} testexprparser { testexprparser {+2? 1 : 0} -1 } {- {} 0 subexpr {+2? 1 : 0} 9 operator ? 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}} test parseExpr-13.4 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} testexprparser { testexprparser {-123 * 3} -1 } {- {} 0 subexpr {-123 * 3} 7 operator * 0 subexpr -123 3 operator - 0 subexpr 123 1 text 123 0 subexpr 3 1 text 3 0 {}} test parseExpr-13.5 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} testexprparser { testexprparser {+-456 / 3} -1 } {- {} 0 subexpr {+-456 / 3} 9 operator / 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}} test parseExpr-13.6 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} testexprparser { testexprparser {+-456 % 3} -1 } {- {} 0 subexpr {+-456 % 3} 9 operator % 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}} test parseExpr-13.7 {ParseMultiplyExpr procedure, bad lexeme after "*", "/", or "%"} {testexprparser wideIs32bit} { list [catch {testexprparser {--++5 / 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-13.8 {ParseMultiplyExpr procedure, valid RHS subexpression} testexprparser { testexprparser {-2 / 3 % 4} -1 } {- {} 0 subexpr {-2 / 3 % 4} 11 operator % 0 subexpr {-2 / 3} 7 operator / 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}} test parseExpr-13.9 {ParseMultiplyExpr procedure, error in RHS subexpression} \ -constraints testexprparser -body { list [catch {testexprparser {++2 / 3 * martha} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "++2 / 3 * martha": * preceding $*}} test parseExpr-14.1 {ParseUnaryExpr procedure, first token is unary operator} testexprparser { testexprparser {+2} -1 } {- {} 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 {}} test parseExpr-14.2 {ParseUnaryExpr procedure, first token is unary operator} testexprparser { testexprparser {-2} -1 } {- {} 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 {}} test parseExpr-14.3 {ParseUnaryExpr procedure, first token is unary operator} testexprparser { testexprparser {~2} -1 } {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}} test parseExpr-14.4 {ParseUnaryExpr procedure, first token is unary operator} testexprparser { testexprparser {!2} -1 } {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}} test parseExpr-14.5 {ParseUnaryExpr procedure, error in lexeme after unary op} {testexprparser wideIs32bit} { list [catch {testexprparser {-12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-14.6 {ParseUnaryExpr procedure, simple unary expr after unary op} testexprparser { testexprparser {+"1234"} -1 } {- {} 0 subexpr +\"1234\" 3 operator + 0 subexpr {"1234"} 1 text 1234 0 {}} test parseExpr-14.7 {ParseUnaryExpr procedure, another unary expr after unary op} testexprparser { testexprparser {~!{fred}} -1 } {- {} 0 subexpr ~!{fred} 5 operator ~ 0 subexpr !{fred} 3 operator ! 0 subexpr {{fred}} 1 text fred 0 {}} test parseExpr-14.8 {ParseUnaryExpr procedure, error in unary expr after unary op} testexprparser { list [catch {testexprparser {+-||27} -1} msg] $msg } {1 {syntax error in expression "+-||27": unexpected operator ||}} test parseExpr-14.9 {ParseUnaryExpr procedure, error in unary expr after unary op} testexprparser { list [catch {testexprparser {+-||27} -1} msg] $msg } {1 {syntax error in expression "+-||27": unexpected operator ||}} test parseExpr-14.10 {ParseUnaryExpr procedure, first token is not unary op} testexprparser { testexprparser {123} -1 } {- {} 0 subexpr 123 1 text 123 0 {}} test parseExpr-14.11 {ParseUnaryExpr procedure, not unary expr, complex primary expr} testexprparser { testexprparser {(1+2)} -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} test parseExpr-14.12 {ParseUnaryExpr procedure, not unary expr, error in primary expr} {testexprparser wideIs32bit} { list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-15.1 {ParsePrimaryExpr procedure, just parenthesized subexpr} testexprparser { testexprparser {({abc}/{def})} -1 } {- {} 0 subexpr {{abc}/{def}} 5 operator / 0 subexpr {{abc}} 1 text abc 0 subexpr {{def}} 1 text def 0 {}} test parseExpr-15.2 {ParsePrimaryExpr procedure, bad lexeme after "("} {testexprparser wideIs32bit} { list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-15.3 {ParsePrimaryExpr procedure, valid parenthesized subexpr} testexprparser { testexprparser {({abc}? 2*4 : -6)} -1 } {- {} 0 subexpr {{abc}? 2*4 : -6} 13 operator ? 0 subexpr {{abc}} 1 text abc 0 subexpr 2*4 5 operator * 0 subexpr 2 1 text 2 0 subexpr 4 1 text 4 0 subexpr -6 3 operator - 0 subexpr 6 1 text 6 0 {}} test parseExpr-15.4 {ParsePrimaryExpr procedure, error in parenthesized subexpr} testexprparser { list [catch {testexprparser {(? 123 : 456)} -1} msg] $msg |
︙ | ︙ | |||
445 446 447 448 449 450 451 | test parseExpr-15.21 {ParsePrimaryExpr procedure, primary is braced string with multiple tokens} testexprparser { testexprparser "\{ \\ +123 \}" -1 } {- {} 0 subexpr \{\ \ \\\n\ +123\ \} 4 word \{\ \ \\\n\ +123\ \} 3 text { } 0 backslash \\\n\ 0 text {+123 } 0 {}} test parseExpr-15.22 {ParsePrimaryExpr procedure, primary is function call} testexprparser { testexprparser {foo(123)} -1 } {- {} 0 subexpr foo(123) 3 operator foo 0 subexpr 123 1 text 123 0 {}} | | | > | > | | | | | 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 | test parseExpr-15.21 {ParsePrimaryExpr procedure, primary is braced string with multiple tokens} testexprparser { testexprparser "\{ \\ +123 \}" -1 } {- {} 0 subexpr \{\ \ \\\n\ +123\ \} 4 word \{\ \ \\\n\ +123\ \} 3 text { } 0 backslash \\\n\ 0 text {+123 } 0 {}} test parseExpr-15.22 {ParsePrimaryExpr procedure, primary is function call} testexprparser { testexprparser {foo(123)} -1 } {- {} 0 subexpr foo(123) 3 operator foo 0 subexpr 123 1 text 123 0 {}} test parseExpr-15.23 {ParsePrimaryExpr procedure, bad lexeme after function name} {testexprparser wideIs32bit} { list [catch {testexprparser {foo 12345678901234567890 123)} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-15.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} \ -constraints testexprparser -body { list [catch {testexprparser {foo 27.4 123)} -1} msg] $msg } -match glob \ -result {1 {syntax error in expression "foo 27.4 123)": * preceding $*}} test parseExpr-15.25 {ParsePrimaryExpr procedure, bad lexeme after "("} {testexprparser wideIs32bit} { list [catch {testexprparser {foo(12345678901234567890)} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-15.26 {ParsePrimaryExpr procedure, function call, one arg} testexprparser { testexprparser {foo(27*4)} -1 } {- {} 0 subexpr foo(27*4) 7 operator foo 0 subexpr 27*4 5 operator * 0 subexpr 27 1 text 27 0 subexpr 4 1 text 4 0 {}} test parseExpr-15.27 {ParsePrimaryExpr procedure, error in function arg} testexprparser { list [catch {testexprparser {foo(*1-2)} -1} msg] $msg } {1 {syntax error in expression "foo(*1-2)": unexpected operator *}} test parseExpr-15.28 {ParsePrimaryExpr procedure, error in function arg} testexprparser { list [catch {testexprparser {foo(*1-2)} -1} msg] $msg } {1 {syntax error in expression "foo(*1-2)": unexpected operator *}} test parseExpr-15.29 {ParsePrimaryExpr procedure, function call, comma after arg} testexprparser { testexprparser {foo(27-2, (-2*[foo]))} -1 } {- {} 0 subexpr {foo(27-2, (-2*[foo]))} 15 operator foo 0 subexpr 27-2 5 operator - 0 subexpr 27 1 text 27 0 subexpr 2 1 text 2 0 subexpr {-2*[foo]} 7 operator * 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr {[foo]} 1 command {[foo]} 0 {}} test parseExpr-15.30 {ParsePrimaryExpr procedure, bad lexeme after comma} {testexprparser wideIs32bit} { list [catch {testexprparser {foo(123, 12345678901234567890)} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-15.31 {ParsePrimaryExpr procedure, lexeme not "," or ")" after arg} testexprparser { list [catch {testexprparser {foo(123 [foo])} -1} msg] $msg } {1 {syntax error in expression "foo(123 [foo])": missing close parenthesis at end of function call}} test parseExpr-15.32 {ParsePrimaryExpr procedure, bad lexeme after primary} {testexprparser wideIs32bit} { list [catch {testexprparser {123 12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-15.33 {ParsePrimaryExpr procedure, comma-specific message} testexprparser { list [catch {testexprparser {123+,456} -1} msg] $msg } {1 {syntax error in expression "123+,456": commas can only separate function arguments}} test parseExpr-15.34 {ParsePrimaryExpr procedure, single equal-specific message} testexprparser { list [catch {testexprparser {123+=456} -1} msg] $msg |
︙ | ︙ | |||
503 504 505 506 507 508 509 | test parseExpr-16.3 {GetLexeme procedure, no lexeme after whitespace} testexprparser { testexprparser { 123 \ } -1 } {- {} 0 subexpr 123 1 text 123 0 {}} test parseExpr-16.4 {GetLexeme procedure, integer lexeme} testexprparser { testexprparser {000} -1 } {- {} 0 subexpr 000 1 text 000 0 {}} | | | | | > > > | 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 | test parseExpr-16.3 {GetLexeme procedure, no lexeme after whitespace} testexprparser { testexprparser { 123 \ } -1 } {- {} 0 subexpr 123 1 text 123 0 {}} test parseExpr-16.4 {GetLexeme procedure, integer lexeme} testexprparser { testexprparser {000} -1 } {- {} 0 subexpr 000 1 text 000 0 {}} test parseExpr-16.5 {GetLexeme procedure, integer lexeme too big} {testexprparser wideIs32bit} { list [catch {testexprparser {12345678901234567890} -1} msg] $msg } {1 {integer value too large to represent}} test parseExpr-16.6 {GetLexeme procedure, bad integer lexeme} -constraints testexprparser -body { testexprparser {0999} -1 } -returnCodes error -match glob -result {*invalid octal number*} test parseExpr-16.7 {GetLexeme procedure, double lexeme} testexprparser { testexprparser {0.999} -1 } {- {} 0 subexpr 0.999 1 text 0.999 0 {}} test parseExpr-16.8 {GetLexeme procedure, double lexeme} testexprparser { testexprparser {.123} -1 } {- {} 0 subexpr .123 1 text .123 0 {}} test parseExpr-16.9 {GetLexeme procedure, double lexeme} {testexprparser unix} { testexprparser {nan} -1 } {- {} 0 subexpr nan 1 text nan 0 {}} test parseExpr-16.10 {GetLexeme procedure, double lexeme} {testexprparser unix} { testexprparser {NaN} -1 } {- {} 0 subexpr NaN 1 text NaN 0 {}} test parseExpr-16.11a {GetLexeme procedure, bad double lexeme too big} {testexprparser && !ieeeFloatingPoint} { list [catch {testexprparser {123.e+99999999999999} -1} msg] $msg } {1 {floating-point value too large to represent}} test parseExpr-16.11b {GetLexeme procedure, bad double lexeme too big} {testexprparser && ieeeFloatingPoint} { list [catch {testexprparser {123.e+99999999999999} -1} msg] $msg } {0 {- {} 0 subexpr 123.e+99999999999999 1 text 123.e+99999999999999 0 {}}} test parseExpr-16.12 {GetLexeme procedure, bad double lexeme} testexprparser { list [catch {testexprparser {123.4x56} -1} msg] $msg } {1 {syntax error in expression "123.4x56": extra tokens at end of expression}} test parseExpr-16.13 {GetLexeme procedure, lexeme is "["} testexprparser { testexprparser {[foo]} -1 } {- {} 0 subexpr {[foo]} 1 command {[foo]} 0 {}} test parseExpr-16.14 {GetLexeme procedure, lexeme is open brace} testexprparser { |
︙ | ︙ |
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.25.2.1 2005/05/05 17:56:19 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } catch {unset foo} |
︙ | ︙ | |||
216 217 218 219 220 221 222 | test regexp-6.8 {regexp errors} { catch {unset f1} set f1 44 list [catch {regexp abc abc f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} test regexp-6.9 {regexp errors, -start bad int check} { list [catch {regexp -start bogus {^$} {}} msg] $msg | | | 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 | test regexp-6.8 {regexp errors} { catch {unset f1} set f1 44 list [catch {regexp abc abc f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} test regexp-6.9 {regexp errors, -start bad int check} { list [catch {regexp -start bogus {^$} {}} msg] $msg } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} test regexp-7.1 {basic regsub operation} { list [regsub aa+ xaxaaaxaa 111&222 foo] $foo } {1 xax111aaa222xaa} test regexp-7.2 {basic regsub operation} { list [regsub aa+ aaaxaa &111 foo] $foo } {1 aaa111xaa} |
︙ | ︙ | |||
373 374 375 376 377 378 379 | test regexp-11.7 {regsub errors} { catch {unset f1} set f1 44 list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} test regexp-11.8 {regsub errors, -start bad int check} { list [catch {regsub -start bogus pattern string rep var} msg] $msg | | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 | test regexp-11.7 {regsub errors} { catch {unset f1} set f1 44 list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} test regexp-11.8 {regsub errors, -start bad int check} { list [catch {regsub -start bogus pattern string rep var} msg] $msg } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} test regexp-11.9 {regsub without final variable name returns value} { regsub b abaca X } {aXaca} test regexp-11.10 {regsub without final variable name returns value} { regsub -all a abaca X } {XbXcX} test regexp-11.11 {regsub without final variable name returns value} { |
︙ | ︙ | |||
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 | test regexp-15.5 {regexp -start, over end of string} { catch {unset x} list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x] } {0 0} test regexp-15.6 {regexp -start, loss of ^$ behavior} { list [regexp -start 2 {^$} {}] } {0} test regexp-16.1 {regsub -start} { catch {unset x} list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x } {4 a1b/2c/3d/4e/5} test regexp-16.2 {regsub -start} { catch {unset x} list [regsub -all -start -25 {z} hello {/&} x] $x } {0 hello} test regexp-16.3 {regsub -start} { catch {unset x} list [regsub -all -start 3 {z} hello {/&} x] $x } {0 hello} test regexp-16.4 {regsub -start, \A behavior} { set out {} lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x } {5 /a/b/c/d/e 3 ab/c/d/e} test regexp-17.1 {regexp -inline} { regexp -inline b ababa } {b} test regexp-17.2 {regexp -inline} { regexp -inline (b) ababa } {b b} | > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | test regexp-15.5 {regexp -start, over end of string} { catch {unset x} list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x] } {0 0} test regexp-15.6 {regexp -start, loss of ^$ behavior} { list [regexp -start 2 {^$} {}] } {0} test regexp-15.7 {regexp -start, double option} { regexp -start 2 -start 0 a abc } 1 test regexp-15.8 {regexp -start, double option} { regexp -start 0 -start 2 a abc } 0 test regexp-15.9 {regexp -start, end relative index} { catch {unset x} list [regexp -start end {\d} 1abc2de3 x] [info exists x] } {0 0} test regexp-15.10 {regexp -start, end relative index} { catch {unset x} list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x } {1 1 3} test regexp-16.1 {regsub -start} { catch {unset x} list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x } {4 a1b/2c/3d/4e/5} test regexp-16.2 {regsub -start} { catch {unset x} list [regsub -all -start -25 {z} hello {/&} x] $x } {0 hello} test regexp-16.3 {regsub -start} { catch {unset x} list [regsub -all -start 3 {z} hello {/&} x] $x } {0 hello} test regexp-16.4 {regsub -start, \A behavior} { set out {} lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x } {5 /a/b/c/d/e 3 ab/c/d/e} test regexp-16.5 {regsub -start, double option} { list [regsub -start 2 -start 0 a abc c x] $x } {1 cbc} test regexp-16.6 {regsub -start, double option} { list [regsub -start 0 -start 2 a abc c x] $x } {0 abc} test regexp-16.7 {regexp -start, end relative index} { list [regsub -start end a aaa b x] $x } {0 aaa} test regexp-16.8 {regexp -start, end relative index} { list [regsub -start end-1 a aaa b x] $x } {1 aab} test regexp-17.1 {regexp -inline} { regexp -inline b ababa } {b} test regexp-17.2 {regexp -inline} { regexp -inline (b) ababa } {b b} |
︙ | ︙ |
Changes to tests/regexpComp.test.
︙ | ︙ | |||
297 298 299 300 301 302 303 | list [catch {regexp abc abc f1(f2)} msg] $msg } } {1 {couldn't set variable "f1(f2)"}} test regexpComp-6.9 {regexp errors, -start bad int check} { evalInProc { list [catch {regexp -start bogus {^$} {}} msg] $msg } | | | 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 | list [catch {regexp abc abc f1(f2)} msg] $msg } } {1 {couldn't set variable "f1(f2)"}} test regexpComp-6.9 {regexp errors, -start bad int check} { evalInProc { list [catch {regexp -start bogus {^$} {}} msg] $msg } } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} test regexpComp-7.1 {basic regsub operation} { evalInProc { list [regsub aa+ xaxaaaxaa 111&222 foo] $foo } } {1 xax111aaa222xaa} test regexpComp-7.2 {basic regsub operation} { |
︙ | ︙ | |||
538 539 540 541 542 543 544 | list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg } } {1 {couldn't set variable "f1(f2)"}} test regexpComp-11.8 {regsub errors, -start bad int check} { evalInProc { list [catch {regsub -start bogus pattern string rep var} msg] $msg } | | | 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 | list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg } } {1 {couldn't set variable "f1(f2)"}} test regexpComp-11.8 {regsub errors, -start bad int check} { evalInProc { list [catch {regsub -start bogus pattern string rep var} msg] $msg } } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} # This test crashes on the Mac unless you increase the Stack Space to about 1 # Meg. This is probably bigger than most users want... # 8.2.3 regexp reduced stack space requirements, but this should be # tested again test regexpComp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} { evalInProc { |
︙ | ︙ |
Changes to tests/result.test.
︙ | ︙ | |||
104 105 106 107 108 109 110 111 112 113 114 | catch {testseterrorcode \{} llength $errorCode } 1 test result-5.4 {Tcl_SetErrorCode - two args, list quoting} testseterrorcode { catch {testseterrorcode {a b} c} set errorCode } {{a b} c} # cleanup ::tcltest::cleanupTests return | > > > > > > > > > > > > > | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | catch {testseterrorcode \{} llength $errorCode } 1 test result-5.4 {Tcl_SetErrorCode - two args, list quoting} testseterrorcode { catch {testseterrorcode {a b} c} set errorCode } {{a b} c} ::tcltest::testConstraint testreturn \ [expr {[info commands testreturn] != {}}] test result-6.0 {Bug 1209759} -constraints testreturn -body { # Might panic if bug is not fixed. proc foo {} {testreturn} foo } -returnCodes ok -result {} test result-6.1 {Bug 1209759} -constraints testreturn -body { # Might panic if bug is not fixed. proc foo {} {catch {return -level 2}; testreturn} foo } -returnCodes ok -result {} # cleanup ::tcltest::cleanupTests return |
Changes to tests/safe.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # safe.test -- # # This file contains a collection of tests for safe Tcl, packages loading, # and using safe interpreters. Sourcing this file into tcl runs the tests # and generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | # safe.test -- # # This file contains a collection of tests for safe Tcl, packages loading, # and using safe interpreters. Sourcing this file into tcl runs the tests # and generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: safe.test,v 1.17.2.1 2004/12/08 18:24:36 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } foreach i [interp slaves] { interp delete $i } set saveAutoPath $::auto_path set ::auto_path [info library] # Force actual loading of the safe package # because we use un exported (and thus un-autoindexed) APIs # in this test result arguments: catch {safe::interpConfigure} proc equiv {x} {return $x} |
︙ | ︙ | |||
474 475 476 477 478 479 480 481 482 483 | list \ [catch {interp eval $i encoding convertto} msg] \ $msg \ [safe::interpDelete $i]; } {1 {wrong # args: should be "encoding convertto ?encoding? data"} {}} # cleanup ::tcltest::cleanupTests return | > | 477 478 479 480 481 482 483 484 485 486 487 | list \ [catch {interp eval $i encoding convertto} msg] \ $msg \ [safe::interpDelete $i]; } {1 {wrong # args: should be "encoding convertto ?encoding? data"} {}} set ::auto_path $saveAutoPath # cleanup ::tcltest::cleanupTests return |
Changes to tests/scan.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: scan # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | # 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.15.2.5 2005/08/23 18:28:52 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } ::tcltest::testConstraint wideIs64bit \ [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 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} |
︙ | ︙ | |||
336 337 338 339 340 341 342 | unset z set result } {1 {couldn't set variable "z"couldn't set variable "y"} abc} # procedure that returns the range of integers proc int_range {} { | | > | 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 | unset z set result } {1 {couldn't set variable "z"couldn't set variable "y"} abc} # procedure that returns the range of integers proc int_range {} { for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} { set MIN_INT [expr { $MIN_INT << 1 }] } set MIN_INT [expr {int($MIN_INT)}] set MAX_INT [expr { ~ $MIN_INT }] return [list $MIN_INT $MAX_INT] } test scan-4.62 {scanning of large and negative octal integers} { foreach { MIN_INT MAX_INT } [int_range] {} set scanstring [format {%o %o %o} -1 $MIN_INT $MAX_INT] |
︙ | ︙ | |||
413 414 415 416 417 418 419 | # input (-16) some return MAX_INT. # test scan-5.11 {integer scanning} {nonPortable} { set a {}; set b {}; list [scan "4294967280 4294967280" "%u %d" a b] $a \ [expr {$b == -16 || $b == 0x7fffffff}] } {2 4294967280 1} | | | 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 | # input (-16) some return MAX_INT. # test scan-5.11 {integer scanning} {nonPortable} { set a {}; set b {}; list [scan "4294967280 4294967280" "%u %d" a b] $a \ [expr {$b == -16 || $b == 0x7fffffff}] } {2 4294967280 1} test scan-5.12 {integer scanning} {wideIs64bit} { set a {}; set b {}; set c {} list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \ %ld,%lx,%lo a b c] $a $b $c } {3 7810179016327718216 7810179016327718216 7810179016327718216} test scan-5.13 {integer scanning and overflow} { # This test used to fail on some 64-bit systems. [Bug 1011860] scan {300000000 3000000000 30000000000} {%ld %ld %ld} |
︙ | ︙ | |||
447 448 449 450 451 452 453 | set a {}; set b {}; set c {} list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c } {3 1.0 200.0 3.0} test scan-6.5 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d } {4 4.6 99999.7 87.643 118.0} | | | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 | set a {}; set b {}; set c {} list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c } {3 1.0 200.0 3.0} test scan-6.5 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d } {4 4.6 99999.7 87.643 118.0} test scan-6.6 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d } {4 1.2345 0.697 124.0 5e-5} test scan-6.7 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d } {1 4.6 {} {} {}} test scan-6.8 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d |
︙ | ︙ | |||
674 675 676 677 678 679 680 681 682 683 | scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" {%20$d %18$d %17$d %16$d %15$d %14$d %13$d %12$d %11$d %10$d %9$d %8$d %7$d %6$d %5$d %4$d %3$d %2$d %1$d} } {190 180 170 160 150 140 130 120 110 100 90 80 70 60 50 40 30 20 {} 10} test scan-13.8 {Tcl_ScanObjCmd, inline XPG case lots of arguments} { set msg [scan "10 20 30" {%100$d %5$d %200$d}] list [llength $msg] [lindex $msg 99] [lindex $msg 4] [lindex $msg 199] } {200 10 20 30} # cleanup ::tcltest::cleanupTests return | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" {%20$d %18$d %17$d %16$d %15$d %14$d %13$d %12$d %11$d %10$d %9$d %8$d %7$d %6$d %5$d %4$d %3$d %2$d %1$d} } {190 180 170 160 150 140 130 120 110 100 90 80 70 60 50 40 30 20 {} 10} test scan-13.8 {Tcl_ScanObjCmd, inline XPG case lots of arguments} { set msg [scan "10 20 30" {%100$d %5$d %200$d}] list [llength $msg] [lindex $msg 99] [lindex $msg 4] [lindex $msg 199] } {200 10 20 30} # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues binary scan [binary format dd -1.0 1.0] c* c switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ ieeeValues(-Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ ieeeValues(+Normal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ ieeeValues(+Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 } default { return 0 } } } testConstraint ieeeFloatingPoint [testIEEE] # scan infinities - not working test scan-14.1 {infinity} ieeeFloatingPoint { scan Inf %g d set d } Inf test scan-14.2 {infinity} ieeeFloatingPoint { scan -Inf %g d set d } -Inf # TODO - also need to scan NaN's # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
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.36.2.1 2005/08/02 18:16:43 dgp 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 |
︙ | ︙ | |||
197 198 199 200 201 202 203 | } test socket-1.1 {arg parsing for socket command} {socket} { list [catch {socket -server} msg] $msg } {1 {no argument given for -server option}} test socket-1.2 {arg parsing for socket command} {socket} { list [catch {socket -server foo} msg] $msg | < | < < | < < | < < | < < | < | 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 | } test socket-1.1 {arg parsing for socket command} {socket} { list [catch {socket -server} msg] $msg } {1 {no argument given for -server option}} test socket-1.2 {arg parsing for socket command} {socket} { list [catch {socket -server foo} msg] $msg } {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} test socket-1.3 {arg parsing for socket command} {socket} { list [catch {socket -myaddr} msg] $msg } {1 {no argument given for -myaddr option}} test socket-1.4 {arg parsing for socket command} {socket} { list [catch {socket -myaddr 127.0.0.1} msg] $msg } {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} test socket-1.5 {arg parsing for socket command} {socket} { list [catch {socket -myport} msg] $msg } {1 {no argument given for -myport option}} test socket-1.6 {arg parsing for socket command} {socket} { list [catch {socket -myport xxxx} msg] $msg } {1 {expected integer but got "xxxx"}} test socket-1.7 {arg parsing for socket command} {socket} { list [catch {socket -myport 2522} msg] $msg } {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} test socket-1.8 {arg parsing for socket command} {socket} { list [catch {socket -froboz} msg] $msg } {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}} test socket-1.9 {arg parsing for socket command} {socket} { list [catch {socket -server foo -myport 2521 3333} msg] $msg } {1 {Option -myport is not valid for servers}} test socket-1.10 {arg parsing for socket command} {socket} { list [catch {socket host 2528 -junk} msg] $msg } {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} test socket-1.11 {arg parsing for socket command} {socket} { list [catch {socket -server callback 2520 --} msg] $msg } {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} test socket-1.12 {arg parsing for socket command} {socket} { list [catch {socket foo badport} msg] $msg } {1 {expected integer but got "badport"}} test socket-1.13 {arg parsing for socket command} {socket} { list [catch {socket -async -server} msg] $msg } {1 {cannot set -async option for server sockets}} test socket-1.14 {arg parsing for socket command} {socket} { |
︙ | ︙ |
Changes to tests/string.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: string.test,v 1.43.2.7 2005/08/17 04:57:49 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } # Some tests require the testobj command testConstraint testobj [expr {[info commands testobj] != {}}] testConstraint testindexobj [expr {[info commands testindexobj] != {}}] test string-1.1 {error conditions} { list [catch {string gorp a b} msg] $msg } {1 {bad option "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2 {error conditions} { list [catch {string} msg] $msg } {1 {wrong # args: should be "string option arg ?arg ...?"}} |
︙ | ︙ | |||
171 172 173 174 175 176 177 | } 1 test string-4.1 {string first, too few args} { list [catch {string first a} msg] $msg } {1 {wrong # args: should be "string first subString string ?startIndex?"}} test string-4.2 {string first, bad args} { list [catch {string first a b c} msg] $msg | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 | } 1 test string-4.1 {string first, too few args} { list [catch {string first a} msg] $msg } {1 {wrong # args: should be "string first subString string ?startIndex?"}} test string-4.2 {string first, bad args} { list [catch {string first a b c} msg] $msg } {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} test string-4.3 {string first, too many args} { list [catch {string first a b 5 d} msg] $msg } {1 {wrong # args: should be "string first subString string ?startIndex?"}} test string-4.4 {string first} { string first bq abcdefgbcefgbqrs } 12 test string-4.5 {string first} { |
︙ | ︙ | |||
236 237 238 239 240 241 242 | string index abcde 5 } {} test string-5.6 {string index} { list [catch {string index abcde -10} msg] $msg } {0 {}} test string-5.7 {string index} { list [catch {string index a xyz} msg] $msg | | | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 | string index abcde 5 } {} test string-5.6 {string index} { list [catch {string index abcde -10} msg] $msg } {0 {}} test string-5.7 {string index} { list [catch {string index a xyz} msg] $msg } {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}} test string-5.8 {string index} { string index abc end } c test string-5.9 {string index} { string index abc end-1 } b test string-5.10 {string index, unicode} { |
︙ | ︙ | |||
271 272 273 274 275 276 277 | test string-5.16 {string index, bytearray object with string obj shimmering} { set str "0123456789\x00 abcdedfghi" binary scan $str H* dump string compare [string index $str 10] \x00 } 0 test string-5.17 {string index, bad integer} { list [catch {string index "abc" 08} msg] $msg | | | | | 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 | test string-5.16 {string index, bytearray object with string obj shimmering} { set str "0123456789\x00 abcdedfghi" binary scan $str H* dump string compare [string index $str 10] \x00 } 0 test string-5.17 {string index, bad integer} { list [catch {string index "abc" 08} msg] $msg } {1 {bad index "08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test string-5.18 {string index, bad integer} { list [catch {string index "abc" end-00289} msg] $msg } {1 {bad index "end-00289": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test string-5.19 {string index, bytearray object out of bounds} { string index [binary format I* {0x50515253 0x52}] -1 } {} test string-5.20 {string index, bytearray object out of bounds} { string index [binary format I* {0x50515253 0x52}] 20 } {} proc largest_int {} { # This will give us what the largest valid int on this machine is, # so we can test for overflow properly below on >32 bit systems set int 1 set exp 7; # assume we get at least 8 bits while {wide($int) > 0} { set int [expr {wide(1) << [incr exp]}] } return [expr {$int-1}] } test string-6.1 {string is, too few args} { list [catch {string is} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} test string-6.2 {string is, too few args} { |
︙ | ︙ | |||
405 406 407 408 409 410 411 | test string-6.36 {string is double, false} { list [string is double -fail var "\n"] $var } {0 0} test string-6.37 {string is double, false on int overflow} { # Make it the largest int recognizable, with one more digit for overflow list [string is double -fail var [largest_int]0] $var } {0 -1} | | < < < | > > | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 | test string-6.36 {string is double, false} { list [string is double -fail var "\n"] $var } {0 0} test string-6.37 {string is double, false on int overflow} { # Make it the largest int recognizable, with one more digit for overflow list [string is double -fail var [largest_int]0] $var } {0 -1} # string-6.38 removed, underflow on input is no longer an error. test string-6.39 {string is double, false} { # This test is non-portable because IRIX thinks # that .e1 is a valid double - this is really a bug # on IRIX as .e1 should NOT be a valid double # # Portable now. Tcl 8.5 does its own double parsing. list [string is double -fail var .e1] $var } {0 0} test string-6.40 {string is false, true} { string is false false } 1 test string-6.41 {string is false, true} { |
︙ | ︙ | |||
662 663 664 665 666 667 668 | catch {rename largest_int {}} test string-7.1 {string last, too few args} { list [catch {string last a} msg] $msg } {1 {wrong # args: should be "string last subString string ?startIndex?"}} test string-7.2 {string last, bad args} { list [catch {string last a b c} msg] $msg | | | 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 | catch {rename largest_int {}} test string-7.1 {string last, too few args} { list [catch {string last a} msg] $msg } {1 {wrong # args: should be "string last subString string ?startIndex?"}} test string-7.2 {string last, bad args} { list [catch {string last a b c} msg] $msg } {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} test string-7.3 {string last, too many args} { list [catch {string last a b c d} msg] $msg } {1 {wrong # args: should be "string last subString string ?startIndex?"}} test string-7.4 {string last} { string la xxx xxxx123xx345x678 } 1 test string-7.5 {string last} { |
︙ | ︙ | |||
804 805 806 807 808 809 810 | test string-10.19 {string map, empty arguments} { string map -nocase {{} abc f bar {} def} foo } baroo test string-10.20 {string map, dictionaries can alter map ordering} { set map {aa X a Y} list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] } {YYY XY 2 XY} | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | test string-10.19 {string map, empty arguments} { string map -nocase {{} abc f bar {} def} foo } baroo test string-10.20 {string map, dictionaries can alter map ordering} { set map {aa X a Y} list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] } {YYY XY 2 XY} test string-10.21 {string map, ABR checks} { string map {longstring foob} long } long test string-10.22 {string map, ABR checks} { string map {long foob} long } foob test string-10.23 {string map, ABR checks} { string map {lon foob} long } foobg test string-10.24 {string map, ABR checks} { string map {lon foob} longlo } foobglo test string-10.25 {string map, ABR checks} { string map {lon foob} longlon } foobgfoob test string-10.26 {string map, ABR checks} { string map {longstring foob longstring bar} long } long test string-10.27 {string map, ABR checks} { string map {long foob longstring bar} long } foob test string-10.28 {string map, ABR checks} { string map {lon foob longstring bar} long } foobg test string-10.29 {string map, ABR checks} { string map {lon foob longstring bar} longlo } foobglo test string-10.30 {string map, ABR checks} { string map {lon foob longstring bar} longlon } foobgfoob test string-10.31 {string map, nasty sharing crash from [Bug 1018562]} { set a {a b} string map $a $a } {b b} test string-11.1 {string match, too few args} { list [catch {string match a} msg] $msg } {1 {wrong # args: should be "string match ?-nocase? pattern string"}} |
︙ | ︙ | |||
1017 1018 1019 1020 1021 1022 1023 | test string-12.4 {string range} { string range abcdefghijklmnop 2 14 } {cdefghijklmno} test string-12.5 {string range, last > length} { string range abcdefghijklmnop 7 1000 } {hijklmnop} test string-12.6 {string range} { | | | | | | 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 | test string-12.4 {string range} { string range abcdefghijklmnop 2 14 } {cdefghijklmno} test string-12.5 {string range, last > length} { string range abcdefghijklmnop 7 1000 } {hijklmnop} test string-12.6 {string range} { string range abcdefghijklmnop 10 end } {klmnop} test string-12.7 {string range, last < first} { string range abcdefghijklmnop 10 9 } {} test string-12.8 {string range, first < 0} { string range abcdefghijklmnop -3 2 } {abc} test string-12.9 {string range} { string range abcdefghijklmnop -3 -2 } {} test string-12.10 {string range} { string range abcdefghijklmnop 1000 1010 } {} test string-12.11 {string range} { string range abcdefghijklmnop -100 end } {abcdefghijklmnop} test string-12.12 {string range} { list [catch {string range abc abc 1} msg] $msg } {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}} test string-12.13 {string range} { list [catch {string range abc 1 eof} msg] $msg } {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}} test string-12.14 {string range} { string range abcdefghijklmnop end-1 end } {op} test string-12.15 {string range} { string range abcdefghijklmnop end 1000 } {p} test string-12.16 {string range} { string range abcdefghijklmnop end end-1 } {} test string-12.17 {string range, unicode} { string range ab\u7266cdefghijklmnop 5 5 } e |
︙ | ︙ | |||
1127 1128 1129 1130 1131 1132 1133 | test string-14.5 {string replace} { string replace abcdefghijklmnop 2 14 } {abp} test string-14.6 {string replace} { string replace abcdefghijklmnop 7 1000 } {abcdefg} test string-14.7 {string replace} { | | | | | | | 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 | test string-14.5 {string replace} { string replace abcdefghijklmnop 2 14 } {abp} test string-14.6 {string replace} { string replace abcdefghijklmnop 7 1000 } {abcdefg} test string-14.7 {string replace} { string replace abcdefghijklmnop 10 end } {abcdefghij} test string-14.8 {string replace} { string replace abcdefghijklmnop 10 9 } {abcdefghijklmnop} test string-14.9 {string replace} { string replace abcdefghijklmnop -3 2 } {defghijklmnop} test string-14.10 {string replace} { string replace abcdefghijklmnop -3 -2 } {abcdefghijklmnop} test string-14.11 {string replace} { string replace abcdefghijklmnop 1000 1010 } {abcdefghijklmnop} test string-14.12 {string replace} { string replace abcdefghijklmnop -100 end } {} test string-14.13 {string replace} { list [catch {string replace abc abc 1} msg] $msg } {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}} test string-14.14 {string replace} { list [catch {string replace abc 1 eof} msg] $msg } {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}} test string-14.15 {string replace} { string replace abcdefghijklmnop end-10 end-2 NEW } {abcdeNEWop} test string-14.16 {string replace} { string replace abcdefghijklmnop 0 end foo } {foo} test string-14.17 {string replace} { string replace abcdefghijklmnop end end-1 } {abcdefghijklmnop} test string-15.1 {string tolower too few args} { list [catch {string tolower} msg] $msg } {1 {wrong # args: should be "string tolower string ?first? ?last?"}} test string-15.2 {string tolower bad args} { list [catch {string tolower a b} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} test string-15.3 {string tolower too many args} { list [catch {string tolower ABC 1 end oops} msg] $msg } {1 {wrong # args: should be "string tolower string ?first? ?last?"}} test string-15.4 {string tolower} { string tolower ABCDeF } {abcdef} test string-15.5 {string tolower} { |
︙ | ︙ | |||
1196 1197 1198 1199 1200 1201 1202 | } "abcabc\xe7\xe7" test string-16.1 {string toupper} { list [catch {string toupper} msg] $msg } {1 {wrong # args: should be "string toupper string ?first? ?last?"}} test string-16.2 {string toupper} { list [catch {string toupper a b} msg] $msg | | | 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 | } "abcabc\xe7\xe7" test string-16.1 {string toupper} { list [catch {string toupper} msg] $msg } {1 {wrong # args: should be "string toupper string ?first? ?last?"}} test string-16.2 {string toupper} { list [catch {string toupper a b} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} test string-16.3 {string toupper} { list [catch {string toupper a 1 end oops} msg] $msg } {1 {wrong # args: should be "string toupper string ?first? ?last?"}} test string-16.4 {string toupper} { string toupper abCDEf } {ABCDEF} test string-16.5 {string toupper} { |
︙ | ︙ | |||
1227 1228 1229 1230 1231 1232 1233 | } "ABCABC\xc7\xc7" test string-17.1 {string totitle} { list [catch {string totitle} msg] $msg } {1 {wrong # args: should be "string totitle string ?first? ?last?"}} test string-17.2 {string totitle} { list [catch {string totitle a b} msg] $msg | | | 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 | } "ABCABC\xc7\xc7" test string-17.1 {string totitle} { list [catch {string totitle} msg] $msg } {1 {wrong # args: should be "string totitle string ?first? ?last?"}} test string-17.2 {string totitle} { list [catch {string totitle a b} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} test string-17.3 {string totitle} { string totitle abCDEf } {Abcdef} test string-17.4 {string totitle} { string totitle "abc xYz" } {Abc xyz} test string-17.5 {string totitle} { |
︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 | list [catch {string wordend a} msg] $msg } {1 {wrong # args: should be "string wordend string index"}} test string-21.2 {string wordend} { list [catch {string wordend a b c} msg] $msg } {1 {wrong # args: should be "string wordend string index"}} test string-21.3 {string wordend} { list [catch {string wordend a gorp} msg] $msg | | | 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 | list [catch {string wordend a} msg] $msg } {1 {wrong # args: should be "string wordend string index"}} test string-21.2 {string wordend} { list [catch {string wordend a b c} msg] $msg } {1 {wrong # args: should be "string wordend string index"}} test string-21.3 {string wordend} { list [catch {string wordend a gorp} msg] $msg } {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} test string-21.4 {string wordend} { string wordend abc. -1 } 3 test string-21.5 {string wordend} { string wordend abc. 100 } 4 test string-21.6 {string wordend} { |
︙ | ︙ | |||
1355 1356 1357 1358 1359 1360 1361 | list [catch {string wordstart a} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} test string-22.3 {string wordstart} { list [catch {string wordstart a b c} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} test string-22.4 {string wordstart} { list [catch {string wordstart a gorp} msg] $msg | | | 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 | list [catch {string wordstart a} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} test string-22.3 {string wordstart} { list [catch {string wordstart a b c} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} test string-22.4 {string wordstart} { list [catch {string wordstart a gorp} msg] $msg } {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} test string-22.5 {string wordstart} { string wordstart "one two three_words" 400 } 8 test string-22.6 {string wordstart} { string wordstart "one two three_words" 2 } 0 test string-22.7 {string wordstart} { |
︙ | ︙ | |||
1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 | } 4 test string-22.12 {string wordstart, unicode} { string wordstart "ab\uc700\uc700 cdef ghi" 12 } 10 test string-22.13 {string wordstart, unicode} { string wordstart "\uc700\uc700 abc" 8 } 3 # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } 4 test string-22.12 {string wordstart, unicode} { string wordstart "ab\uc700\uc700 cdef ghi" 12 } 10 test string-22.13 {string wordstart, unicode} { string wordstart "\uc700\uc700 abc" 8 } 3 test string-23.0 {string is boolean, Bug 1187123} testindexobj { set x 5 catch {testindexobj $x foo bar soom} string is boolean $x } 0 test string-23.1 {string is command with empty string} { set s "" list \ [string is alnum $s] \ [string is alpha $s] \ [string is ascii $s] \ [string is control $s] \ [string is boolean $s] \ [string is digit $s] \ [string is double $s] \ [string is false $s] \ [string is graph $s] \ [string is integer $s] \ [string is lower $s] \ [string is print $s] \ [string is punct $s] \ [string is space $s] \ [string is true $s] \ [string is upper $s] \ [string is wordchar $s] \ [string is xdigit $s] \ } {1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1} test string-23.2 {string is command with empty string} { set s "" list \ [string is alnum -strict $s] \ [string is alpha -strict $s] \ [string is ascii -strict $s] \ [string is control -strict $s] \ [string is boolean -strict $s] \ [string is digit -strict $s] \ [string is double -strict $s] \ [string is false -strict $s] \ [string is graph -strict $s] \ [string is integer -strict $s] \ [string is lower -strict $s] \ [string is print -strict $s] \ [string is punct -strict $s] \ [string is space -strict $s] \ [string is true -strict $s] \ [string is upper -strict $s] \ [string is wordchar -strict $s] \ [string is xdigit -strict $s] \ } {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to tests/stringComp.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # # Copyright (c) 2001 by ActiveState Corporation. # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # # Copyright (c) 2001 by ActiveState Corporation. # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: stringComp.test,v 1.8.2.1 2005/05/05 17:56:36 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } # Some tests require the testobj command |
︙ | ︙ | |||
222 223 224 225 226 227 228 | test stringComp-4.1 {string first, too few args} { proc foo {} {string first a} list [catch {foo} msg] $msg } {1 {wrong # args: should be "string first subString string ?startIndex?"}} test stringComp-4.2 {string first, bad args} { proc foo {} {string first a b c} list [catch {foo} msg] $msg | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 | test stringComp-4.1 {string first, too few args} { proc foo {} {string first a} list [catch {foo} msg] $msg } {1 {wrong # args: should be "string first subString string ?startIndex?"}} test stringComp-4.2 {string first, bad args} { proc foo {} {string first a b c} list [catch {foo} msg] $msg } {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} test stringComp-4.3 {string first, too many args} { proc foo {} {string first a b 5 d} list [catch {foo} msg] $msg } {1 {wrong # args: should be "string first subString string ?startIndex?"}} test stringComp-4.4 {string first} { proc foo {} {string first bq abcdefgbcefgbqrs} foo |
︙ | ︙ | |||
299 300 301 302 303 304 305 | test stringComp-5.6 {string index} { proc foo {} {string index abcde -10} list [catch {foo} msg] $msg } {0 {}} test stringComp-5.7 {string index} { proc foo {} {string index a xyz} list [catch {foo} msg] $msg | | | 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 | test stringComp-5.6 {string index} { proc foo {} {string index abcde -10} list [catch {foo} msg] $msg } {0 {}} test stringComp-5.7 {string index} { proc foo {} {string index a xyz} list [catch {foo} msg] $msg } {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}} test stringComp-5.8 {string index} { proc foo {} {string index abc end} foo } c test stringComp-5.9 {string index} { proc foo {} {string index abc end-1} foo |
︙ | ︙ | |||
348 349 350 351 352 353 354 | string compare [string index $str 10] \x00 } foo } 0 test stringComp-5.17 {string index, bad integer} { proc foo {} {string index "abc" 08} list [catch {foo} msg] $msg | | | | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | string compare [string index $str 10] \x00 } foo } 0 test stringComp-5.17 {string index, bad integer} { proc foo {} {string index "abc" 08} list [catch {foo} msg] $msg } {1 {bad index "08": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test stringComp-5.18 {string index, bad integer} { proc foo {} {string index "abc" end-00289} list [catch {foo} msg] $msg } {1 {bad index "end-00289": must be integer?[+-]integer? or end?[+-]integer? (looks like invalid octal number)}} test stringComp-5.19 {string index, bytearray object out of bounds} { proc foo {} {string index [binary format I* {0x50515253 0x52}] -1} foo } {} test stringComp-5.20 {string index, bytearray object out of bounds} { proc foo {} {string index [binary format I* {0x50515253 0x52}] 20} foo |
︙ | ︙ |
Changes to tests/switch.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: switch # # 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) 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: switch # # 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) 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: switch.test,v 1.10.2.2 2005/07/12 20:37:12 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } test switch-1.1 {simple patterns} { |
︙ | ︙ | |||
35 36 37 38 39 40 41 42 43 44 45 46 47 48 | } 2 test switch-1.6 {simple patterns} { switch default a {format 1} default {format 2} c {format 3} default {format 4} } 2 test switch-1.7 {simple patterns} { switch x a {format 1} default {format 2} c {format 3} default {format 4} } 4 test switch-2.1 {single-argument form for pattern/command pairs} { switch b { a {format 1} b {format 2} default {format 6} } | > > > > > > > > > > > > | 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 | } 2 test switch-1.6 {simple patterns} { switch default a {format 1} default {format 2} c {format 3} default {format 4} } 2 test switch-1.7 {simple patterns} { switch x a {format 1} default {format 2} c {format 3} default {format 4} } 4 test switch-1.8 {simple patterns with -nocase} { switch -nocase b a {format 1} b {format 2} c {format 3} default {format 4} } 2 test switch-1.9 {simple patterns with -nocase} { switch -nocase B a {format 1} b {format 2} c {format 3} default {format 4} } 2 test switch-1.10 {simple patterns with -nocase} { switch -nocase b a {format 1} B {format 2} c {format 3} default {format 4} } 2 test switch-1.11 {simple patterns with -nocase} { switch -nocase x a {format 1} default {format 2} c {format 3} default {format 4} } 4 test switch-2.1 {single-argument form for pattern/command pairs} { switch b { a {format 1} b {format 2} default {format 6} } |
︙ | ︙ | |||
85 86 87 88 89 90 91 | -* {concat glob} -glob {concat exact} default {concat none} } } exact test switch-3.6 {-exact vs. -glob vs. -regexp} { list [catch {switch -foo a b c} msg] $msg | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | -* {concat glob} -glob {concat exact} default {concat none} } } exact test switch-3.6 {-exact vs. -glob vs. -regexp} { list [catch {switch -foo a b c} msg] $msg } {1 {bad option "-foo": must be -exact, -glob, -indexvar, -matchvar, -nocase, -regexp, or --}} test switch-3.7 {-exact vs. -glob vs. -regexp with -nocase} { switch -exact -nocase aaaab { ^a*b$ {concat regexp} *b {concat glob} aaaab {concat exact} default {concat none} } } exact test switch-3.8 {-exact vs. -glob vs. -regexp with -nocase} { switch -regexp -nocase aaaab { ^a*b$ {concat regexp} *b {concat glob} aaaab {concat exact} default {concat none} } } regexp test switch-3.9 {-exact vs. -glob vs. -regexp with -nocase} { switch -glob -nocase aaaab { ^a*b$ {concat regexp} *b {concat glob} aaaab {concat exact} default {concat none} } } glob test switch-3.10 {-exact vs. -glob vs. -regexp with -nocase} { switch -nocase aaaab {^a*b$} {concat regexp} *b {concat glob} \ aaaab {concat exact} default {concat none} } exact test switch-3.11 {-exact vs. -glob vs. -regexp with -nocase} { switch -nocase -- -glob { ^g.*b$ {concat regexp} -* {concat glob} -glob {concat exact} default {concat none} } } exact test switch-3.7 {-exact vs. -glob vs. -regexp} { list [catch {switch -exa Foo Foo {set result OK}} msg] $msg } {0 OK} test switch-3.8 {-exact vs. -glob vs. -regexp} { list [catch {switch -gl Foo Fo? {set result OK}} msg] $msg } {0 OK} test switch-3.9 {-exact vs. -glob vs. -regexp} { list [catch {switch -re Foo Fo. {set result OK}} msg] $msg } {0 OK} test switch-3.10 {-exact vs. -glob vs. -regexp} { list [catch {switch -exact -exact Foo Foo {set result OK}} msg] $msg } {1 {bad option "-exact": -exact option already found}} test switch-3.11 {-exact vs. -glob vs. -regexp} { list [catch {switch -exact -glob Foo Foo {set result OK}} msg] $msg } {1 {bad option "-glob": -exact option already found}} test switch-3.12 {-exact vs. -glob vs. -regexp} { list [catch {switch -glob -regexp Foo Foo {set result OK}} msg] $msg } {1 {bad option "-regexp": -glob option already found}} test switch-3.13 {-exact vs. -glob vs. -regexp} { list [catch {switch -regexp -glob Foo Foo {set result OK}} msg] $msg } {1 {bad option "-glob": -regexp option already found}} test switch-4.1 {error in executed command} { list [catch {switch a a {error "Just a test"} default {format 1}} msg] \ $msg $errorInfo } {1 {Just a test} {Just a test while executing "error "Just a test"" |
︙ | ︙ | |||
168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 | switch a { a - b -foo c - } } msg] $msg } {1 {no body specified for pattern "c"}} test switch-8.1 {empty body} { set msg {} switch {2} { 1 {set msg 1} 2 {} default {set msg 2} } } {} test switch-9.1 {empty pattern/body list} { list [catch {switch x} msg] $msg } {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}} test switch-9.2 {empty pattern/body list} { list [catch {switch -- x} msg] $msg } {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}} | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | switch a { a - b -foo c - } } msg] $msg } {1 {no body specified for pattern "c"}} test switch-7.4 {"-" bodies} { list [catch { switch a { a - b -foo c {} } } msg] $msg } {1 {invalid command name "-foo"}} test switch-8.1 {empty body} { set msg {} switch {2} { 1 {set msg 1} 2 {} default {set msg 2} } } {} proc test_switch_body {} { return "INVOKED" } test switch-8.2 {weird body text, variable} { set cmd {test_switch_body} switch Foo { Foo $cmd } } {INVOKED} test switch-8.3 {weird body text, variable} { set cmd {test_switch_body} switch Foo { Foo {$cmd} } } {INVOKED} test switch-9.1 {empty pattern/body list} { list [catch {switch x} msg] $msg } {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}} test switch-9.2 {empty pattern/body list} { list [catch {switch -- x} msg] $msg } {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}} |
︙ | ︙ | |||
252 253 254 255 256 257 258 259 260 261 | set x 0; set y 0 foreach c [split $s {}] { switch -glob -- $c { a {incr x} b {incr y} } } return $x,$y } proc iswtest-glob s { | > > > > | > > > > > > > | > > > > | > > > > > > > | > > > > | > > > > > > > > | < < < | > > > > > > > | > > > > > > > > | | | | | | | | | 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 | set x 0; set y 0 foreach c [split $s {}] { switch -glob -- $c { a {incr x} b {incr y} } } set x [expr {$x*100}]; set y [expr {$y*100}] foreach c [split $s {}] { switch -glob -- $c a {incr x} b {incr y} } return $x,$y } proc iswtest-glob s { set x 0; set y 0; set switch switch foreach c [split $s {}] { $switch -glob -- $c { a {incr x} b {incr y} } } set x [expr {$x*100}]; set y [expr {$y*100}] foreach c [split $s {}] { $switch -glob -- $c a {incr x} b {incr y} } return $x,$y } proc cswtest-exact s { set x 0; set y 0 foreach c [split $s {}] { switch -exact -- $c { a {incr x} b {incr y} } } set x [expr {$x*100}]; set y [expr {$y*100}] foreach c [split $s {}] { switch -exact -- $c a {incr x} b {incr y} } return $x,$y } proc iswtest-exact s { set x 0; set y 0; set switch switch foreach c [split $s {}] { $switch -exact -- $c { a {incr x} b {incr y} } } set x [expr {$x*100}]; set y [expr {$y*100}] foreach c [split $s {}] { $switch -exact -- $c a {incr x} b {incr y} } return $x,$y } proc cswtest2-glob s { set x 0; set y 0; set z 0 foreach c [split $s {}] { switch -glob -- $c { a {incr x} b {incr y} default {incr z} } } set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] foreach c [split $s {}] { switch -glob -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z } proc iswtest2-glob s { set x 0; set y 0; set z 0; set switch switch foreach c [split $s {}] { $switch -glob -- $c { a {incr x} b {incr y} default {incr z} } } set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] foreach c [split $s {}] { $switch -glob -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z } proc cswtest2-exact s { set x 0; set y 0; set z 0 foreach c [split $s {}] { switch -exact -- $c { a {incr x} b {incr y} default {incr z} } } set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] foreach c [split $s {}] { switch -exact -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z } proc iswtest2-exact s { set x 0; set y 0; set z 0; set switch switch foreach c [split $s {}] { $switch -exact -- $c { a {incr x} b {incr y} default {incr z} } } set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] foreach c [split $s {}] { $switch -exact -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z } test switch-10.7 {comparison of compiled and interpreted behaviour of switch, exact matching} { cswtest-exact abcb } [iswtest-exact abcb] test switch-10.8 {comparison of compiled and interpreted behaviour of switch, glob matching} { cswtest-glob abcb } [iswtest-glob abcb] test switch-10.9 {comparison of compiled and interpreted behaviour of switch, exact matching with default} { cswtest2-exact abcb } [iswtest2-exact abcb] test switch-10.10 {comparison of compiled and interpreted behaviour of switch, glob matching with default} { cswtest2-glob abcb } [iswtest2-glob abcb] proc cswtest-default-exact {x} { switch -- $x { a* {return b} aa {return c} default {return d} } } |
︙ | ︙ |
Changes to tests/tcltest.test.
1 2 3 4 5 6 7 8 | # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # # RCS: @(#) $Id: tcltest.test,v 1.48.2.1 2005/03/09 15:57:19 kennykb 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]. # |
︙ | ︙ | |||
695 696 697 698 699 700 701 | file delete -force $notReadableDir $notWriteableDir removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory # -file, -notfile, [matchFiles], [skipFiles] | | | | | | | | 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 | file delete -force $notReadableDir $notWriteableDir removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory # -file, -notfile, [matchFiles], [skipFiles] test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { slave msg [file join [testsDirectory] all.tcl] -file d*.test set msg } -cleanup { testsDirectory $old } -match regexp -result {dstring\.test} test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { slave msg [file join [testsDirectory] all.tcl] \ -file d*.test -notfile dstring* regexp {dstring\.test} $msg } -cleanup { testsDirectory $old } -result 0 test tcltest-9.3 {matchFiles} { -body { set old [matchFiles] |
︙ | ︙ | |||
741 742 743 744 745 746 747 748 749 750 751 752 753 754 | skipFiles bar set new [skipFiles] skipFiles $old list $current $new } -result {foo bar} } # -preservecore, [preserveCore] set mc [makeFile { package require tcltest namespace import ::tcltest::test test makecore {make a core file} { set f [open core w] | > > > > > > > > > > > > > > > | 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 | skipFiles bar set new [skipFiles] skipFiles $old list $current $new } -result {foo bar} } test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { set d [makeDirectory tmp] makeDirectory foo $d makeFile {} fee $d file copy [file join [file dirname [info script]] all.tcl] $d } -body { slave msg [file join [temporaryDirectory] all.tcl] -file f* regexp {exiting with errors:} $msg } -cleanup { file delete [file join $d all.tcl] removeFile fee $d removeDirectory foo $d removeDirectory tmp } -result 0 # -preservecore, [preserveCore] set mc [makeFile { package require tcltest namespace import ::tcltest::test test makecore {make a core file} { set f [open core w] |
︙ | ︙ |
Changes to tests/tm.test.
1 2 3 4 5 6 7 8 | # This file contains tests for the ::tcl::tm::* commands. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 2004 by Donal K. Fellows. # All rights reserved. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | # This file contains tests for the ::tcl::tm::* commands. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 2004 by Donal K. Fellows. # All rights reserved. # # RCS: @(#) $Id: tm.test,v 1.5.2.1 2005/09/09 18:48:40 dgp Exp $ package require Tcl 8.5 if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } |
︙ | ︙ | |||
200 201 202 203 204 205 206 | proc genpaths {base} { # Normalizing picks up drive letters on windows [Bug 1053568] set base [file normalize $base] foreach {major minor} [split [info tclversion] .] break set results {} | < > | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 | proc genpaths {base} { # Normalizing picks up drive letters on windows [Bug 1053568] set base [file normalize $base] foreach {major minor} [split [info tclversion] .] break set results {} set base [file join $base tcl$major] lappend results [file join $base site-tcl] for {set i 0} {$i <= $minor} {incr i} { lappend results [file join $base ${major}.$i] } return $results } test tm-3.12 {tm: module path management, roots} -setup { |
︙ | ︙ |
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.37.2.2 2005/08/02 18:16:43 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } testConstraint testcmdtrace [llength [info commands testcmdtrace]] |
︙ | ︙ | |||
2200 2201 2202 2203 2204 2205 2206 | test trace-33.1 {variable match with remove variable} { unset -nocomplain x trace variable x w foo trace remove variable x write foo llength [trace info variable x] } 0 | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 | test trace-33.1 {variable match with remove variable} { unset -nocomplain x trace variable x w foo trace remove variable x write foo llength [trace info variable x] } 0 test trace-34.1 {Bug 1201035} { set ::x [list] proc foo {} {lappend ::x foo} proc bar args { lappend ::x $args trace remove execution foo leavestep bar trace remove execution foo enterstep bar trace add execution foo leavestep bar trace add execution foo enterstep bar lappend ::x done } trace add execution foo leavestep bar trace add execution foo enterstep bar foo set ::x } {{{lappend ::x foo} enterstep} done foo} test trace-34.2 {Bug 1224585} { proc foo {} {} proc bar args {trace remove execution foo leave soom} trace add execution foo leave bar trace add execution foo leave soom foo } {} test trace-34.3 {Bug 1224585} { proc foo {} {set x {}} proc bar args {trace remove execution foo enterstep soom} trace add execution foo enterstep soom trace add execution foo enterstep bar foo } {} test trace-34.4 {Bug 1047286} { variable x notrace proc callback {old - -} { variable x "$old exists: [namespace which -command $old]" } namespace eval ::foo {proc bar {} {}} trace add command ::foo::bar delete [namespace code callback] namespace delete ::foo set x } {::foo::bar exists: ::foo::bar} test trace-35.1 {527164: Keep -errorinfo of traces} -setup { unset -nocomplain x y } -body { trace add variable x write {error foo;#} trace add variable y write {set x 2;#} list [catch {set y 1} msg opts] $msg [dict get $opts -errorinfo] } -cleanup { unset -nocomplain x y |
︙ | ︙ |
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 | # 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.44.2.3 2005/05/05 17:56:37 kennykb Exp $ package require tcltest 2.2 namespace import -force ::tcltest::* unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { set x {} |
︙ | ︙ | |||
88 89 90 91 92 93 94 | } then { subst "OK" } else { subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'" } } {OK} | | | < < < | < | | < < < | < > | < < | 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 | } then { subst "OK" } else { subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'" } } {OK} # The unixInit-2.* tests were written to test the internal routine, # TclpInitLibraryPath. That routine no longer does the things it used # to do so those tests are obsolete. Skip them. skip [concat [skip] unixInit-2.*] test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} { set origDir [testgetdefenc] testsetdefenc slappy set path [testgetdefenc] testsetdefenc $origDir set path } {slappy} test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) unset env(TCL_LIBRARY) } } -body { set path [getlibpath] |
︙ | ︙ | |||
134 135 136 137 138 139 140 | set x } -cleanup { if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result {0 0} | > | < < > | < < > | < < | < > | < < | 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 | set x } -cleanup { if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result {0 0} test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } } -body { # ((str != NULL) && (str[0] != '\0')) set env(TCL_LIBRARY) sparkly set path [getlibpath] unset env(TCL_LIBRARY) lindex $path 0 } -cleanup { if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result "sparkly" test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } } -body { # ((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 } -cleanup { if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result [list /a/b/tcl1.7 /a/b/tcl[info tclversion]] test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup { if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } } -body { # 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 } -cleanup { if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result "\xa7" test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} { # cannot test } {} test unixInit-2.6 {TclpInitLibraryPath: executable relative} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } set env(TCL_LIBRARY) [info library] makeDirectory tmp makeDirectory [file join tmp sparkly] |
︙ | ︙ | |||
234 235 236 237 238 239 240 | unset env(TCL_LIBRARY) if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]] | | < > < < < | < < | 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 | unset env(TCL_LIBRARY) if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]] test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} { # 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. # test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } set env(TCL_LIBRARY) [info library] # Checking for Bug 219416 # When a program that embeds the Tcl library, like tcltest, is |
︙ | ︙ | |||
311 312 313 314 315 316 317 | if {$deletelib} {file delete -force /tmp/lib} unset env(TCL_LIBRARY) if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result 1 | | | < < | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 | if {$deletelib} {file delete -force /tmp/lib} unset env(TCL_LIBRARY) if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result 1 test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} -setup { # Checking for Bug 438014 unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } set env(TCL_LIBRARY) [info library] file delete -force /tmp/sparkly |
︙ | ︙ | |||
341 342 343 344 345 346 347 | if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \ /tmp/library /library /tcl[info patchlevel]/library] | | < < | 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 | if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } } -result [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \ /tmp/library /library /tcl[info patchlevel]/library] test unixInit-2.10 {TclpInitLibraryPath: executable relative} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } set env(TCL_LIBRARY) [info library] set tmpDir [makeDirectory tmp] set sparklyDir [makeDirectory sparkly $tmpDir] |
︙ | ︙ | |||
448 449 450 451 452 453 454 | test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unix} { } {} test unixInit-7.1 {closed standard channel: Bug 772288} -constraints { unix stdio } -body { set tclsh [interpreter] | | | | | | | 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 | test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unix} { } {} test unixInit-7.1 {closed standard channel: Bug 772288} -constraints { unix stdio } -body { set tclsh [interpreter] set crash [makeFile {puts [open /dev/null]} crash.tcl] set crashtest [makeFile " close stdin [list exec $tclsh $crash] " crashtest.tcl] exec $tclsh $crashtest } -cleanup { removeFile crash.tcl removeFile crashtest.tcl } -returnCodes 0 # cleanup catch {unset env(LANG)} catch {set env(LANG) $oldlang} unset -nocomplain path ::tcltest::cleanupTests return |
Changes to tests/unixNotfy.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file contains tests for tclUnixNotfy.c. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | # 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.17.2.1 2005/05/21 15:10:27 kennykb Exp $ # The tests should not be run if you have a notifier which is unable to # detect infinite vwaits, as the tests below will hang. The presence of # the "testthread" command indicates that this is the case. if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # When run in a Tk shell, these tests hang. testConstraint noTk [expr {![info exists tk_version]}] testConstraint testthread [expr {[info commands testthread] != {}}] # Darwin always uses a threaded notifier testConstraint unthreaded [expr { (![info exist tcl_platform(threaded)] || !$tcl_platform(threaded)) && $tcl_platform(os) ne "Darwin" }] # The next two tests will hang if threads are enabled because the notifier # will not necessarily wait for ever in this case, so it does not generate # an error. test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { catch {vwait x} |
︙ | ︙ |
Changes to tests/utf.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for tclUtf.c # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | # This file contains a collection of tests for tclUtf.c # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: utf.test,v 1.12.2.1 2005/09/09 18:48:40 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } catch {unset x} test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} { set x \x01 } [bytestring "\x01"] test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} { set x "\x00" } [bytestring "\xc0\x80"] test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} { set x "\xe0" } [bytestring "\xc3\xa0"] test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} { set x "\u4e4e" } [bytestring "\xe4\xb9\x8e"] test utf-1.5 {Tcl_UniCharToUtf: negative Tcl_UniChar} { string length [format %c -1] } 1 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" } {3} test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} { string length [bytestring "\x82\x83\x84"] } {3} |
︙ | ︙ |
Changes to tests/util.test.
1 2 3 4 5 6 7 8 9 | # This file is a Tcl script to test the code in the file tclUtil.c. # This file is organized in the standard fashion for Tcl tests. # # Copyright (c) 1995-1998 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 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 | # This file is a Tcl script to test the code in the file tclUtil.c. # This file is organized in the standard fashion for Tcl tests. # # Copyright (c) 1995-1998 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: util.test,v 1.14.2.4 2005/05/21 15:10:27 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues binary scan [binary format dd -1.0 1.0] c* c switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ ieeeValues(-Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ ieeeValues(+Normal) binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ ieeeValues(+Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-0) binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 } default { return 0 } } } ::tcltest::testConstraint ieeeFloatingPoint [testIEEE] proc convertDouble { x } { variable ieeeValues if { $ieeeValues(littleEndian) } { binary scan [binary format w $x] d result } else { binary scan [binary format W $x] d result } return $result } test util-1.1 {TclFindElement procedure - binary element in middle of list} { lindex {0 foo\x00help 1} 1 } "foo\x00help" test util-1.2 {TclFindElement procedure - binary element at end of list} { lindex {0 foo\x00help} 1 } "foo\x00help" |
︙ | ︙ | |||
269 270 271 272 273 274 275 | test util-5.50 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch *. "" } 0 test util-5.51 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch "" "" } 1 | | > > > > > | | > > > > > | | > > > > > | | > | > | | > > | | > > > > | | > > > > | | > > > > | | > > > > | < < | 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 | test util-5.50 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch *. "" } 0 test util-5.51 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch "" "" } 1 test util-6.1 {Tcl_PrintDouble - using tcl_precision} -setup { set old_precision $::tcl_precision set ::tcl_precision 12 } -body { concat x[expr 1.4] } -cleanup { set ::tcl_precision $old_precision } -result {x1.4} test util-6.2 {Tcl_PrintDouble - using tcl_precision} -setup { set old_precision $::tcl_precision set ::tcl_precision 12 } -body { concat x[expr 1.39999999999] } -cleanup { set ::tcl_precision $old_precision } -result {x1.39999999999} test util-6.3 {Tcl_PrintDouble - using tcl_precision} -setup { set old_precision $::tcl_precision set ::tcl_precision 12 } -body { concat x[expr 1.399999999999] } -cleanup { set ::tcl_precision $old_precision } -result {x1.4} test util-6.4 {Tcl_PrintDouble - using tcl_precision} -setup { set old_precision $::tcl_precision set ::tcl_precision 5 } -body { concat x[expr 1.123412341234] } -cleanup { set tcl_precision $old_precision } -result {x1.1234} test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr 2.0] } {x2.0} test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr 3.0e98] } {x3e+98} test util-7.1 {TclPrecTraceProc - unset callbacks} -setup { set old_precision $::tcl_precision } -body { set tcl_precision 7 set x $tcl_precision unset tcl_precision list $x $tcl_precision } -cleanup { set ::tcl_precision $old_precision } -result {7 7} test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -setup { set old_precision $::tcl_precision } -body { set tcl_precision 12 interp create child set x [child eval set tcl_precision] child eval {set tcl_precision 6} interp delete child list $x $tcl_precision } -cleanup { set ::tcl_precision $old_precision } -result {12 6} test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -setup { set old_precision $::tcl_precision } -body { set tcl_precision 12 interp create -safe child set x [child eval { list [catch {set tcl_precision 8} msg] $msg }] interp delete child list $x $tcl_precision } -cleanup { set ::tcl_precision $old_precision } -result {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12} test util-7.4 {TclPrecTraceProc - write traces, bogus values} -setup { set old_precision $::tcl_precision } -body { set tcl_precision 12 list [catch {set tcl_precision abc} msg] $msg $tcl_precision } -cleanup { set ::tcl_precision $old_precision } -result {1 {can't set "tcl_precision": improper value for precision} 12} # This test always succeeded in the C locale anyway... test util-8.1 {TclNeedSpace - correct UTF8 handling} { # Bug 411825 # Note that this test relies on the fact that # [interp target] calls on Tcl_AppendElement() # which calls on TclNeedSpace(). If [interp target] |
︙ | ︙ | |||
383 384 385 386 387 388 389 390 391 392 393 | testdstring free testdstring append {\\ } -1 testdstring append \{ -1 testdstring element foo testdstring append \} -1 list [llength [testdstring get]] [string length [testdstring get]] } {2 9} # cleanup ::tcltest::cleanupTests return | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | testdstring free testdstring append {\\ } -1 testdstring append \{ -1 testdstring element foo testdstring append \} -1 list [llength [testdstring get]] [string length [testdstring get]] } {2 9} test util-9.0.0 {TclGetIntForIndex} { string index abcd 0 } a test util-9.0.1 {TclGetIntForIndex} { string index abcd 0x0 } a test util-9.0.2 {TclGetIntForIndex} { string index abcd -0x0 } a test util-9.0.3 {TclGetIntForIndex} { string index abcd { 0 } } a test util-9.0.4 {TclGetIntForIndex} { string index abcd { 0x0 } } a test util-9.0.5 {TclGetIntForIndex} { string index abcd { -0x0 } } a test util-9.0.6 {TclGetIntForIndex} { string index abcd 01 } b test util-9.0.7 {TclGetIntForIndex} { string index abcd { 01 } } b test util-9.1.0 {TclGetIntForIndex} { string index abcd 3 } d test util-9.1.1 {TclGetIntForIndex} { string index abcd { 3 } } d test util-9.1.2 {TclGetIntForIndex} { string index abcdefghijk 0xa } k test util-9.1.3 {TclGetIntForIndex} { string index abcdefghijk { 0xa } } k test util-9.2.0 {TclGetIntForIndex} { string index abcd end } d test util-9.2.1 {TclGetIntForIndex} -body { string index abcd { end} } -returnCodes error -match glob -result * test util-9.2.2 {TclGetIntForIndex} -body { string index abcd {end } } -returnCodes error -match glob -result * test util-9.3 {TclGetIntForIndex} { # Deprecated string index abcd en } d test util-9.4 {TclGetIntForIndex} { # Deprecated string index abcd e } d test util-9.5.0 {TclGetIntForIndex} { string index abcd end-1 } c test util-9.5.1 {TclGetIntForIndex} { string index abcd {end-1 } } c test util-9.5.2 {TclGetIntForIndex} -body { string index abcd { end-1} } -returnCodes error -match glob -result * test util-9.6 {TclGetIntForIndex} { string index abcd end+-1 } c test util-9.7 {TclGetIntForIndex} { string index abcd end+1 } {} test util-9.8 {TclGetIntForIndex} { string index abcd end--1 } {} test util-9.9.0 {TclGetIntForIndex} { string index abcd 0+0 } a test util-9.9.1 {TclGetIntForIndex} { string index abcd { 0+0 } } a test util-9.10 {TclGetIntForIndex} { string index abcd 0-0 } a test util-9.11 {TclGetIntForIndex} { string index abcd 1+0 } b test util-9.12 {TclGetIntForIndex} { string index abcd 1-0 } b test util-9.13 {TclGetIntForIndex} { string index abcd 1+1 } c test util-9.14 {TclGetIntForIndex} { string index abcd 1-1 } a test util-9.15 {TclGetIntForIndex} { string index abcd -1+2 } b test util-9.16 {TclGetIntForIndex} { string index abcd -1--2 } b test util-9.17 {TclGetIntForIndex} { string index abcd { -1+2 } } b test util-9.18 {TclGetIntForIndex} { string index abcd { -1--2 } } b test util-9.19 {TclGetIntForIndex} -body { string index a {} } -returnCodes error -match glob -result * test util-9.20 {TclGetIntForIndex} -body { string index a { } } -returnCodes error -match glob -result * test util-9.21 {TclGetIntForIndex} -body { string index a " \r\t\n" } -returnCodes error -match glob -result * test util-9.22 {TclGetIntForIndex} -body { string index a + } -returnCodes error -match glob -result * test util-9.23 {TclGetIntForIndex} -body { string index a - } -returnCodes error -match glob -result * test util-9.24 {TclGetIntForIndex} -body { string index a x } -returnCodes error -match glob -result * test util-9.25 {TclGetIntForIndex} -body { string index a +x } -returnCodes error -match glob -result * test util-9.26 {TclGetIntForIndex} -body { string index a -x } -returnCodes error -match glob -result * test util-9.27 {TclGetIntForIndex} -body { string index a 0y } -returnCodes error -match glob -result * test util-9.28 {TclGetIntForIndex} -body { string index a 1* } -returnCodes error -match glob -result * test util-9.29 {TclGetIntForIndex} -body { string index a 0+ } -returnCodes error -match glob -result * test util-9.30 {TclGetIntForIndex} -body { string index a {0+ } } -returnCodes error -match glob -result * test util-9.31 {TclGetIntForIndex} -body { string index a 0x } -returnCodes error -match glob -result * test util-9.32 {TclGetIntForIndex} -body { string index a 0x1FFFFFFFF+0 } -returnCodes error -match glob -result * test util-9.33 {TclGetIntForIndex} -body { string index a 100000000000+0 } -returnCodes error -match glob -result * test util-9.34 {TclGetIntForIndex} -body { string index a 1.0 } -returnCodes error -match glob -result * test util-9.35 {TclGetIntForIndex} -body { string index a 1e23 } -returnCodes error -match glob -result * test util-9.36 {TclGetIntForIndex} -body { string index a 1.5e2 } -returnCodes error -match glob -result * test util-9.37 {TclGetIntForIndex} -body { string index a 0+x } -returnCodes error -match glob -result * test util-9.38 {TclGetIntForIndex} -body { string index a 0+0x } -returnCodes error -match glob -result * test util-9.39 {TclGetIntForIndex} -body { string index a 0+0xg } -returnCodes error -match glob -result * test util-9.40 {TclGetIntForIndex} -body { string index a 0+0xg } -returnCodes error -match glob -result * test util-9.41 {TclGetIntForIndex} -body { string index a 0+1.0 } -returnCodes error -match glob -result * test util-9.42 {TclGetIntForIndex} -body { string index a 0+1e2 } -returnCodes error -match glob -result * test util-9.43 {TclGetIntForIndex} -body { string index a 0+1.5e1 } -returnCodes error -match glob -result * test util-9.44 {TclGetIntForIndex} -body { string index a 0+1000000000000 } -returnCodes error -match glob -result * test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x0000000000000000 } {0.0} test util-10.2 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x8000000000000000 } {-0.0} test util-10.3 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x7ef754e31cd072da } {4e+303} test util-10.4 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xd08afcef51f0fb5f } {-1e+80} test util-10.5 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x7ed754e31cd072da } {1e+303} test util-10.6 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xfee754e31cd072da } {-2e+303} test util-10.7 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x0afe07b27dd78b14 } {1e-255} test util-10.8 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x93ae29e9c56687fe } {-7e-214} test util-10.9 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x376be03d0bf225c7 } {1e-41} test util-10.10 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xa0ca2fe76a3f9475 } {-1e-150} test util-10.11 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x7fa9a2028368022e } {9e+306} test util-10.12 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xdfc317e5ef3ab327 } {-2e+153} test util-10.13 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x5fd317e5ef3ab327 } {4e+153} test util-10.14 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xdfe317e5ef3ab327 } {-8e+153} test util-10.15 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x00feb8e84fa0b278 } {7e-304} test util-10.16 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x8133339131c46f8b } {-7e-303} test util-10.17 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x35dc0f92a6276c9d } {3e-49} test util-10.18 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xa445ce1f143d7ad2 } {-6e-134} test util-10.19 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x2d2c0794d9d40e96 } {4.3e-91} test util-10.20 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xad3c0794d9d40e96 } {-8.6e-91} test util-10.21 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x30ecd5bee57763e6 } {5.1e-73} test util-10.22 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x68ad1c26db7d0dae } {1.7e+196} test util-10.23 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbfa3f7ced916872b } {-0.039} test util-10.24 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x64b7d93193f78fc6 } {1.51e+177} test util-10.25 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x98ea82a1631eeb30 } {-1.19e-188} test util-10.26 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xd216c309024bab4b } {-2.83e+87} test util-10.27 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x0dfdbbac6f83a821 } {2.7869147e-241} test util-10.28 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xdadc569e968e0944 } {-4.91080654e+129} test util-10.29 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x5acc569e968e0944 } {2.45540327e+129} test util-10.30 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xab5fc575867314ee } {-9.078555839e-100} test util-10.31 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xdabc569e968e0944 } {-1.227701635e+129} test util-10.32 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x2b6fc575867314ee } {1.8157111678e-99} test util-10.33 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xb3b8bf7e7fa6f02a } {-1.5400733123779e-59} test util-10.34 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xcd83de005bd620df } {-2.6153245263757307e+65} test util-10.35 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x6cdf92bacb3cb40c } {2.7210404151224248e+216} test util-10.36 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xecef92bacb3cb40c } {-5.4420808302448496e+216} test util-10.37 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x49342dbf25096cf5 } {4.5e+44} test util-10.38 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xd06afcef51f0fb5f } {-2.5e+79} test util-10.39 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x49002498ea6df0c4 } {4.5e+43} test util-10.40 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xfeb754e31cd072da } {-2.5e+302} test util-10.41 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x1d22deac01e2b4f7 } {2.5e-168} test util-10.42 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xaccb1df536c13eee } {-6.5e-93} test util-10.43 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3650711fed5b19a4 } {4.5e-47} test util-10.44 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xb6848d67e8b1e00d } {-4.5e-46} test util-10.45 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x4bac8c574c0c6be7 } {3.5e+56} test util-10.46 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xccd756183c147514 } {-1.5e+62} test util-10.47 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x4ca2ab469676c410 } {1.5e+61} test util-10.48 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xcf5539684e774b48 } {-1.5e+74} test util-10.49 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x2e12e5f5dfa4fe9d } {9.5e-87} test util-10.50 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x8b9bdc2417bf7787 } {-9.5e-253} test util-10.51 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x00eeb8e84fa0b278 } {3.5e-304} test util-10.52 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xadde3cbc9907fdc8 } {-9.5e-88} test util-10.53 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x2bb0ad836f269a17 } {3.05e-98} test util-10.54 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x950b39ae1909c31b } {-2.65e-207} test util-10.55 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x1bfb2ab18615fcc6 } {6.865e-174} test util-10.56 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x98f3e1f90a573064 } {-1.785e-188} test util-10.57 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x5206c309024bab4b } {1.415e+87} test util-10.58 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xcc059bd3ad46e346 } {-1.6955e+58} test util-10.59 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x47bdf4170f0fdecc } {3.9815e+37} test util-10.60 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x59e7e1e0f1c7a4ac } {1.263005e+125} test util-10.61 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xda1dda592e398dd7 } {-1.263005e+126} test util-10.62 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xdc4e597c0b94b7ae } {-4.4118455e+136} test util-10.63 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x5aac569e968e0944 } {6.138508175e+128} test util-10.64 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xdabc569e968e0944 } {-1.227701635e+129} test util-10.65 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x6ce7ae0c186d8709 } {4.081560622683637e+216} test util-10.66 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x44b52d02c7e14af7 } {1.0000000000000001e+23} test util-10.67 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc589d971e4fe8402 } {-1e+27} test util-10.68 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x4599d971e4fe8402 } {2e+27} test util-10.69 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc5a9d971e4fe8402 } {-4e+27} test util-10.70 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3e45798ee2308c3a } {1e-8} test util-10.71 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbe55798ee2308c3a } {-2e-8} test util-10.72 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3e65798ee2308c3a } {4e-8} test util-10.73 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbabef2d0f5da7dd9 } {-1e-25} test util-10.74 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x44da784379d99db4 } {5e+23} test util-10.75 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc4fa784379d99db4 } {-2e+24} test util-10.76 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x4503da329b633647 } {3e+24} test util-10.77 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc54cf389cd46047d } {-7e+25} test util-10.78 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3fc999999999999a } {0.2} test util-10.79 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbfd3333333333333 } {-0.3} test util-10.80 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3cf6849b86a12b9b } {5e-15} test util-10.81 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbd16849b86a12b9b } {-2e-14} test util-10.82 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3b87ccfc73126788 } {6.3e-22} test util-10.83 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbbbdc03b8fd7016a } {-6.3e-21} test util-10.84 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3fa3f7ced916872b } {0.039} test util-10.85 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x460b297cad9f70b6 } {2.69e+29} test util-10.86 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc61b297cad9f70b6 } {-5.38e+29} test util-10.87 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3adcdc06b20ef183 } {3.73e-25} test util-10.88 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x45fb297cad9f70b6 } {1.345e+29} test util-10.89 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc60b297cad9f70b6 } {-2.69e+29} test util-10.90 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbc050a246ecd44f3 } {-1.4257e-19} test util-10.91 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbec19b96f36ec68b } {-2.09901e-6} test util-10.92 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3dcc06d366394441 } {5.0980203373e-11} test util-10.93 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc79f58ac4db68c90 } {-1.04166211811e+37} test util-10.94 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x4569d971e4fe8402 } {2.5e+26} test util-10.95 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc50dc74be914d16b } {-4.5e+24} test util-10.96 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x4534adf4b7320335 } {2.5e+25} test util-10.97 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc54ae22487c1042b } {-6.5e+25} test util-10.98 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3c987fe49aab41e0 } {8.5e-17} test util-10.99 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbc2f5c05e4b23fd7 } {-8.5e-19} test util-10.100 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3d5faa7ab552a552 } {4.5e-13} test util-10.101 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbdbb7cdfd9d7bdbb } {-2.5e-11} test util-10.102 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x44f3da329b633647 } {1.5e+24} test util-10.103 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc53cf389cd46047d } {-3.5e+25} test util-10.104 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x454f04ef12cb04cf } {7.5e+25} test util-10.105 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc55f04ef12cb04cf } {-1.5e+26} test util-10.106 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3fc3333333333333 } {0.15} test util-10.107 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbdb07e1fe91b0b70 } {-1.5e-11} test util-10.108 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3de49da7e361ce4c } {1.5e-10} test util-10.109 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbe19c511dc3a41df } {-1.5e-9} test util-10.110 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc5caa83d74267822 } {-1.65e+28} test util-10.111 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x4588f1d5969453de } {9.65e+26} test util-10.112 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3b91d9bd564dcda6 } {9.45e-22} test util-10.113 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbcfa58973ecbede6 } {-5.85e-15} test util-10.114 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x45eb297cad9f70b6 } {6.725e+28} test util-10.115 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc5fb297cad9f70b6 } {-1.345e+29} test util-10.116 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3accdc06b20ef183 } {1.865e-25} test util-10.117 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xbd036071dcae4565 } {-8.605e-15} test util-10.118 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x462cb968d297dde8 } {1.137885e+30} test util-10.119 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0xc661f3e1839eeab1 } {-1.137885e+31} test util-10.120 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x474e9cec176c96f8 } {3.179033335e+35} test util-10.121 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x3dbc06d366394441 } {2.54901016865e-11} test util-10.122 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x478f58ac4db68c90 } {5.20831059055e+36} test util-11.1 {Tcl_PrintDouble - scaling} { expr 1.1e-5 } {1.1e-5} test util-11.2 {Tcl_PrintDouble - scaling} { expr 1.1e-4 } {0.00011} test util-11.3 {Tcl_PrintDouble - scaling} { expr 1.1e-3 } {0.0011} test util-11.4 {Tcl_PrintDouble - scaling} { expr 1.1e-2 } {0.011} test util-11.5 {Tcl_PrintDouble - scaling} { expr 1.1e-1 } {0.11} test util-11.6 {Tcl_PrintDouble - scaling} { expr 1.1e0 } {1.1} test util-11.7 {Tcl_PrintDouble - scaling} { expr 1.1e1 } {11.0} test util-11.8 {Tcl_PrintDouble - scaling} { expr 1.1e2 } {110.0} test util-11.9 {Tcl_PrintDouble - scaling} { expr 1.1e3 } {1100.0} test util-11.10 {Tcl_PrintDouble - scaling} { expr 1.1e4 } {11000.0} test util-11.11 {Tcl_PrintDouble - scaling} { expr 1.1e5 } {110000.0} test util-11.12 {Tcl_PrintDouble - scaling} { expr 1.1e6 } {1100000.0} test util-11.13 {Tcl_PrintDouble - scaling} { expr 1.1e7 } {11000000.0} test util-11.14 {Tcl_PrintDouble - scaling} { expr 1.1e8 } {110000000.0} test util-11.15 {Tcl_PrintDouble - scaling} { expr 1.1e9 } {1100000000.0} test util-11.16 {Tcl_PrintDouble - scaling} { expr 1.1e10 } {11000000000.0} test util-11.17 {Tcl_PrintDouble - scaling} { expr 1.1e11 } {110000000000.0} test util-11.18 {Tcl_PrintDouble - scaling} { expr 1.1e12 } {1100000000000.0} test util-11.19 {Tcl_PrintDouble - scaling} { expr 1.1e13 } {11000000000000.0} test util-11.20 {Tcl_PrintDouble - scaling} { expr 1.1e14 } {110000000000000.0} test util-11.21 {Tcl_PrintDouble - scaling} { expr 1.1e15 } {1100000000000000.0} test util-11.22 {Tcl_PrintDouble - scaling} { expr 1.1e16 } {11000000000000000.0} test util-11.23 {Tcl_PrintDouble - scaling} { expr 1.1e17 } {1.1e+17} # cleanup ::tcltest::cleanupTests return |
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.26.2.1 2005/01/20 14:53:40 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 #tcltest::configure -verbose {pass start} namespace import -force ::tcltest::* } |
︙ | ︙ | |||
215 216 217 218 219 220 221 | dde eval "" "foo" } -returnCodes error -result {invalid service name ""} # ------------------------------------------------------------------------- test winDde-6.1 {DDE servername bad arguments} -constraints {win dde} -body { dde servername -z -z -z | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | dde eval "" "foo" } -returnCodes error -result {invalid service name ""} # ------------------------------------------------------------------------- test winDde-6.1 {DDE servername bad arguments} -constraints {win dde} -body { dde servername -z -z -z } -returnCodes error -result {bad option "-z": must be -force, -handler, or --} test winDde-6.2 {DDE servername set name} -constraints {win dde} -body { dde servername -- winDde-6.2 } -result {winDde-6.2} test winDde-6.3 {DDE servername set exact name} -constraints {win dde} -body { dde servername -force winDde-6.3 } -result {winDde-6.3} test winDde-6.4 {DDE servername set exact name} -constraints {win dde} -body { |
︙ | ︙ |
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.35.2.2 2005/04/10 23:15:16 kennykb Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } |
︙ | ︙ | |||
1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 | } } -cleanup { cd $pwd } -result "permission denied" cd $pwd unset d dd pwd # This block of code used to occur after the "return" call, so I'm # commenting it out and assuming that this code is still under construction. #foreach source {tef ted tnf tnd "" nul com1} { # foreach chmodsrc {000 755} { # foreach dest "tfn tfe tdn tdempty tdfull td1/td2 $p $p/td1 {} nul" { # foreach chmoddst {000 755} { | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } } -cleanup { cd $pwd } -result "permission denied" cd $pwd unset d dd pwd test winFCmd-18.1 {Windows reserved path names} -constraints win -body { file pathtype com1 } -result "absolute" test winFCmd-18.1.2 {Windows reserved path names} -constraints win -body { file pathtype com4 } -result "absolute" test winFCmd-18.1.3 {Windows reserved path names} -constraints win -body { file pathtype com5 } -result "relative" test winFCmd-18.1.4 {Windows reserved path names} -constraints win -body { file pathtype lpt3 } -result "absolute" test winFCmd-18.1.5 {Windows reserved path names} -constraints win -body { file pathtype lpt4 } -result "relative" test winFCmd-18.1.6 {Windows reserved path names} -constraints win -body { file pathtype nul } -result "absolute" test winFCmd-18.1.7 {Windows reserved path names} -constraints win -body { file pathtype null } -result "relative" test winFCmd-18.2 {Windows reserved path names} -constraints win -body { file pathtype com1: } -result "absolute" test winFCmd-18.3 {Windows reserved path names} -constraints win -body { file pathtype COM1 } -result "absolute" test winFCmd-18.4 {Windows reserved path names} -constraints win -body { file pathtype CoM1: } -result "absolute" test winFCmd-18.5 {Windows reserved path names} -constraints win -body { file normalize com1: } -result COM1 test winFCmd-18.6 {Windows reserved path names} -constraints win -body { file normalize COM1: } -result COM1 test winFCmd-18.7 {Windows reserved path names} -constraints win -body { file normalize cOm1 } -result COM1 test winFCmd-18.8 {Windows reserved path names} -constraints win -body { file normalize cOm1: } -result COM1 # This block of code used to occur after the "return" call, so I'm # commenting it out and assuming that this code is still under construction. #foreach source {tef ted tnf tnd "" nul com1} { # foreach chmodsrc {000 755} { # foreach dest "tfn tfe tdn tdempty tdfull td1/td2 $p $p/td1 {} nul" { # foreach chmoddst {000 755} { |
︙ | ︙ |
Changes to tests/winFile.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the tclWinFile.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # 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.16.2.1 2005/10/08 13:44:39 dgp Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." return } namespace import -force ::tcltest::* |
︙ | ︙ | |||
108 109 110 111 112 113 114 | set tail [file tail $tryname] set dirtext [exec cmd /c dir /q [file nativename $fname]] set owner "" foreach line [split $dirtext "\n"] { if {[string match -nocase "* $tail" $line]} { set attrs [string range $line \ 0 end-[string length $tail]] | | | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | set tail [file tail $tryname] set dirtext [exec cmd /c dir /q [file nativename $fname]] set owner "" foreach line [split $dirtext "\n"] { if {[string match -nocase "* $tail" $line]} { set attrs [string range $line \ 0 end-[string length $tail]] regexp { [^ \\]+\\.*$} $attrs owner set owner [string trim $owner] } } if {"" == "$owner"} { error "getuser: Owner not found in output of dir/q" } return $owner |
︙ | ︙ |
Added tools/fix_tommath_h.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | # fixtommath.tcl -- # # Changes to 'tommath.h' to make it conform with Tcl's linking # conventions. # # Copyright (c) 2005 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: fix_tommath_h.tcl,v 1.1.2.1 2005/01/20 19:13:56 kennykb Exp $ # #---------------------------------------------------------------------- set f [open [lindex $argv 0] r] set data [read $f] close $f foreach line [split $data \n] { switch -regexp -- $line { {#define BN_H_} { puts $line puts {} puts "\#ifdef TCL_TOMMATH" puts "\#include <tclTomMath.h>" puts "\#endif" puts "\#ifndef TOMMATH_STORAGE_CLASS" puts "\#define TOMMATH_STORAGE_CLASS extern" puts "\#endif" } {typedef.*mp_digit;} { puts "\#ifndef MP_DIGIT_DECLARED" puts $line puts "\#define MP_DIGIT_DECLARED" puts "\#endif" } {typedef struct} { puts "\#ifndef MP_INT_DECLARED" puts "\#define MP_INT_DECLARED" puts "typedef struct mp_int mp_int;" puts "\#endif" puts "struct mp_int \{" } \}\ mp_int\; { puts "\};" } "^(char|int|void)" { puts "TOMMATH_STORAGE_CLASS $line" } default { puts $line } } } |
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.17.2.1 2005/09/15 20:58:40 dgp Exp $ package require Tcl 8 namespace eval genStubs { # libraryName -- # # The name of the entire library. This value is used to compute |
︙ | ︙ | |||
367 368 369 370 371 372 373 | set arg1 [lindex $args 0] switch -exact $arg1 { void { append line "(void)" } TCL_VARARGS { set arg [lindex $args 1] | | | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 | set arg1 [lindex $args 0] switch -exact $arg1 { void { append line "(void)" } TCL_VARARGS { set arg [lindex $args 1] append line "([lindex $arg 0][lindex $arg 1], ...)" } default { set sep "(" foreach arg $args { append line $sep set next {} append next [lindex $arg 0] " " [lindex $arg 1] \ |
︙ | ︙ | |||
460 461 462 463 464 465 466 | append text "/* Slot $index */\n" $rtype "\n" $fname set arg1 [lindex $args 0] if {![string compare $arg1 "TCL_VARARGS"]} { lassign [lindex $args 1] type argName | | | | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 | append text "/* Slot $index */\n" $rtype "\n" $fname set arg1 [lindex $args 0] if {![string compare $arg1 "TCL_VARARGS"]} { lassign [lindex $args 1] type argName append text " ($type$argName, ...)\n\{\n" append text " " $type " var;\n va_list argList;\n" if {[string compare $rtype "void"]} { append text " " $rtype " resultValue;\n" } append text "\n var = (" $type ") (va_start(argList, " \ $argName "), " $argName ");\n\n " if {[string compare $rtype "void"]} { append text "resultValue = " } append text "(" $name "StubsPtr->" $lfname "VA)(var, argList);\n" append text " va_end(argList);\n" if {[string compare $rtype "void"]} { append text "return resultValue;\n" |
︙ | ︙ | |||
529 530 531 532 533 534 535 | set arg1 [lindex $args 0] switch -exact $arg1 { void { append text "(void)" } TCL_VARARGS { set arg [lindex $args 1] | | | 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 | set arg1 [lindex $args 0] switch -exact $arg1 { void { append text "(void)" } TCL_VARARGS { set arg [lindex $args 1] append text "([lindex $arg 0][lindex $arg 1], ...)" } default { set sep "(" foreach arg $args { append text $sep [lindex $arg 0] " " [lindex $arg 1] \ [lindex $arg 2] set sep ", " |
︙ | ︙ |
Changes to tools/loadICU.tcl.
︙ | ︙ | |||
22 23 24 25 26 27 28 | # #---------------------------------------------------------------------- # # Copyright (c) 2004 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. # | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | # #---------------------------------------------------------------------- # # Copyright (c) 2004 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: loadICU.tcl,v 1.1.4.1 2005/10/08 13:45:04 dgp Exp $ # #---------------------------------------------------------------------- # Calculate the Chinese numerals from zero to ninety-nine. set zhDigits [list {} \u4e00 \u4e8c \u4e09 \u56db \ \u4e94 \u516d \u4e03 \u516b \u4e5d] |
︙ | ︙ | |||
613 614 615 616 617 618 619 | foreach { icudir msgdir } $argv break # Walk the ICU files and create corresponding Tcl message catalogs foreach fileName [glob -directory $icudir *.txt] { set n [file rootname [file tail $fileName]] if { [regexp {^[a-z]{2,3}(_[A-Z]{2,3}(_.*)?)?$} $n] } { | | | 613 614 615 616 617 618 619 620 621 622 | foreach { icudir msgdir } $argv break # Walk the ICU files and create corresponding Tcl message catalogs foreach fileName [glob -directory $icudir *.txt] { set n [file rootname [file tail $fileName]] if { [regexp {^[a-z]{2,3}(_[A-Z]{2,3}(_.*)?)?$} $n] } { handleLocaleFile $n $fileName [file join $msgdir [string tolower $n].msg] } } |
Changes to tools/makeTestCases.tcl.
1 2 3 | # TODO - When integrating this with the Core, path names will need to be # swizzled here. | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | # TODO - When integrating this with the Core, path names will need to be # swizzled here. package require msgcat set d [file dirname [file dirname [info script]]] puts "getting transition data from [file join $d library tzdata America Detroit]" source [file join $d library/tzdata/America/Detroit] namespace eval ::tcl::clock { ::msgcat::mcmset en_US_roman { LOCALE_ERAS { {-62164627200 {} 0} {-59008867200 c 100} |
︙ | ︙ | |||
543 544 545 546 547 548 549 | puts $f2 {} puts $f2 "\# Test formatting of Daylight Saving Time" puts $f2 {} set fmt {%H:%M:%S %z %Z} set i 0 | < < < | 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 | puts $f2 {} puts $f2 "\# Test formatting of Daylight Saving Time" puts $f2 {} set fmt {%H:%M:%S %z %Z} set i 0 puts $f2 "test clock-5.[incr i] {does Detroit exist} {" puts $f2 " clock format 0 -format {} -timezone :America/Detroit" puts $f2 " concat" puts $f2 "} {}" puts $f2 "test clock-5.[incr i] {does Detroit have a Y2038 problem} detroit {" puts $f2 " if { \[clock format 2158894800 -format %z -timezone :America/Detroit\] ne {-0400} } {" puts $f2 " concat {y2038 problem}" puts $f2 " } else {" puts $f2 " concat {ok}" puts $f2 " }" puts $f2 "} ok" foreach row $TZData(:America/Detroit) { foreach { t offset isdst tzname } $row break if { $t > -4000000000000 } { |
︙ | ︙ |
Changes to tools/man2html2.tcl.
1 2 3 4 5 6 7 | # man2html2.tcl -- # # This file defines procedures that are used during the second pass of the # man page to html conversion process. It is sourced by man2html.tcl. # # Copyright (c) 1996 by Sun Microsystems, Inc. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # man2html2.tcl -- # # This file defines procedures that are used during the second pass of the # man page to html conversion process. It is sourced by man2html.tcl. # # Copyright (c) 1996 by Sun Microsystems, Inc. # # $Id: man2html2.tcl,v 1.7.2.1 2005/04/10 23:15:16 kennykb Exp $ # package require Tcl 8.4 # Global variables used by these scripts: # # NAME_file - array indexed by NAME and containing file names used |
︙ | ︙ | |||
715 716 717 718 719 720 721 | return } # Special case for alternative mechanism for declaring bullets if {[lindex $argList 0] eq "\\(bu"} { nest para UL LI return } | | < | | | | < < | 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 | return } # Special case for alternative mechanism for declaring bullets if {[lindex $argList 0] eq "\\(bu"} { nest para UL LI return } if {[regexp {^\[\d+\]$} [lindex $argList 0]]} { nest para OL LI return } nest para DL DT formattedText [lindex $argList 0] puts $file "\n<DD>" return } # TPmacro -- # # This procedure is invoked to handle ".TP" macros, which may take any # of the following forms: |
︙ | ︙ |
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.5a4 Disk Filename=setup Patch Flags=0000000000000001 Patch Threshold=85 Patch Memory=4000 Variable Name1=_SYS_ Variable Default1=C:\WINDOWS\SYSTEM Variable Flags1=00001000 |
︙ | ︙ |
Changes to tools/tclZIC.tcl.
︙ | ︙ | |||
21 22 23 24 25 26 27 | # # This program parses the timezone data in a means analogous to the # 'zic' command, and produces Tcl time zone information files suitable # for loading into the 'clock' namespace. # #---------------------------------------------------------------------- # | | | > > | | | | < < < < < < < < < < < < < < < < < < < < < < < < < | | 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 | # # This program parses the timezone data in a means analogous to the # 'zic' command, and produces Tcl time zone information files suitable # for loading into the 'clock' namespace. # #---------------------------------------------------------------------- # # Copyright (c) 2004 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: tclZIC.tcl,v 1.3.2.1 2005/04/25 21:37:30 kennykb Exp $ # #---------------------------------------------------------------------- package require Tcl 8.5 # Define the names of the Olson files that we need to load. # We avoid the solar time files and the leap seconds. set olsonFiles { africa antarctica asia australasia backward etcetera europe northamerica pacificnew southamerica systemv } # Temporary scaffolding - load up the new 'clock' package. source [file join [file dirname [info script]] .. library clock.tcl] # Define the year at which the DST information will stop. set maxyear 2100 # Determine how big a wide integer is. set MAXWIDE [expr {wide(1)}] while 1 { set next [expr {$MAXWIDE + $MAXWIDE + 1}] if {$next < 0} { break } set MAXWIDE $next } set MINWIDE [expr {-$MAXWIDE-1}] #---------------------------------------------------------------------- # # loadFiles -- # # Loads the time zone files for each continent into memory # # Parameters: # dir - Directory where the time zone source files are found # # Results: # None. # # Side effects: # Calls 'loadZIC' for each continent's data file in turn. # Reports progress on stdout. # #---------------------------------------------------------------------- proc loadFiles {dir} { variable olsonFiles foreach file $olsonFiles { puts "loading: [file join $dir $file]" loadZIC [file join $dir $file] } return } |
︙ | ︙ | |||
132 133 134 135 136 137 138 | # any undefined rules are present. # #---------------------------------------------------------------------- proc checkForwardRuleRefs {} { variable forwardRuleRefs variable rules | > | | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | # any undefined rules are present. # #---------------------------------------------------------------------- proc checkForwardRuleRefs {} { variable forwardRuleRefs variable rules foreach {rule where} [array get forwardRuleRefs] { if {![info exists rules($rule)]} { foreach {fileName lno} $where { puts stderr "$fileName:$lno:can't locate rule \"$rule\"" incr errorCount } } } } |
︙ | ︙ | |||
163 164 165 166 167 168 169 | # The global array, 'links', contains a distillation of the # 'Link' directives in the file. The keys are 'links to' and # the values are 'links from'. The 'parseRule' and 'parseZone' # procedures are called to handle 'Rule' and 'Zone' directives. # #---------------------------------------------------------------------- | | < | | | > | < < < | < | | | > > < | 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 | # The global array, 'links', contains a distillation of the # 'Link' directives in the file. The keys are 'links to' and # the values are 'links from'. The 'parseRule' and 'parseZone' # procedures are called to handle 'Rule' and 'Zone' directives. # #---------------------------------------------------------------------- proc loadZIC {fileName} { variable errorCount variable links # Suck the text into memory. set f [open $fileName r] set data [read $f] close $f # Break the input into lines, and count line numbers. set lno 0 foreach line [split $data \n] { incr lno # Break a line of input into words. regsub {\s*(\#.*)?$} $line {} line if {$line eq ""} { continue } set words {} if {[regexp {^\s} $line]} { # Detect continuations of a zone and flag the list appropriately lappend words "" } lappend words {expand}[regexp -all -inline {\S+} $line] # Switch on the directive switch -exact -- [lindex $words 0] { Rule { parseRule $fileName $lno $words } Link { set links([lindex $words 2]) [lindex $words 1] } Zone { set lastZone [lindex $words 1] set until [parseZone $fileName $lno \ $lastZone [lrange $words 2 end] "minimum"] } {} { set i 0 foreach word $words { if {[lindex $words $i] ne ""} { break } incr i } set words [lrange $words $i end] set until [parseZone $fileName $lno $lastZone $words $until] } default { incr errorCount puts stderr "$fileName:$lno:unknown line type \"[lindex $words 0]\"" } } } return } #---------------------------------------------------------------------- # # parseRule -- # # Parses a Rule directive in an Olson file. |
︙ | ︙ | |||
250 251 252 253 254 255 256 | # # Side effects: # The rule is analyzed and added to the 'rules' array. # Errors are reported and counted. # #---------------------------------------------------------------------- | | < | | < | | | < | | | | | | | | | | | | | | | | | | | | | | | | < | | 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 | # # Side effects: # The rule is analyzed and added to the 'rules' array. # Errors are reported and counted. # #---------------------------------------------------------------------- proc parseRule {fileName lno words} { variable rules variable errorCount # Break out the columns lassign $words Rule name from to type in on at save letter # Handle the 'only' keyword if {$to eq "only"} { set to $from } # Process the start year if {![string is integer $from]} { if {![string equal -length [string length $from] $from "minimum"]} { puts stderr "$fileName:$lno:FROM field \"$from\" not an integer." incr errorCount return } else { set from "minimum" } } # Process the end year if {![string is integer $to]} { if {![string equal -length [string length $to] $to "maximum"]} { puts stderr "$fileName:$lno:TO field \"$to\" not an integer." incr errorCount return } else { set to "maximum" } } # Process the type of year in which the rule applies if {$type ne "-"} { puts stderr "$fileName:$lno:year types are not yet supported." incr errorCount return } # Process the month in which the rule starts if {[catch {lookupMonth $in} in]} { puts stderr "$fileName:$lno:$in" incr errorCount return } # Process the day of the month on which the rule starts if {[catch {parseON $on} on]} { puts stderr "$fileName:$lno:$on" incr errorCount return } # Process the time of day on which the rule starts if {[catch {parseTOD $at} at]} { puts stderr "$fileName:$lno:$at" incr errorCount return } # Process the DST adder if {[catch {parseOffsetTime $save} save]} { puts stderr "$fileName:$lno:$save" incr errorCount return } # Process the letter to use for summer time if {$letter eq "-"} { set letter "" } # Accumulate all the data. lappend rules($name) $from $to $type $in $on $at $save $letter return } #---------------------------------------------------------------------- # # parseON -- # # Parse a specification for a day of the month # # Parameters: # on - the ON field from a line in an Olson file. # # Results: # Returns a partial Tcl command. When the year and number of the # month are appended, the command will return the Julian Day Number # of the desired date. # # Side effects: # None. # # The specification can be: # - a simple number, which designates a constant date. # - The name of a weekday, followed by >= or <=, followed by a number. # This designates the nearest occurrence of the given weekday on # or before (on or after) the given day of the month. # - The word 'last' followed by a weekday name with no intervening # space. This designates the last occurrence of the given weekday # in the month. # #---------------------------------------------------------------------- proc parseON {on} { if {![regexp -expanded { ^(?: # first possibility - simple number - field 1 ([[:digit:]]+) | # second possibility - weekday >= (or <=) number # field 2 - weekday ([[:alpha:]]+) # field 3 - direction ([<>]=) # field 4 - number ([[:digit:]]+) | # third possibility - lastWeekday - field 5 last([[:alpha:]]+) )$ } $on -> dom1 wday2 dir2 num2 wday3]} then { error "can't parse ON field \"$on\"" } if {$dom1 ne ""} { return [list onDayOfMonth $dom1] } elseif {$wday2 ne ""} { set wday2 [lookupDayOfWeek $wday2] return [list onWeekdayInMonth $wday2 $dir2 $num2] } elseif {$wday3 ne ""} { set wday3 [lookupDayOfWeek $wday3] return [list onLastWeekdayInMonth $wday3] } else { error "in parseOn \"$on\": can't happen" } } #---------------------------------------------------------------------- # # onDayOfMonth -- # # Find a given day of a given month # # Parameters: # day - Day of the month # year - Gregorian year # month - Number of the month (1-12) # # Results: # Returns the Julian Day Number of the desired day. # # Side effects: # None. # #---------------------------------------------------------------------- proc onDayOfMonth {day year month} { set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ [dict create era CE year $year month $month dayOfMonth $day]] return [dict get $date julianDay] } #---------------------------------------------------------------------- # # onWeekdayInMonth -- # |
︙ | ︙ | |||
458 459 460 461 462 463 464 | # # onWeekdayInMonth is used to compute Daylight Saving Time rules # like 'Sun>=1' (for the nearest Sunday on or after the first of the month) # or "Mon<=4' (for the Monday on or before the fourth of the month). # #---------------------------------------------------------------------- | | | | < < | | | 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 | # # onWeekdayInMonth is used to compute Daylight Saving Time rules # like 'Sun>=1' (for the nearest Sunday on or after the first of the month) # or "Mon<=4' (for the Monday on or before the fourth of the month). # #---------------------------------------------------------------------- proc onWeekdayInMonth {dayOfWeek relation dayOfMonth year month} { set date [::tcl::clock::GetJulianDayFromEraYearMonthDay [dict create \ era CE year $year month $month dayOfMonth $dayOfMonth]] switch -exact -- $relation { <= { return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \ [dict get $date julianDay]] } >= { return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \ [expr {[dict get $date julianDay] + 6}]] } } } #---------------------------------------------------------------------- # # onLastWeekdayInMonth -- |
︙ | ︙ | |||
495 496 497 498 499 500 501 | # the given weekday in the given month # # Side effects: # None. # #---------------------------------------------------------------------- | | | | < < | | | 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 | # the given weekday in the given month # # Side effects: # None. # #---------------------------------------------------------------------- proc onLastWeekdayInMonth {dayOfWeek year month} { incr month # Find day 0 of the following month, which is the last day of # the current month. Yes, it works to ask for day 0 of month 13! set date [::tcl::clock::GetJulianDayFromEraYearMonthDay [dict create \ era CE year $year month $month dayOfMonth 0]] return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \ [dict get $date julianDay]] } #---------------------------------------------------------------------- # # parseTOD -- # # Parses the specification of a time of day in an Olson file. # # Parameters: |
︙ | ︙ | |||
528 529 530 531 532 533 534 | # midnight and the letter that followed the time. # # Side effects: # Reports and counts an error if the time cannot be parsed. # #---------------------------------------------------------------------- | | | < | < | | < | | | < | | | | | | | | | < < | < | | < | | | | | | | < | | 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 | # midnight and the letter that followed the time. # # Side effects: # Reports and counts an error if the time cannot be parsed. # #---------------------------------------------------------------------- proc parseTOD {tod} { if {![regexp -expanded { ^ ([[:digit:]]{1,2}) # field 1 - hour (?: :([[:digit:]]{2}) # field 2 - minute (?: :([[:digit:]]{2}) # field 3 - second )? )? (?: ([wsugz]) # field 4 - type indicator )? } $tod -> hour minute second ind]} then { puts stderr "$fileName:$lno:can't parse time field \"$tod\"" incr errorCount } scan $hour %d hour if {$minute ne ""} { scan $minute %d minute } else { set minute 0 } if {$second ne ""} { scan $second %d second } else { set second 0 } if {$ind eq ""} { set ind w } return [list [expr {($hour * 60 + $minute) * 60 + $second}] $ind] } #---------------------------------------------------------------------- # # parseOffsetTime -- # # Parses the specification of an offset time in an Olson file. # # Parameters: # offset - Offset time as [+-]hh:mm:ss # # Results: # Returns the offset time as a count of seconds. # # Side effects: # Reports and counts an error if the time cannot be parsed. # #---------------------------------------------------------------------- proc parseOffsetTime {offset} { if {![regexp -expanded { ^ ([-+])? # field 1 - signum ([[:digit:]]{1,2}) # field 2 - hour (?: :([[:digit:]]{2}) # field 3 - minute (?: :([[:digit:]]{2}) # field 4 - second )? )? } $offset -> signum hour minute second]} then { puts stderr "$fileName:$lno:can't parse offset time \"$offset\"" incr errorCount } append signum 1 scan $hour %d hour if {$minute ne ""} { scan $minute %d minute } else { set minute 0 } if {$second ne ""} { scan $second %d second } else { set second 0 } return [expr {(($hour * 60 + $minute) * 60 + $second) * $signum}] } #---------------------------------------------------------------------- # # lookupMonth - # Looks up a month by name # # Parameters: # month - Name of a month. # # Results: # Returns the number of the month. # # Side effects: # None. # #---------------------------------------------------------------------- proc lookupMonth {month} { set indx [lsearch -regexp { {} January February March April May June July August September October November December } ${month}.*] if {$indx < 1} { error "unknown month name \"$month\"" } return $indx } #---------------------------------------------------------------------- # |
︙ | ︙ | |||
663 664 665 666 667 668 669 | # Returns the weekday number (Monday=1, Sunday=7) # # Side effects: # None. # #---------------------------------------------------------------------- | | | | | | | > | | | | | < | | | | | | < | | | > | | | | | | | | 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 | # Returns the weekday number (Monday=1, Sunday=7) # # Side effects: # None. # #---------------------------------------------------------------------- proc lookupDayOfWeek {wday} { set indx [lsearch -regexp { {} Monday Tuesday Wednesday Thursday Friday Saturday Sunday } ${wday}.*] if {$indx < 1} { error "unknown weekday name \"$wday\"" } return $indx } #---------------------------------------------------------------------- # # parseZone -- # # Parses a Zone directive in an Olson file # # Parameters: # fileName -- Name of the file being parsed. # lno -- Line number within the file. # zone -- Name of the time zone # words -- Remaining words on the line. # start -- 'Until' time from the previous line if this is a # continuation line, or 'minimum' if this is the first line. # # Results: # Returns the 'until' field of the current line # # Side effects: # Stores a row in the 'zones' array describing the current zone. # The row consists of a start time (year month day tod), a Standard # Time offset from Greenwich, a Daylight Saving Time offset from # Standard Time, and a format for printing the time zone. # # The start time is the result of an earlier call to 'parseUntil' # or else the keyword 'minimum'. The GMT offset is the # result of a call to 'parseOffsetTime'. The Daylight Saving # Time offset is represented as a partial Tcl command. To the # command will be appended a start time (seconds from epoch) # the current offset of Standard Time from Greenwich, the current # offset of Daylight Saving Time from Greenwich, the default # offset from this line, the name pattern from this line, # the 'until' field from this line, and a variable name where points # are to be stored. This command is implemented by the 'applyNoRule', # 'applyDSTOffset' and 'applyRules' procedures. # #---------------------------------------------------------------------- proc parseZone {fileName lno zone words start} { variable zones variable rules variable errorCount variable forwardRuleRefs lassign $words gmtoff save format if {[catch {parseOffsetTime $gmtoff} gmtoff]} { puts stderr "$fileName:$lno:$gmtoff" incr errorCount return } if {[info exists rules($save)]} { set save [list applyRules $save] } elseif {$save eq "-"} { set save [list applyNoRule] } elseif {[catch {parseOffsetTime $save} save2]} { lappend forwardRuleRefs($save) $fileName $lno set save [list applyRules $save] } else { set save [list applyDSTOffset $save2] } lappend zones($zone) $start $gmtoff $save $format if {[llength $words] >= 4} { return [parseUntil [lrange $words 3 end]] } else { return {} } } #---------------------------------------------------------------------- # # parseUntil -- # # Parses the 'UNTIL' part of a 'Zone' directive. # # Parameters: # words - The 'UNTIL' part of the directie. # # Results: # Returns a list comprising the year, the month, the day, and # the time of day. Time of day is represented as the result of # 'parseTOD'. # #---------------------------------------------------------------------- proc parseUntil {words} { variable firstYear if {[llength $words] >= 1} { set year [lindex $words 0] if {![string is integer $year]} { error "can't parse UNTIL field \"$words\"" } if {![info exists firstYear] || $year < $firstYear} { set firstYear $year } } else { set year "maximum" } if {[llength $words] >= 2} { set month [lookupMonth [lindex $words 1]] } else { set month 1 } if {[llength $words] >= 3} { set day [parseON [lindex $words 2]] } else { set day {onDayOfMonth 1} } if {[llength $words] >= 4} { set tod [parseTOD [lindex $words 3]] } else { set tod {0 w} } return [list $year $month $day $tod] } |
︙ | ︙ | |||
820 821 822 823 824 825 826 | # Side effects: # Appends a row to the 'points' variable comprising the start time, # the offset from GMT, a zero (indicating that DST is not in effect), # and the name of the time zone. # #---------------------------------------------------------------------- | | | | < | | | 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 | # Side effects: # Appends a row to the 'points' variable comprising the start time, # the offset from GMT, a zero (indicating that DST is not in effect), # and the name of the time zone. # #---------------------------------------------------------------------- proc applyNoRule {year startSecs stdGMTOffset DSTOffset nextGMTOffset namePattern until pointsVar} { upvar 1 $pointsVar points lappend points $startSecs $nextGMTOffset 0 \ [convertNamePattern $namePattern -] return [list $nextGMTOffset 0] } #---------------------------------------------------------------------- # # applyDSTOffset -- # # Generates time zone data for a zone with permanent Daylight # Saving Time. # # Parameters: # nextDSTOffset - Offset of Daylight from Standard while the # rule is in effect. # year - Year in which the rule applies # startSecs - Time at which the rule starts. # stdGMTOffset - Offset from Greenwich prior to the start of the # rule # DSTOffset - Offset of Daylight from Standard prior to the # start of the rule. # nextGMTOffset - Offset from Greenwich when the rule is in effect. |
︙ | ︙ | |||
862 863 864 865 866 867 868 | # Side effects: # Appends a row to the 'points' variable comprising the start time, # the offset from GMT, a one (indicating that DST is in effect), # and the name of the time zone. # #---------------------------------------------------------------------- | | | | | | | | | 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 | # Side effects: # Appends a row to the 'points' variable comprising the start time, # the offset from GMT, a one (indicating that DST is in effect), # and the name of the time zone. # #---------------------------------------------------------------------- proc applyDSTOffset {nextDSTOffset year startSecs stdGMTOffset DSTOffset nextGMTOffset namePattern until pointsVar} { upvar 1 $pointsVar points lappend points \ $startSecs \ [expr {$nextGMTOffset + $nextDSTOffset}] \ 1 \ [convertNamePattern $namePattern S] return [list $nextGMTOffset $nextDSTOffset] } #---------------------------------------------------------------------- # # applyRules -- # |
︙ | ︙ | |||
907 908 909 910 911 912 913 | # Appends one or more rows to the 'points' variable, each of which # comprises a transition time, the offset from GMT that is # in effect after the transition, a flag for whether DST is in # effect, and the name of the time zone. # #---------------------------------------------------------------------- | | | < < | | | | | | | | | | | < | < | < < | > < | < | < | < < < | | | | | < > | | | | | | | | | | | | < | | | | < | | | | | | | < < | < | 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 | # Appends one or more rows to the 'points' variable, each of which # comprises a transition time, the offset from GMT that is # in effect after the transition, a flag for whether DST is in # effect, and the name of the time zone. # #---------------------------------------------------------------------- proc applyRules {ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset namePattern until pointsVar} { variable done variable rules variable maxyear upvar 1 $pointsVar points # Extract the rules that apply to the current year, and the number # of rules (now or in future) that will end at a specific year. # Ignore rules entirely in the past. lassign [divideRules $ruleSet $year] currentRules nSunsetRules # If the first transition is later than $startSecs, and $stdGMTOffset is # different from $nextGMTOffset, we will need an initial record like: # lappend points $startSecs $stdGMTOffset 0 \ # [convertNamePattern $namePattern -] set didTransitionIn false # Determine the letter to use in Standard Time set prevLetter "" foreach { fromYear toYear yearType monthIn daySpecOn timeAt save letter } $rules($ruleSet) { if {$save == 0} { set prevLetter $letter break } } # Walk through each year in turn. This loop will break when # (a) the 'until' time is passed # or (b) the 'until' time is empty and all remaining rules extend to # the end of time set stdGMTOffset $nextGMTOffset # convert "until" to seconds from epoch in current time zone if {$until ne ""} { lassign $until untilYear untilMonth untilDaySpec untilTimeOfDay lappend untilDaySpec $untilYear $untilMonth set untilJCD [eval $untilDaySpec] set untilBaseSecs [expr { wide(86400) * wide($untilJCD) - 210866803200 }] set untilSecs [convertTimeOfDay $untilBaseSecs $stdGMTOffset \ $DSTOffset {expand}$untilTimeOfDay] } set origStartSecs $startSecs while {($until ne "" && $startSecs < $untilSecs) || ($until eq "" && ($nSunsetRules > 0 || $year < $maxyear))} { set remainingRules $currentRules while {[llength $remainingRules] > 0} { # Find the rule with the earliest start time from among the # active rules that haven't yet been processed. lassign [findEarliestRule $remainingRules $year \ $stdGMTOffset $DSTOffset] earliestSecs earliestIndex set endi [expr {$earliestIndex + 7}] set rule [lrange $remainingRules $earliestIndex $endi] lassign $rule fromYear toYear \ yearType monthIn daySpecOn timeAt save letter # Test if the rule is in effect. if { $earliestSecs > $startSecs && ($until eq "" || $earliestSecs < $untilSecs) } then { # Test if the initial transition has been done. # If not, do it now. if {!$didTransitionIn && $earliestSecs > $origStartSecs} { set nm [convertNamePattern $namePattern $prevLetter] lappend points \ $origStartSecs \ [expr {$stdGMTOffset + $DSTOffset}] \ 0 \ $nm set didTransitionIn true } # Add a row to 'points' for the rule set nm [convertNamePattern $namePattern $letter] lappend points \ $earliestSecs \ [expr {$stdGMTOffset + $save}] \ [expr {$save != 0}] \ $nm } # Remove the rule just applied from the queue set remainingRules [lreplace \ $remainingRules[set remainingRules {}] \ $earliestIndex $endi] # Update current DST offset and time zone letter set DSTOffset $save set prevLetter $letter # Reconvert the 'until' time in the current zone. if {$until ne ""} { set untilSecs [convertTimeOfDay $untilBaseSecs \ $stdGMTOffset $DSTOffset {expand}$untilTimeOfDay] } } # Advance to the next year incr year set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ [dict create era CE year $year month 1 dayOfMonth 1]] set startSecs [expr { [dict get $date julianDay] * wide(86400) - 210866803200 - $stdGMTOffset - $DSTOffset }] # Get rules in effect in the new year. lassign [divideRules $ruleSet $year] currentRules nSunsetRules } return [list $stdGMTOffset $DSTOffset] } #---------------------------------------------------------------------- # |
︙ | ︙ | |||
1081 1082 1083 1084 1085 1086 1087 | # not change in future years. # # Side effects: # None. # #---------------------------------------------------------------------- | | < | | | | | | | | < | < < | | | < | 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 | # not change in future years. # # Side effects: # None. # #---------------------------------------------------------------------- proc divideRules {ruleSet year} { variable rules set currentRules {} set nSunsetRules 0 foreach { fromYear toYear yearType monthIn daySpecOn timeAt save letter } $rules($ruleSet) { if {$toYear ne "maximum" && $year > $toYear} { # ignore - rule is in the past } else { if {$fromYear eq "minimum" || $fromYear <= $year} { lappend currentRules $fromYear $toYear $yearType $monthIn \ $daySpecOn $timeAt $save $letter } if {$toYear ne "maximum"} { incr nSunsetRules } } } return [list $currentRules $nSunsetRules] } #---------------------------------------------------------------------- # # findEarliestRule -- # # Find the rule in a rule set that has the earliest start time. # # Parameters: # remainingRules -- Rules to search # year - Year being processed. # stdGMTOffset - Current offset of standard time from GMT # DSTOffset - Current offset of daylight time from standard, # if daylight time is in effect. # # Results: # Returns the index in remainingRules of the next rule to # go into effect. # # Side effects: # None. # #---------------------------------------------------------------------- proc findEarliestRule {remainingRules year stdGMTOffset DSTOffset} { set earliest $::MAXWIDE set i 0 foreach { fromYear toYear yearType monthIn daySpecOn timeAt save letter } $remainingRules { lappend daySpecOn $year $monthIn set dayIn [eval $daySpecOn] set secs [expr {wide(86400) * wide($dayIn) - 210866803200}] set secs [convertTimeOfDay $secs \ $stdGMTOffset $DSTOffset {expand}$timeAt] if {$secs < $earliest} { set earliest $secs set earliestIdx $i } incr i 8 } return [list $earliest $earliestIdx] } #---------------------------------------------------------------------- # # convertNamePattern -- # # Converts a name pattern to the name of the time zone. |
︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 | # Returns the name of the time zone. # # Side effects: # None. # #---------------------------------------------------------------------- | | | | | 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 | # Returns the name of the time zone. # # Side effects: # None. # #---------------------------------------------------------------------- proc convertNamePattern {pattern flag} { if {[regexp {(.*)/(.*)} $pattern -> standard daylight]} { if {$flag ne ""} { set pattern $daylight } else { set pattern $standard } } return [string map [list %s $flag] $pattern] } |
︙ | ︙ | |||
1200 1201 1202 1203 1204 1205 1206 | # seconds -- Time at which the GMT day starts, in seconds # from the Posix epoch # stdGMTOffset - Offset of Standard Time from Greenwich # DSTOffset - Offset of Daylight Time from standard. # timeOfDay - Time of day to convert, in seconds from midnight # flag - Flag indicating whether the time is Greenwich, Standard # or wall-clock. (g, s, or w) | | | | | | | | < | | | | | < | < | | | | | | 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 | # seconds -- Time at which the GMT day starts, in seconds # from the Posix epoch # stdGMTOffset - Offset of Standard Time from Greenwich # DSTOffset - Offset of Daylight Time from standard. # timeOfDay - Time of day to convert, in seconds from midnight # flag - Flag indicating whether the time is Greenwich, Standard # or wall-clock. (g, s, or w) # # Results: # Returns the time of day in seconds from the Posix epoch. # # Side effects: # None. # #---------------------------------------------------------------------- proc convertTimeOfDay {seconds stdGMTOffset DSTOffset timeOfDay flag} { incr seconds $timeOfDay switch -exact $flag { g - u - z { } w { incr seconds [expr {-$stdGMTOffset}] incr seconds [expr {-$DSTOffset}] } z { incr seconds [expr {-$stdGMTOffset}] } } return $seconds } #---------------------------------------------------------------------- # # processTimeZone -- # # Generate the information about all time transitions in a # time zone. # # Parameters: # zoneName - Name of the time zone # zoneData - List containing the rows describing the time zone, # obtained from 'parseZone. # # Results: # Returns a list of rows. Each row consists of a time in # seconds from the Posix epoch, an offset from GMT to local # that begins at that time, a flag indicating whether DST # is in effect after that time, and the printable name of the # timezone that goes into effect at that time. # # Side effects: # None. # #---------------------------------------------------------------------- proc processTimeZone {zoneName zoneData} { set points {} set i 0 foreach {startTime nextGMTOffset dstRule namePattern} $zoneData { incr i 4 set until [lindex $zoneData $i] if {![info exists stdGMTOffset]} { set stdGMTOffset $nextGMTOffset } if {![info exists DSTOffset]} { set DSTOffset 0 } if {$startTime eq "minimum"} { set secs $::MINWIDE set year 0 } else { lassign $startTime year month dayRule timeOfDay lappend dayRule $year $month set startDay [eval $dayRule] set secs [expr {wide(86400) * wide($startDay) -210866803200}] set secs [convertTimeOfDay $secs \ $stdGMTOffset $DSTOffset {expand}$timeOfDay] } lappend dstRule \ $year $secs $stdGMTOffset $DSTOffset $nextGMTOffset \ $namePattern $until points lassign [eval $dstRule] stdGMTOffset DSTOffset } return $points } #---------------------------------------------------------------------- # # writeZones -- |
︙ | ︙ | |||
1301 1302 1303 1304 1305 1306 1307 | # # Side effects: # Writes the time zone information files; traces what's happening # on the standard output. # #---------------------------------------------------------------------- | | < | | | | | | < | 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 | # # Side effects: # Writes the time zone information files; traces what's happening # on the standard output. # #---------------------------------------------------------------------- proc writeZones {outDir} { variable zones # Walk the zones foreach zoneName [lsort -dictionary [array names zones]] { puts "calculating: $zoneName" set fileName [eval [list file join $outDir] [file split $zoneName]] # Create directories as needed set dirName [file dirname $fileName] if {![file exists $dirName]} { puts "creating directory: $dirName" file mkdir $dirName } # Generate data for a zone set data "" foreach { time offset dst name } [processTimeZone $zoneName $zones($zoneName)] { append data "\n " [list [list $time $offset $dst $name]] } append data \n # Write the data to the information file set f [open $fileName w] puts $f "\# created by $::argv0 - do not edit" puts $f "" puts $f [list set TZData(:$zoneName) $data] close $f } return } #---------------------------------------------------------------------- # |
︙ | ︙ | |||
1358 1359 1360 1361 1362 1363 1364 | # # Results: # None. # # Side effects: # Creates a file for each link. | | < | | 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 | # # Results: # None. # # Side effects: # Creates a file for each link. proc writeLinks {outDir} { variable links # Walk the links foreach zoneName [lsort -dictionary [array names links]] { puts "creating link: $zoneName" set fileName [eval [list file join $outDir] [file split $zoneName]] # Create directories as needed set dirName [file dirname $fileName] if {![file exists $dirName]} { puts "creating directory: $dirName" file mkdir $dirName } # Create code for the synonym set linkTo $links($zoneName) |
︙ | ︙ | |||
1403 1404 1405 1406 1407 1408 1409 | # # MAIN PROGRAM # #---------------------------------------------------------------------- # Determine directories | | | | | | 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 | # # MAIN PROGRAM # #---------------------------------------------------------------------- # Determine directories lassign $argv inDir outDir # Initialize count of errors set errorCount 0 # Parse the Olson files loadFiles $inDir if {$errorCount > 0} { exit 1 } # Check that all riles appearing in Zone and Link lines actually exist checkForwardRuleRefs if {$errorCount > 0} { exit 1 } # Write the time zone information files writeZones $outDir writeLinks $outDir if {$errorCount > 0} { exit 1 } # All done! exit |
Changes to tools/tcltk-man2html.tcl.
︙ | ︙ | |||
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 | # Set defaults based on original code. set tcltkdir ../.. set tkdir {} set tcldir {} set webdir ../html set build_tcl 0 set build_tk 0 # Handle arguments a la GNU: # --version # --help # --srcdir=/path # --htmldir=/path foreach option $argv { switch -glob -- $option { --version { puts "tcltk-man-html $Version" exit 0 } --help { puts "usage: tcltk-man-html \[OPTION\] ...\n" puts " --help print this help, then exit" puts " --version print version number, then exit" puts " --srcdir=DIR find tcl and tk source below DIR" puts " --htmldir=DIR put generated HTML in DIR" puts " --tcl build tcl help" puts " --tk build tk help" exit 0 } --srcdir=* { # length of "--srcdir=" is 9. set tcltkdir [string range $option 9 end] } --htmldir=* { # length of "--htmldir=" is 10 set webdir [string range $option 10 end] } --tcl { set build_tcl 1 } --tk { set build_tk 1 } default { puts stderr "tcltk-man-html: unrecognized option -- `$option'" exit 1 } } } if {!$build_tcl && !$build_tk} {set build_tcl 1; set build_tk 1} if {$build_tcl} { | > > > > > > > > > | | | | | | | | | | | | | | | | | 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 | # Set defaults based on original code. set tcltkdir ../.. set tkdir {} set tcldir {} set webdir ../html set build_tcl 0 set build_tk 0 # Default search version is a glob pattern set useversion {{,[8-9].[0-9]{,.[0-9]{,[0-9]}}}} # Handle arguments a la GNU: # --version # --useversion=<version> # --help # --srcdir=/path # --htmldir=/path foreach option $argv { switch -glob -- $option { --version { puts "tcltk-man-html $Version" exit 0 } --help { puts "usage: tcltk-man-html \[OPTION\] ...\n" puts " --help print this help, then exit" puts " --version print version number, then exit" puts " --srcdir=DIR find tcl and tk source below DIR" puts " --htmldir=DIR put generated HTML in DIR" puts " --tcl build tcl help" puts " --tk build tk help" puts " --useversion version of tcl/tk to search for" exit 0 } --srcdir=* { # length of "--srcdir=" is 9. set tcltkdir [string range $option 9 end] } --htmldir=* { # length of "--htmldir=" is 10 set webdir [string range $option 10 end] } --useversion=* { # length of "--useversion=" is 13 set useversion [string range $option 13 end] } --tcl { set build_tcl 1 } --tk { set build_tk 1 } default { puts stderr "tcltk-man-html: unrecognized option -- `$option'" exit 1 } } } if {!$build_tcl && !$build_tk} {set build_tcl 1; set build_tk 1} if {$build_tcl} { # Find Tcl. set tcldir [lindex [lsort [glob -nocomplain -tails -type d \ -directory $tcltkdir tcl$useversion]] end] if {$tcldir == ""} then { puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir" exit 1 } puts "using Tcl source directory $tcldir" } if {$build_tk} { # Find Tk. set tkdir [lindex [lsort [glob -nocomplain -tails -type d \ -directory $tcltkdir tk$useversion]] end] if {$tkdir == ""} then { puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir" exit 1 } puts "using Tk source directory $tkdir" } # the title for the man pages overall global overall_title set overall_title "" if {$build_tcl} {append overall_title "[capitalize $tcldir]"} if {$build_tcl && $build_tk} {append overall_title "/"} |
︙ | ︙ |
Changes to unix/Makefile.in.
1 2 3 4 5 6 7 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # # RCS: @(#) $Id: Makefile.in,v 1.157.2.19 2005/09/23 16:47:35 dgp Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ MINOR_VERSION = @TCL_MINOR_VERSION@ PATCH_LEVEL = @TCL_PATCH_LEVEL@ #---------------------------------------------------------------- |
︙ | ︙ | |||
34 35 36 37 38 39 40 | mandir = @mandir@ # The following definition can be set to non-null for special systems # like AFS with replication. It allows the pathnames used for installation # to be different than those used for actually reference files at # run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix # when installing files. | | | > > > | > > > > > > | < < < | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | mandir = @mandir@ # The following definition can be set to non-null for special systems # like AFS with replication. It allows the pathnames used for installation # to be different than those used for actually reference files at # run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix # when installing files. INSTALL_ROOT = $(DESTDIR) # Path for the platform independent Tcl scripting libraries: TCL_LIBRARY = @TCL_LIBRARY@ # Path to use at runtime to refer to LIB_INSTALL_DIR: LIB_RUNTIME_DIR = $(libdir) # Directory in which to install the program tclsh: BIN_INSTALL_DIR = $(INSTALL_ROOT)$(bindir) # Directory in which to install libtcl.so or libtcl.a: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Path to the private tcl header dir: PRIVATE_INCLUDE_DIR = @PRIVATE_INCLUDE_DIR@ # Directory in which to (optionally) install the private tcl headers: PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(PRIVATE_INCLUDE_DIR) # Top-level directory in which to install manual entries: MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) # Directory in which to install manual entry for tclsh: MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 # Directory in which to install manual entries for Tcl's C library # procedures: MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 # Directory in which to install manual entries for the built-in # Tcl commands: MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann # Path to the html documentation dir: HTML_DIR = @HTML_DIR@ # Directory in which to install html documentation: HTML_INSTALL_DIR = $(INSTALL_ROOT)$(HTML_DIR) # Package search path. TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@ # Tcl Module default path roots (TIP189). TCL_MODULE_PATH = @TCL_MODULE_PATH@ # warning flags CFLAGS_WARNING = @CFLAGS_WARNING@ # The default switches for optimization or debugging CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ |
︙ | ︙ | |||
104 105 106 107 108 109 110 | LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ # To disable ANSI-C procedure prototypes reverse the comment characters # on the following lines: PROTO_FLAGS = #PROTO_FLAGS = -DNO_PROTOTYPE | < < < < < < | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ # To disable ANSI-C procedure prototypes reverse the comment characters # on the following lines: PROTO_FLAGS = #PROTO_FLAGS = -DNO_PROTOTYPE # If you use the setenv, putenv, or unsetenv procedures to modify # environment variables in your application and you'd like those # modifications to appear in the "env" Tcl variable, switch the # comments on the two lines below so that Tcl provides these # procedures instead of your standard C library. ENV_FLAGS = |
︙ | ︙ | |||
162 163 164 165 166 167 168 | # Tcl used to let the configure script choose which program to use # for installing, but there are just too many different versions of # "install" around; better to use the install-sh script that comes # with the distribution, which is slower but guaranteed to work. INSTALL_STRIP_PROGRAM = -s | | | 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 | # Tcl used to let the configure script choose which program to use # for installing, but there are just too many different versions of # "install" around; better to use the install-sh script that comes # with the distribution, which is slower but guaranteed to work. INSTALL_STRIP_PROGRAM = -s INSTALL_STRIP_LIBRARY = -S -S INSTALL = @srcdir@/install-sh -c INSTALL_PROGRAM = ${INSTALL} INSTALL_LIBRARY = ${INSTALL} INSTALL_DATA = ${INSTALL} -m 644 # TCL_EXE is the name of a tclsh executable that is available *BEFORE* |
︙ | ︙ | |||
185 186 187 188 189 190 191 | # 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@ | < | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 | # symbols mean. The values of the symbols are normally set by the # configure script. You shouldn't normally need to modify any of # these definitions by hand. STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ TCL_SHLIB_LD_EXTRAS = @TCL_SHLIB_LD_EXTRAS@ SHLIB_SUFFIX = @SHLIB_SUFFIX@ #SHLIB_SUFFIX = DLTEST_TARGETS = dltest.marker |
︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 249 250 251 | AC_FLAGS = @DEFS@ AR = @AR@ RANLIB = @RANLIB@ SRC_DIR = @srcdir@ TOP_DIR = $(SRC_DIR)/.. BUILD_DIR = @builddir@ GENERIC_DIR = $(TOP_DIR)/generic COMPAT_DIR = $(TOP_DIR)/compat TOOL_DIR = $(TOP_DIR)/tools UNIX_DIR = $(SRC_DIR) MAC_OSX_DIR = $(TOP_DIR)/macosx # Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below. DLTEST_DIR = @TCL_SRC_DIR@/unix/dltest # Must be absolute to so the corresponding tcltest's tcl_library is absolute. | > | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 | AC_FLAGS = @DEFS@ AR = @AR@ RANLIB = @RANLIB@ SRC_DIR = @srcdir@ TOP_DIR = $(SRC_DIR)/.. BUILD_DIR = @builddir@ GENERIC_DIR = $(TOP_DIR)/generic TOMMATH_DIR = $(TOP_DIR)/libtommath COMPAT_DIR = $(TOP_DIR)/compat TOOL_DIR = $(TOP_DIR)/tools UNIX_DIR = $(SRC_DIR) MAC_OSX_DIR = $(TOP_DIR)/macosx # Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below. DLTEST_DIR = @TCL_SRC_DIR@/unix/dltest # Must be absolute to so the corresponding tcltest's tcl_library is absolute. |
︙ | ︙ | |||
271 272 273 274 275 276 277 | # The information below should be usable as is. The configure # script won't modify it and you shouldn't need to modify it # either. #---------------------------------------------------------------- CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ | | | | | | > < | | | > | > | > > > > > > > > > > > > > > > > > > > > > | | | | 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 | # The information below should be usable as is. The configure # script won't modify it and you shouldn't need to modify it # either. #---------------------------------------------------------------- CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ -I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR} -DTCL_TOMMATH -DMP_PREC=4 \ -I${TOMMATH_DIR} ${AC_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} \ ${NO_DEPRECATED_FLAGS} ${ENV_FLAGS} @EXTRA_CC_SWITCHES@ STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ -I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR} -DTCL_TOMMATH -DMP_PREC=4 \ -I${TOMMATH_DIR} ${AC_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${ENV_FLAGS} \ @EXTRA_CC_SWITCHES@ LIBS = @TCL_LIBS@ DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \ ${AC_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} @EXTRA_CC_SWITCHES@ TCLSH_OBJS = tclAppInit.o TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ tclThreadTest.o tclUnixTest.o XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o tclClock.o \ tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompCmds.o tclCompExpr.o \ tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclEncoding.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ tclIORChan.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ tclObj.o tclPanic.o tclParse.o tclParseExpr.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ tclPreserve.o tclProc.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclStubLib.o tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o \ tclTomMathInterface.o TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_fast_s_mp_sqr.o bn_mp_add.o bn_mp_and.o \ bn_mp_add_d.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o \ bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o bn_mp_copy.o \ bn_mp_count_bits.o bn_mp_div.o bn_mp_div_d.o bn_mp_div_2.o \ bn_mp_div_2d.o bn_mp_div_3.o \ bn_mp_exch.o bn_mp_expt_d.o bn_mp_grow.o bn_mp_init.o \ bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o \ bn_mp_init_size.o bn_mp_karatsuba_mul.o \ bn_mp_karatsuba_sqr.o \ bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \ bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \ bn_mp_radix_size.o bn_mp_radix_smap.o \ bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o bn_mp_shrink.o \ bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \ bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \ bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix_n.o \ bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o STUB_LIB_OBJS = tclStubLib.o ${COMPAT_OBJS} MAC_OSX_OBJS = tclMacOSXBundle.o tclMacOSXFCmd.o tclMacOSXNotify.o OBJS = ${GENERIC_OBJS} ${TOMMATH_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} \ ${COMPAT_OBJS} @DL_OBJS@ @PLAT_OBJS@ TCL_DECLS = \ $(GENERIC_DIR)/tcl.decls \ $(GENERIC_DIR)/tclInt.decls GENERIC_HDRS = \ $(GENERIC_DIR)/tcl.h \ |
︙ | ︙ | |||
365 366 367 368 369 370 371 372 373 374 375 376 377 378 | $(GENERIC_DIR)/tclIndexObj.c \ $(GENERIC_DIR)/tclInterp.c \ $(GENERIC_DIR)/tclIO.c \ $(GENERIC_DIR)/tclIOCmd.c \ $(GENERIC_DIR)/tclIOGT.c \ $(GENERIC_DIR)/tclIOSock.c \ $(GENERIC_DIR)/tclIOUtil.c \ $(GENERIC_DIR)/tclLink.c \ $(GENERIC_DIR)/tclListObj.c \ $(GENERIC_DIR)/tclLiteral.c \ $(GENERIC_DIR)/tclLoad.c \ $(GENERIC_DIR)/tclMain.c \ $(GENERIC_DIR)/tclNamesp.c \ $(GENERIC_DIR)/tclNotify.c \ | > | 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 | $(GENERIC_DIR)/tclIndexObj.c \ $(GENERIC_DIR)/tclInterp.c \ $(GENERIC_DIR)/tclIO.c \ $(GENERIC_DIR)/tclIOCmd.c \ $(GENERIC_DIR)/tclIOGT.c \ $(GENERIC_DIR)/tclIOSock.c \ $(GENERIC_DIR)/tclIOUtil.c \ $(GENERIC_DIR)/tclIORChan.c \ $(GENERIC_DIR)/tclLink.c \ $(GENERIC_DIR)/tclListObj.c \ $(GENERIC_DIR)/tclLiteral.c \ $(GENERIC_DIR)/tclLoad.c \ $(GENERIC_DIR)/tclMain.c \ $(GENERIC_DIR)/tclNamesp.c \ $(GENERIC_DIR)/tclNotify.c \ |
︙ | ︙ | |||
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 | $(GENERIC_DIR)/tclRegexp.c \ $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ $(GENERIC_DIR)/tclScan.c \ $(GENERIC_DIR)/tclStubInit.c \ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclTest.c \ $(GENERIC_DIR)/tclTestObj.c \ $(GENERIC_DIR)/tclTestProcBodyObj.c \ $(GENERIC_DIR)/tclThread.c \ $(GENERIC_DIR)/tclThreadAlloc.c \ $(GENERIC_DIR)/tclThreadJoin.c \ $(GENERIC_DIR)/tclThreadStorage.c \ $(GENERIC_DIR)/tclTimer.c \ $(GENERIC_DIR)/tclTrace.c \ $(GENERIC_DIR)/tclUtil.c \ $(GENERIC_DIR)/tclVar.c STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c UNIX_HDRS = \ $(UNIX_DIR)/tclUnixPort.h # $(UNIX_DIR)/tclConfig.h UNIX_SRCS = \ $(UNIX_DIR)/tclAppInit.c \ $(UNIX_DIR)/tclUnixChan.c \ $(UNIX_DIR)/tclUnixEvent.c \ $(UNIX_DIR)/tclUnixFCmd.c \ $(UNIX_DIR)/tclUnixFile.c \ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | > > | | > | > > | 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 | $(GENERIC_DIR)/tclRegexp.c \ $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ $(GENERIC_DIR)/tclScan.c \ $(GENERIC_DIR)/tclStubInit.c \ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclStrToD.c \ $(GENERIC_DIR)/tclTest.c \ $(GENERIC_DIR)/tclTestObj.c \ $(GENERIC_DIR)/tclTestProcBodyObj.c \ $(GENERIC_DIR)/tclThread.c \ $(GENERIC_DIR)/tclThreadAlloc.c \ $(GENERIC_DIR)/tclThreadJoin.c \ $(GENERIC_DIR)/tclThreadStorage.c \ $(GENERIC_DIR)/tclTimer.c \ $(GENERIC_DIR)/tclTrace.c \ $(GENERIC_DIR)/tclUtil.c \ $(GENERIC_DIR)/tclVar.c STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c TOMMATH_SRCS = \ $(TOMMATH_DIR)/bncore.c \ $(TOMMATH_DIR)/bn_reverse.c \ $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c \ $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c \ $(TOMMATH_DIR)/bn_mp_add.c \ $(TOMMATH_DIR)/bn_mp_add_d.c \ $(TOMMATH_DIR)/bn_mp_and.c \ $(TOMMATH_DIR)/bn_mp_clamp.c \ $(TOMMATH_DIR)/bn_mp_clear.c \ $(TOMMATH_DIR)/bn_mp_clear_multi.c \ $(TOMMATH_DIR)/bn_mp_cmp.c \ $(TOMMATH_DIR)/bn_mp_cmp_d.c \ $(TOMMATH_DIR)/bn_mp_cmp_mag.c \ $(TOMMATH_DIR)/bn_mp_copy.c \ $(TOMMATH_DIR)/bn_mp_count_bits.c \ $(TOMMATH_DIR)/bn_mp_div.c \ $(TOMMATH_DIR)/bn_mp_div_d.c \ $(TOMMATH_DIR)/bn_mp_div_2.c \ $(TOMMATH_DIR)/bn_mp_div_2d.c \ $(TOMMATH_DIR)/bn_mp_div_3.c \ $(TOMMATH_DIR)/bn_mp_exch.c \ $(TOMMATH_DIR)/bn_mp_expt_d.c \ $(TOMMATH_DIR)/bn_mp_grow.c \ $(TOMMATH_DIR)/bn_mp_init.c \ $(TOMMATH_DIR)/bn_mp_init_copy.c \ $(TOMMATH_DIR)/bn_mp_init_multi.c \ $(TOMMATH_DIR)/bn_mp_init_set.c \ $(TOMMATH_DIR)/bn_mp_init_size.c \ $(TOMMATH_DIR)/bn_mp_karatsuba_mul.c \ $(TOMMATH_DIR)/bn_mp_karatsuba_sqr.c \ $(TOMMATH_DIR)/bn_mp_lshd.c \ $(TOMMATH_DIR)/bn_mp_mod.c \ $(TOMMATH_DIR)/bn_mp_mod_2d.c \ $(TOMMATH_DIR)/bn_mp_mul.c \ $(TOMMATH_DIR)/bn_mp_mul_2.c \ $(TOMMATH_DIR)/bn_mp_mul_2d.c \ $(TOMMATH_DIR)/bn_mp_mul_d.c \ $(TOMMATH_DIR)/bn_mp_neg.c \ $(TOMMATH_DIR)/bn_mp_or.c \ $(TOMMATH_DIR)/bn_mp_radix_size.c \ $(TOMMATH_DIR)/bn_mp_radix_smap.c \ $(TOMMATH_DIR)/bn_mp_read_radix.c \ $(TOMMATH_DIR)/bn_mp_rshd.c \ $(TOMMATH_DIR)/bn_mp_set.c \ $(TOMMATH_DIR)/bn_mp_shrink.c \ $(TOMMATH_DIR)/bn_mp_sqr.c \ $(TOMMATH_DIR)/bn_mp_sqrt.c \ $(TOMMATH_DIR)/bn_mp_sub.c \ $(TOMMATH_DIR)/bn_mp_sub_d.c \ $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c \ $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c \ $(TOMMATH_DIR)/bn_mp_toom_mul.c \ $(TOMMATH_DIR)/bn_mp_toom_sqr.c \ $(TOMMATH_DIR)/bn_mp_toradix_n.c \ $(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c \ $(TOMMATH_DIR)/bn_mp_xor.c \ $(TOMMATH_DIR)/bn_mp_zero.c \ $(TOMMATH_DIR)/bn_s_mp_add.c \ $(TOMMATH_DIR)/bn_s_mp_mul_digs.c \ $(TOMMATH_DIR)/bn_s_mp_sqr.c \ $(TOMMATH_DIR)/bn_s_mp_sub.c UNIX_HDRS = \ $(UNIX_DIR)/tclUnixPort.h # $(UNIX_DIR)/tclConfig.h UNIX_SRCS = \ $(UNIX_DIR)/tclAppInit.c \ $(UNIX_DIR)/tclUnixChan.c \ $(UNIX_DIR)/tclUnixEvent.c \ $(UNIX_DIR)/tclUnixFCmd.c \ $(UNIX_DIR)/tclUnixFile.c \ $(UNIX_DIR)/tclUnixPipe.c \ $(UNIX_DIR)/tclUnixSock.c \ $(UNIX_DIR)/tclUnixTest.c \ $(UNIX_DIR)/tclUnixThrd.c \ $(UNIX_DIR)/tclUnixTime.c \ $(UNIX_DIR)/tclUnixInit.c NOTIFY_SRCS = \ $(UNIX_DIR)/tclUnixNotfy.c DL_SRCS = \ $(UNIX_DIR)/tclLoadAix.c \ $(UNIX_DIR)/tclLoadDl.c \ $(UNIX_DIR)/tclLoadDl2.c \ $(UNIX_DIR)/tclLoadDld.c \ $(UNIX_DIR)/tclLoadDyld.c \ $(GENERIC_DIR)/tclLoadNone.c \ $(UNIX_DIR)/tclLoadOSF.c \ $(UNIX_DIR)/tclLoadShl.c MAC_OSX_SRCS = \ $(MAC_OSX_DIR)/tclMacOSXBundle.c \ $(MAC_OSX_DIR)/tclMacOSXFCmd.c \ $(MAC_OSX_DIR)/tclMacOSXNotify.c # Note: don't include DL_SRCS or MAC_OSX_SRCS in SRCS: most of those # files won't compile on the current machine, and they will cause # problems for things like "make depend". SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) \ $(UNIX_SRCS) $(NOTIFY_SRCS) $(STUB_SRCS) \ @PLAT_SRCS@ all: binaries libraries doc binaries: ${LIB_FILE} $(STUB_LIB_FILE) $(TCL_BUILD_EXP_FILE) tclsh libraries: |
︙ | ︙ | |||
497 498 499 500 501 502 503 | # "make test" won't work in the case where the compilation directory # isn't the same as the source directory. # Specifying TESTFLAGS on the command line is the standard way to pass # args to tcltest, ie: # % make test TESTFLAGS="-verbose bps -file fileName.test" test: tcltest | | | | | | | | | | > > > > > > > > > > | > > | | 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 | # "make test" won't work in the case where the compilation directory # isn't the same as the source directory. # Specifying TESTFLAGS on the command line is the standard way to pass # args to tcltest, ie: # % make test TESTFLAGS="-verbose bps -file fileName.test" test: tcltest @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./tcltest $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) # Useful target to launch a built tcltest with the proper path,... runtest: tcltest @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./tcltest # Useful target for running the test suite with an unwritable current # directory... ro-test: tcltest @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ echo 'exec chmod -w .;package require tcltest;tcltest::temporaryDirectory /tmp;source ../tests/all.tcl;exec chmod +w .' | ./tcltest # This target can be used to run tclsh from the build directory # via `make shell SCRIPT=/tmp/foo.tcl` shell: tclsh @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./tclsh $(SCRIPT) # This target can be used to run tclsh inside either gdb or insight gdb: tclsh @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run $(GDB) ./tclsh --command=gdb.run rm gdb.run # This target can be used to run tclsh inside ddd ddd: tclsh @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run $(DDD) -command=gdb.run ./tclsh rm gdb.run valgrind: tclsh tcltest @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ valgrind --num-callers=8 --leak-resolution=high -v --leak-check=yes --show-reachable=yes $(VALGRINDARGS) ./tcltest $(TOP_DIR)/tests/all.tcl -singleproc 1 $(TESTFLAGS) # 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). .NO_PARALLEL: topDirName topDirName: @cd $(TOP_DIR); pwd # The following target generates the file generic/tclDate.c # from the yacc grammar found in generic/tclGetDate.y. This is # only run by hand as yacc is not available in all environments. # The name of the .c file is different than the name of the .y file # so that make doesn't try to automatically regenerate the .c file. gendate: bison --output-file=$(GENERIC_DIR)/tclDate.c \ --no-lines \ --name-prefix=TclDate \ $(GENERIC_DIR)/tclGetDate.y # yacc -l $(GENERIC_DIR)/tclGetDate.y # sed -e 's/yy/TclDate/g' -e '/^#include <values.h>/d' \ # -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' \ # -e '/#define YYNEW/s/malloc/TclDateAlloc/g' \ # -e '/#define YYENLARGE/,/realloc/s/realloc/TclDateRealloc/g' \ # <y.tab.c >$(GENERIC_DIR)/tclDate.c # rm y.tab.c # The following target generates the file generic/tommath.h. # It needs to be run (and the results checked) after updating # to a new release of libtommath. gentommath_h: $(TCL_EXE) "$(TOP_DIR)/tools/fix_tommath_h.tcl" \ "$(TOMMATH_DIR)/tommath.h" \ > "$(GENERIC_DIR)/tommath.h" # 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_TARGETS = install-binaries install-libraries install-doc @EXTRA_INSTALL@ install: $(INSTALL_TARGETS) install-strip: $(MAKE) $(INSTALL_TARGETS) \ INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \ INSTALL_LIBRARY="$(INSTALL_LIBRARY) ${INSTALL_STRIP_LIBRARY}" # Note: before running ranlib below, must cd to target directory because # some ranlibs write to current directory, and this might not always be # possible (e.g. if installing as root). |
︙ | ︙ | |||
621 622 623 624 625 626 627 628 629 630 631 632 633 634 | @$(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 install-tzdata install-msgs @for i in $(INCLUDE_INSTALL_DIR) $(SCRIPT_INSTALL_DIR); \ do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ mkdir -p $$i; \ | > | 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 | @$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION) @echo "Installing tclConfig.sh to $(LIB_INSTALL_DIR)/" @$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh @if test "$(STUB_LIB_FILE)" != "" ; then \ echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \ @INSTALL_STUB_LIB@ ; \ fi @EXTRA_INSTALL_BINARIES@ install-libraries: libraries install-tzdata install-msgs @for i in $(INCLUDE_INSTALL_DIR) $(SCRIPT_INSTALL_DIR); \ do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ mkdir -p $$i; \ |
︙ | ︙ | |||
660 661 662 663 664 665 666 | $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \ done; @echo "Installing library http1.0 directory"; @for j in $(TOP_DIR)/library/http1.0/*.tcl ; \ do \ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http1.0; \ done; | | | | | | | | 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 | $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \ done; @echo "Installing library http1.0 directory"; @for j in $(TOP_DIR)/library/http1.0/*.tcl ; \ do \ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http1.0; \ done; @echo "Installing package http 2.5.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.1.tm; @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 package msgcat 1.4.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.1.tm; @echo "Installing package tcltest 2.2.8 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.3/tcltest-2.2.8.tm; @echo "Installing library encoding directory"; @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR)/encoding; \ done; @if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ]; then \ echo "Customizing tcl module path"; \ echo "::tcl::tm::roots {$(TCL_MODULE_PATH)}" >> \ $(SCRIPT_INSTALL_DIR)/tm.tcl; \ fi install-tzdata: @echo "Installing time zone data" @@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./tclsh $(TOOL_DIR)/installData.tcl \ $(TOP_DIR)/library/tzdata $(SCRIPT_INSTALL_DIR)/tzdata install-msgs: @echo "Installing message catalogs" @@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./tclsh $(TOOL_DIR)/installData.tcl \ $(TOP_DIR)/library/msgs $(SCRIPT_INSTALL_DIR)/msgs install-doc: doc @if test ! -x $(UNIX_DIR)/installManPage; then \ chmod +x $(UNIX_DIR)/installManPage; \ |
︙ | ︙ | |||
744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 | @echo "Installing private header files"; @for i in $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \ $(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \ $(UNIX_DIR)/tclUnixPort.h; \ do \ $(INSTALL_DATA) $$i $(PRIVATE_INCLUDE_INSTALL_DIR); \ done; Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in $(SHELL) config.status #tclConfig.h: $(UNIX_DIR)/tclConfig.h.in # $(SHELL) config.status clean: rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \ | > > > | | | 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 | @echo "Installing private header files"; @for i in $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \ $(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \ $(UNIX_DIR)/tclUnixPort.h; \ do \ $(INSTALL_DATA) $$i $(PRIVATE_INCLUDE_INSTALL_DIR); \ done; @if test -f tclConfig.h; then\ $(INSTALL_DATA) tclConfig.h $(PRIVATE_INCLUDE_INSTALL_DIR); \ fi; Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in $(SHELL) config.status #tclConfig.h: $(UNIX_DIR)/tclConfig.h.in # $(SHELL) config.status clean: rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \ errors tclsh tcltest lib.exp Tcl cd dltest ; $(MAKE) clean distclean: clean rm -rf Makefile config.status config.cache config.log tclConfig.sh \ $(PACKAGE).* prototype tclConfig.h *.plist Tcl.framework cd dltest ; $(MAKE) distclean depend: makedepend -- $(DEPEND_SWITCHES) -- $(SRCS) # Test binaries. The rules for tclTestInit.o and xtTestInit.o are # complicated because they are compiled from tclAppInit.c. Can't use |
︙ | ︙ | |||
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 | tclIOSock.o: $(GENERIC_DIR)/tclIOSock.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOSock.c tclIOUtil.o: $(GENERIC_DIR)/tclIOUtil.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOUtil.c tclLink.o: $(GENERIC_DIR)/tclLink.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLink.c tclListObj.o: $(GENERIC_DIR)/tclListObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c tclObj.o: $(GENERIC_DIR)/tclObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c tclLoad.o: $(GENERIC_DIR)/tclLoad.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c tclLoadAix.o: $(UNIX_DIR)/tclLoadAix.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAix.c | > > > < < < | 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 | tclIOSock.o: $(GENERIC_DIR)/tclIOSock.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOSock.c tclIOUtil.o: $(GENERIC_DIR)/tclIOUtil.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOUtil.c tclIORChan.o: $(GENERIC_DIR)/tclIORChan.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIORChan.c tclLink.o: $(GENERIC_DIR)/tclLink.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLink.c tclListObj.o: $(GENERIC_DIR)/tclListObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c tclObj.o: $(GENERIC_DIR)/tclObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c tclLoad.o: $(GENERIC_DIR)/tclLoad.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c tclLoadAix.o: $(UNIX_DIR)/tclLoadAix.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAix.c tclLoadDl.o: $(UNIX_DIR)/tclLoadDl.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl.c tclLoadDl2.o: $(UNIX_DIR)/tclLoadDl2.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl2.c tclLoadDld.o: $(UNIX_DIR)/tclLoadDld.c |
︙ | ︙ | |||
1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 | tclScan.o: $(GENERIC_DIR)/tclScan.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclScan.c tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c tclStubInit.o: $(GENERIC_DIR)/tclStubInit.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStubInit.c tclTrace.o: $(GENERIC_DIR)/tclTrace.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTrace.c tclUtil.o: $(GENERIC_DIR)/tclUtil.c | > > > | 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 | tclScan.o: $(GENERIC_DIR)/tclScan.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclScan.c tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c tclStrToD.o: $(GENERIC_DIR)/tclStrToD.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStrToD.c tclStubInit.o: $(GENERIC_DIR)/tclStubInit.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStubInit.c tclTrace.o: $(GENERIC_DIR)/tclTrace.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTrace.c tclUtil.o: $(GENERIC_DIR)/tclUtil.c |
︙ | ︙ | |||
1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 | tclThreadStorage.o: $(GENERIC_DIR)/tclThreadStorage.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadStorage.c tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c tclUnixChan.o: $(UNIX_DIR)/tclUnixChan.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixChan.c tclUnixEvent.o: $(UNIX_DIR)/tclUnixEvent.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixEvent.c tclUnixFCmd.o: $(UNIX_DIR)/tclUnixFCmd.c | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | tclThreadStorage.o: $(GENERIC_DIR)/tclThreadStorage.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadStorage.c tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c tclTomMathInterface.o: $(GENERIC_DIR)/tclTomMathInterface.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTomMathInterface.c bncore.o: $(TOMMATH_DIR)/bncore.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bncore.c bn_reverse.o: $(TOMMATH_DIR)/bn_reverse.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_reverse.c bn_fast_s_mp_mul_digs.o: $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c bn_fast_s_mp_sqr.o: $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c bn_mp_add.o: $(TOMMATH_DIR)/bn_mp_add.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_add.c bn_mp_add_d.o: $(TOMMATH_DIR)/bn_mp_add_d.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_add_d.c bn_mp_and.o: $(TOMMATH_DIR)/bn_mp_and.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_and.c bn_mp_clamp.o: $(TOMMATH_DIR)/bn_mp_clamp.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_clamp.c bn_mp_clear.o: $(TOMMATH_DIR)/bn_mp_clear.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_clear.c bn_mp_clear_multi.o: $(TOMMATH_DIR)/bn_mp_clear_multi.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_clear_multi.c bn_mp_cmp.o: $(TOMMATH_DIR)/bn_mp_cmp.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_cmp.c bn_mp_cmp_d.o: $(TOMMATH_DIR)/bn_mp_cmp_d.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_cmp_d.c bn_mp_cmp_mag.o: $(TOMMATH_DIR)/bn_mp_cmp_mag.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_cmp_mag.c bn_mp_copy.o: $(TOMMATH_DIR)/bn_mp_copy.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_copy.c bn_mp_count_bits.o: $(TOMMATH_DIR)/bn_mp_count_bits.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_count_bits.c bn_mp_div.o: $(TOMMATH_DIR)/bn_mp_div.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div.c bn_mp_div_d.o: $(TOMMATH_DIR)/bn_mp_div_d.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_d.c bn_mp_div_2.o: $(TOMMATH_DIR)/bn_mp_div_2.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_2.c bn_mp_div_2d.o: $(TOMMATH_DIR)/bn_mp_div_2d.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_2d.c bn_mp_div_3.o: $(TOMMATH_DIR)/bn_mp_div_3.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_3.c bn_mp_exch.o: $(TOMMATH_DIR)/bn_mp_exch.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_exch.c bn_mp_expt_d.o: $(TOMMATH_DIR)/bn_mp_expt_d.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_d.c bn_mp_grow.o: $(TOMMATH_DIR)/bn_mp_grow.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_grow.c bn_mp_init.o: $(TOMMATH_DIR)/bn_mp_init.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init.c bn_mp_init_copy.o: $(TOMMATH_DIR)/bn_mp_init_copy.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_copy.c bn_mp_init_multi.o: $(TOMMATH_DIR)/bn_mp_init_multi.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_multi.c bn_mp_init_set.o: $(TOMMATH_DIR)/bn_mp_init_set.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_set.c bn_mp_init_size.o:$(TOMMATH_DIR)/bn_mp_init_size.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_size.c bn_mp_karatsuba_mul.o: $(TOMMATH_DIR)/bn_mp_karatsuba_mul.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_karatsuba_mul.c bn_mp_karatsuba_sqr.o: $(TOMMATH_DIR)/bn_mp_karatsuba_sqr.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_karatsuba_sqr.c bn_mp_lshd.o: $(TOMMATH_DIR)/bn_mp_lshd.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_lshd.c bn_mp_mod.o: $(TOMMATH_DIR)/bn_mp_mod.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mod.c bn_mp_mod_2d.o: $(TOMMATH_DIR)/bn_mp_mod_2d.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mod_2d.c bn_mp_mul.o: $(TOMMATH_DIR)/bn_mp_mul.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mul.c bn_mp_mul_2.o: $(TOMMATH_DIR)/bn_mp_mul_2.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mul_2.c bn_mp_mul_2d.o: $(TOMMATH_DIR)/bn_mp_mul_2d.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mul_2d.c bn_mp_mul_d.o: $(TOMMATH_DIR)/bn_mp_mul_d.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mul_d.c bn_mp_neg.o: $(TOMMATH_DIR)/bn_mp_neg.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_neg.c bn_mp_or.o: $(TOMMATH_DIR)/bn_mp_or.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_or.c bn_mp_radix_size.o: $(TOMMATH_DIR)/bn_mp_radix_size.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_radix_size.c bn_mp_radix_smap.o: $(TOMMATH_DIR)/bn_mp_radix_smap.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_radix_smap.c bn_mp_read_radix.o: $(TOMMATH_DIR)/bn_mp_read_radix.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_read_radix.c bn_mp_rshd.o: $(TOMMATH_DIR)/bn_mp_rshd.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_rshd.c bn_mp_set.o: $(TOMMATH_DIR)/bn_mp_set.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set.c bn_mp_shrink.o: $(TOMMATH_DIR)/bn_mp_shrink.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_shrink.c bn_mp_sqr.o: $(TOMMATH_DIR)/bn_mp_sqr.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sqr.c bn_mp_sqrt.o: $(TOMMATH_DIR)/bn_mp_sqrt.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sqrt.c bn_mp_sub.o: $(TOMMATH_DIR)/bn_mp_sub.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub.c bn_mp_sub_d.o: $(TOMMATH_DIR)/bn_mp_sub_d.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub_d.c bn_mp_to_unsigned_bin.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c bn_mp_to_unsigned_bin_n.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c bn_mp_toom_mul.o: $(TOMMATH_DIR)/bn_mp_toom_mul.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_toom_mul.c bn_mp_toom_sqr.o: $(TOMMATH_DIR)/bn_mp_toom_sqr.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_toom_sqr.c bn_mp_toradix_n.o: $(TOMMATH_DIR)/bn_mp_toradix_n.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_toradix_n.c bn_mp_unsigned_bin_size.o: $(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c bn_mp_xor.o: $(TOMMATH_DIR)/bn_mp_xor.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_xor.c bn_mp_zero.o: $(TOMMATH_DIR)/bn_mp_zero.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_zero.c bn_s_mp_add.o: $(TOMMATH_DIR)/bn_s_mp_add.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_add.c bn_s_mp_mul_digs.o: $(TOMMATH_DIR)/bn_s_mp_mul_digs.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_mul_digs.c bn_s_mp_sqr.o: $(TOMMATH_DIR)/bn_s_mp_sqr.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_sqr.c bn_s_mp_sub.o: $(TOMMATH_DIR)/bn_s_mp_sub.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_sub.c tclUnixChan.o: $(UNIX_DIR)/tclUnixChan.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixChan.c tclUnixEvent.o: $(UNIX_DIR)/tclUnixEvent.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixEvent.c tclUnixFCmd.o: $(UNIX_DIR)/tclUnixFCmd.c |
︙ | ︙ | |||
1108 1109 1110 1111 1112 1113 1114 | $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh $(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \ -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \ $(UNIX_DIR)/tclUnixInit.c | | > > > | 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 | $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh $(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \ -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \ $(UNIX_DIR)/tclUnixInit.c # The following are Mac OS X only sources: tclMacOSXBundle.o: $(MAC_OSX_DIR)/tclMacOSXBundle.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXBundle.c tclMacOSXFCmd.o: $(MAC_OSX_DIR)/tclMacOSXFCmd.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXFCmd.c tclMacOSXNotify.o: $(MAC_OSX_DIR)/tclMacOSXNotify.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXNotify.c # The following targets are not completely general. They are provide # purely for documentation purposes so people who are interested in # the Xt based notifier can modify them to suit their own installation. xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ @DL_OBJS@ ${BUILD_DLTEST} ${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ |
︙ | ︙ | |||
1176 1177 1178 1179 1180 1181 1182 | $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/tmpnam.c waitpid.o: $(COMPAT_DIR)/waitpid.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/waitpid.c # Stub library binaries, these must be compiled for use in a shared library # even though they will be placed in a static archive | < | 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 | $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/tmpnam.c waitpid.o: $(COMPAT_DIR)/waitpid.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/waitpid.c # Stub library binaries, these must be compiled for use in a shared library # even though they will be placed in a static archive tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c .c.o: $(CC) -c $(CC_SWITCHES) $< |
︙ | ︙ | |||
1266 1267 1268 1269 1270 1271 1272 | rpm -bb THIS.TCL.SPEC mv RPMS/i386/*.rpm . rm -rf RPMS THIS.TCL.SPEC # # Target to create a proper Tcl distribution from information in the # master source directory. DISTDIR must be defined to indicate where | | | 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 | rpm -bb THIS.TCL.SPEC mv RPMS/i386/*.rpm . rm -rf RPMS THIS.TCL.SPEC # # Target to create a proper Tcl distribution from information in the # master source directory. DISTDIR must be defined to indicate where # to put the distribution. DISTDIR must be an absolute path name. # DISTROOT = /tmp/dist DISTNAME = tcl${VERSION}${PATCH_LEVEL} ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip DISTDIR = $(DISTROOT)/$(DISTNAME) $(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in $(UNIX_DIR)/tcl.m4 |
︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 | for i in http1.0 http opt msgcat reg dde tcltest; \ do \ mkdir $(DISTDIR)/library/$$i ;\ cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ done; mkdir $(DISTDIR)/library/encoding cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding mkdir $(DISTDIR)/doc cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc mkdir $(DISTDIR)/compat cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/compat/*.c \ $(TOP_DIR)/compat/*.h $(TOP_DIR)/compat/README \ $(DISTDIR)/compat | > > > > > > | 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 | for i in http1.0 http opt msgcat reg dde tcltest; \ do \ mkdir $(DISTDIR)/library/$$i ;\ cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ done; mkdir $(DISTDIR)/library/encoding cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding mkdir $(DISTDIR)/library/msgs cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs ( cd $(TOP_DIR); \ find library/tzdata -name CVS -prune -o -type f -print ) \ | ( cd $(TOP_DIR) ; xargs tar cf - ) \ | ( cd $(DISTDIR) ; tar xfp - ) mkdir $(DISTDIR)/doc cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc mkdir $(DISTDIR)/compat cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/compat/*.c \ $(TOP_DIR)/compat/*.h $(TOP_DIR)/compat/README \ $(DISTDIR)/compat |
︙ | ︙ | |||
1348 1349 1350 1351 1352 1353 1354 | $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.hpj.in cp -p $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.ds* cp -p $(TOP_DIR)/win/README $(DISTDIR)/win cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win mkdir $(DISTDIR)/macosx cp -p $(TOP_DIR)/macosx/Makefile \ | | > > > | 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 | $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.hpj.in cp -p $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.ds* cp -p $(TOP_DIR)/win/README $(DISTDIR)/win cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win mkdir $(DISTDIR)/macosx cp -p $(TOP_DIR)/macosx/Makefile \ $(TOP_DIR)/macosx/*.c $(TOP_DIR)/macosx/*.in \ $(DISTDIR)/macosx mkdir $(DISTDIR)/macosx/Tcl.pbproj cp -p $(TOP_DIR)/macosx/Tcl.pbproj/*.pbx* $(DISTDIR)/macosx/Tcl.pbproj cp -p $(TOP_DIR)/macosx/README $(DISTDIR)/macosx mkdir $(DISTDIR)/unix/dltest cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ $(UNIX_DIR)/dltest/README \ $(DISTDIR)/unix/dltest mkdir $(DISTDIR)/tools cp -p $(TOP_DIR)/tools/Makefile.in $(TOP_DIR)/tools/README \ $(TOP_DIR)/tools/configure $(TOP_DIR)/tools/configure.in \ $(TOP_DIR)/tools/*.tcl $(TOP_DIR)/tools/man2tcl.c \ $(TOP_DIR)/tools/tcl.wse.in $(TOP_DIR)/tools/*.bmp \ $(TOP_DIR)/tools/tcl.hpj.in \ $(DISTDIR)/tools $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/tools/tcl.hpj.in \ $(DISTDIR)/tools/tcl.wse.in mkdir $(DISTDIR)/libtommath cp -p $(TOP_DIR)/libtommath/*.* \ $(DISTDIR)/libtommath # # The following target can only be used for non-patch releases. Use # the "allpatch" target below for patch releases. # alldist: dist |
︙ | ︙ | |||
1398 1399 1400 1401 1402 1403 1404 | mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/$(DISTNAME) mv $(DISTROOT)/old $(DISTROOT)/tcl${VERSION} # # This target creates the HTML folder for Tcl & Tk and places it # in DISTDIR/html. It uses the tcltk-man2html.tcl tool from # the Tcl group's tool workspace. It depends on the Tcl & Tk being | | > > > > > | | | 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 | mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/$(DISTNAME) mv $(DISTROOT)/old $(DISTROOT)/tcl${VERSION} # # This target creates the HTML folder for Tcl & Tk and places it # in DISTDIR/html. It uses the tcltk-man2html.tcl tool from # the Tcl group's tool workspace. It depends on the Tcl & Tk being # in directories called tcl8.* & tk8.* up two directories from the # TOOL_DIR. # html: $(BUILD_HTML) @EXTRA_BUILD_HTML@ html-tcl: $(BUILD_HTML) --tcl @EXTRA_BUILD_HTML@ html-tk: $(BUILD_HTML) --tk @EXTRA_BUILD_HTML@ BUILD_HTML = \ @@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \ ./tclsh $(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) \ --srcdir=$(TOP_DIR)/.. $(BUILD_HTML_FLAGS) # # Targets to build Solaris package of the distribution for the current # architecture. To build stream packages for both sun4 and i86pc # architectures: # # On the sun4 machine, execute the following: |
︙ | ︙ |
Changes to unix/configure.
1 2 | #! /bin/sh # Guess values for system-dependent variables and create Makefiles. | | < | > | | | 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 | #! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.59 for tcl 8.5. # # Copyright (C) 2003 Free Software Foundation, Inc. # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## # Be Bourne compatible if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # Work around bugs in pre-3.0 UWIN ksh. $as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done # Required to use basename. |
︙ | ︙ | |||
214 215 216 217 218 219 220 221 222 223 224 225 226 | as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. | > | | | 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 | as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' ' IFS=" $as_nl" |
︙ | ︙ | |||
303 304 305 306 307 308 309 | # include <stdint.h> # endif #endif #if HAVE_UNISTD_H # include <unistd.h> #endif" | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 | # include <stdint.h> # endif #endif #if HAVE_UNISTD_H # include <unistd.h> #endif" ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS MAN_FLAGS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP TCL_THREADS RANLIB ac_ct_RANLIB AR LIBOBJS TCL_LIBS DL_LIBS DL_OBJS PLAT_OBJS PLAT_SRCS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING LDFLAGS_DEBUG LDFLAGS_OPTIMIZE CC_SEARCH_FLAGS LD_SEARCH_FLAGS STLIB_LD SHLIB_LD TCL_SHLIB_LD_EXTRAS TK_SHLIB_LD_EXTRAS SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX MAKE_LIB MAKE_STUB_LIB INSTALL_LIB INSTALL_STUB_LIB CFLAGS_DEFAULT LDFLAGS_DEFAULT TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_YEAR TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_SRC_DIR CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX TCL_SHARED_BUILD LD_LIBRARY_PATH_VAR TCL_BUILD_LIB_SPEC TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_SHARED_LIB_SUFFIX TCL_UNSHARED_LIB_SUFFIX TCL_HAS_LONGLONG BUILD_DLTEST TCL_PACKAGE_PATH TCL_MODULE_PATH TCL_LIBRARY PRIVATE_INCLUDE_DIR HTML_DIR EXTRA_CC_SWITCHES EXTRA_INSTALL EXTRA_INSTALL_BINARIES EXTRA_BUILD_HTML' ac_subst_files='' # Initialize some variables set by options. ac_init_help= ac_init_version=false # The variables have the same names as the options, with # dashes changed to underlines. |
︙ | ︙ | |||
662 663 664 665 666 667 668 | *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; };; esac done # Be sure to have absolute paths. for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ | | | 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 | *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; };; esac done # Be sure to have absolute paths. for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ localstatedir libdir includedir oldincludedir infodir mandir do eval ac_val=$`echo $ac_var` case $ac_val in [\\/$]* | ?:[\\/]* ) ;; *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; };; esac |
︙ | ︙ | |||
702 703 704 705 706 707 708 | # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then its parent. ac_confdir=`(dirname "$0") 2>/dev/null || $as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ | | | | | | 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 | # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then its parent. ac_confdir=`(dirname "$0") 2>/dev/null || $as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$0" : 'X\(//\)[^/]' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$0" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` srcdir=$ac_confdir |
︙ | ︙ | |||
797 798 799 800 801 802 803 | --srcdir=DIR find the sources in DIR [configure dir or \`..'] _ACEOF cat <<_ACEOF Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX | | | | 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 | --srcdir=DIR find the sources in DIR [configure dir or \`..'] _ACEOF cat <<_ACEOF Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. |
︙ | ︙ | |||
836 837 838 839 840 841 842 | short | recursive ) echo "Configuration of tcl 8.5:";; esac cat <<\_ACEOF Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] | | | | > | | | | > > | | | > | | | > | 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 | short | recursive ) echo "Configuration of tcl 8.5:";; esac cat <<\_ACEOF Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-man-symlinks use symlinks for the manpages (default: off) --enable-man-compression=PROG compress the manpages with PROG (default: off) --enable-man-suffix=STRING use STRING as a suffix to manpage file names (default: no, tcl if enabled without specifying STRING) --enable-threads build with threads (default: off) --enable-shared build and link with shared libraries (default: on) --enable-64bit enable 64bit support (default: off) --enable-64bit-vis enable 64bit Sparc VIS support (default: off) --enable-corefoundation use CoreFoundation API on MacOSX (default: yes) --disable-load disallow dynamic loading and "load" command (default: enabled) --enable-symbols build with debugging symbols (default: off) --enable-langinfo use nl_langinfo if possible to determine encoding at startup, otherwise use old heuristic (default: on) --enable-dll-unloading turn on the 'unload' command (default: on) --enable-framework package shared libraries in MacOSX frameworks (default: off) Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-encoding encoding for configuration values (default: iso8859-1) Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries in a nonstandard directory <lib dir> CPPFLAGS C/C++ preprocessor flags, e.g. -I<include dir> if you have |
︙ | ︙ | |||
903 904 905 906 907 908 909 | [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac | | | > > > > > | > > > > > > > | > > > > > > | > > > > > > > > > > | > > > > > | | < | | | 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 | [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac # Do not use `cd foo && pwd` to compute absolute paths, because # the directories may not exist. case `pwd` in .) ac_abs_builddir="$ac_dir";; *) case "$ac_dir" in .) ac_abs_builddir=`pwd`;; [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; *) ac_abs_builddir=`pwd`/"$ac_dir";; esac;; esac case $ac_abs_builddir in .) ac_abs_top_builddir=${ac_top_builddir}.;; *) case ${ac_top_builddir}. in .) ac_abs_top_builddir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; esac;; esac case $ac_abs_builddir in .) ac_abs_srcdir=$ac_srcdir;; *) case $ac_srcdir in .) ac_abs_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; esac;; esac case $ac_abs_builddir in .) ac_abs_top_srcdir=$ac_top_srcdir;; *) case $ac_top_srcdir in .) ac_abs_top_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; esac;; esac cd $ac_dir # Check for guested configure; otherwise get Cygnus style configure. if test -f $ac_srcdir/configure.gnu; then echo $SHELL $ac_srcdir/configure.gnu --help=recursive elif test -f $ac_srcdir/configure; then echo $SHELL $ac_srcdir/configure --help=recursive elif test -f $ac_srcdir/configure.ac || test -f $ac_srcdir/configure.in; then echo $ac_configure --help else echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi cd $ac_popdir done fi test -n "$ac_init_help" && exit 0 if $ac_init_version; then cat <<\_ACEOF tcl configure 8.5 generated by GNU Autoconf 2.59 Copyright (C) 2003 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit 0 fi exec 5>config.log cat >&5 <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by tcl $as_me 8.5, which was generated by GNU Autoconf 2.59. Invocation command line was $ $0 $@ _ACEOF { cat <<_ASUNAME ## --------- ## |
︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 | ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) ac_configure_args1="$ac_configure_args1 '$ac_arg'" if test $ac_must_keep_next = true; then | | | | | | | | | | | | | | 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 | ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) ac_configure_args1="$ac_configure_args1 '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" # Get rid of the leading space. ac_sep=" " ;; esac done |
︙ | ︙ | |||
1071 1072 1073 1074 1075 1076 1077 | echo # The following way of writing the cache mishandles newlines in values, { (set) 2>&1 | case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in *ac_space=\ *) sed -n \ | | | | | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 | echo # The following way of writing the cache mishandles newlines in values, { (set) 2>&1 | case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in *ac_space=\ *) sed -n \ "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" ;; *) sed -n \ "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } echo cat <<\_ASBOX ## ----------------- ## |
︙ | ︙ | |||
1105 1106 1107 1108 1109 1110 1111 | ## Output files. ## ## ------------- ## _ASBOX echo for ac_var in $ac_subst_files do eval ac_val=$`echo $ac_var` | | | | 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 | ## Output files. ## ## ------------- ## _ASBOX echo for ac_var in $ac_subst_files do eval ac_val=$`echo $ac_var` echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo fi if test -s confdefs.h; then cat <<\_ASBOX ## ----------- ## ## confdefs.h. ## ## ----------- ## _ASBOX echo sed "/^$/d" confdefs.h | sort echo fi test "$ac_signal" != 0 && echo "$as_me: caught signal $ac_signal" echo "$as_me: exit $exit_status" } >&5 rm -f core *.core && rm -rf conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal done ac_signal=0 |
︙ | ︙ | |||
1204 1205 1206 1207 1208 1209 1210 | >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in `(set) 2>&1 | | | | | | | | 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 | >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in `(set) 2>&1 | sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val="\$ac_cv_env_${ac_var}_value" eval ac_new_val="\$ac_env_${ac_var}_value" case $ac_old_set,$ac_new_set in set,) { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 echo "$as_me: former value: $ac_old_val" >&2;} { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 echo "$as_me: current value: $ac_new_val" >&2;} ac_cache_corrupted=: fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; |
︙ | ︙ | |||
1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 | TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 | > | < < < | | | | | > | | > | > | | | | | | | | | | | | > | > | > | | 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 | TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 TCL_PATCH_LEVEL="a4" 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 TCL_SRC_DIR=`cd $srcdir/..; pwd` #------------------------------------------------------------------------ # Compress and/or soft link the manpages? #------------------------------------------------------------------------ echo "$as_me:$LINENO: checking whether to use symlinks for manpages" >&5 echo $ECHO_N "checking whether to use symlinks for manpages... $ECHO_C" >&6 # 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" && MAN_FLAGS="$MAN_FLAGS --symlinks" else enableval="no" fi; echo "$as_me:$LINENO: result: $enableval" >&5 echo "${ECHO_T}$enableval" >&6 echo "$as_me:$LINENO: checking whether to compress the manpages" >&5 echo $ECHO_N "checking whether to compress the manpages... $ECHO_C" >&6 # Check whether --enable-man-compression or --disable-man-compression was given. if test "${enable_man_compression+set}" = set; then enableval="$enable_man_compression" case $enableval in yes) { { echo "$as_me:$LINENO: error: missing argument to --enable-man-compression" >&5 echo "$as_me: error: missing argument to --enable-man-compression" >&2;} { (exit 1); exit 1; }; };; no) ;; *) MAN_FLAGS="$MAN_FLAGS --compress $enableval";; esac else enableval="no" fi; echo "$as_me:$LINENO: result: $enableval" >&5 echo "${ECHO_T}$enableval" >&6 if test "$enableval" != "no"; then echo "$as_me:$LINENO: checking for compressed file suffix" >&5 echo $ECHO_N "checking for compressed file suffix... $ECHO_C" >&6 touch TeST $enableval TeST Z=`ls TeST* | sed 's/^....//'` rm -f TeST* MAN_FLAGS="$MAN_FLAGS --extension $Z" echo "$as_me:$LINENO: result: $Z" >&5 echo "${ECHO_T}$Z" >&6 fi echo "$as_me:$LINENO: checking whether to add a package name suffix for the manpages" >&5 echo $ECHO_N "checking whether to add a package name suffix for the manpages... $ECHO_C" >&6 # Check whether --enable-man-suffix or --disable-man-suffix was given. if test "${enable_man_suffix+set}" = set; then enableval="$enable_man_suffix" case $enableval in yes) enableval="tcl";; no) ;; *) MAN_FLAGS="$MAN_FLAGS --suffix $enableval";; esac else enableval="no" fi; echo "$as_me:$LINENO: result: $enableval" >&5 echo "${ECHO_T}$enableval" >&6 #------------------------------------------------------------------------ # Standard compiler checks |
︙ | ︙ | |||
1710 1711 1712 1713 1714 1715 1716 | { (eval echo "$as_me:$LINENO: \"$ac_compiler -V </dev/null >&5\"") >&5 (eval $ac_compiler -V </dev/null >&5) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } cat >conftest.$ac_ext <<_ACEOF | < | | | | | | | | | | | | | | | | 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 | { (eval echo "$as_me:$LINENO: \"$ac_compiler -V </dev/null >&5\"") >&5 (eval $ac_compiler -V </dev/null >&5) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6 ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 (eval $ac_link_default) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then # Find the output, starting from the most likely. This scheme is # not robust to junk in `.', hence go to wildcards (a.*) only as a last # resort. # Be careful to initialize this variable, since it used to be cached. # Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile. ac_cv_exeext= # b.out is created by i960 compilers. for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; conftest.$ac_ext ) # This is the source file. ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` # FIXME: I believe we export ac_cv_exeext for Libtool, # but it would be cool to find out if it's true. Does anybody # maintain Libtool? --akim. export ac_cv_exeext break;; * ) break;; esac done else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { echo "$as_me:$LINENO: error: C compiler cannot create executables |
︙ | ︙ | |||
1841 1842 1843 1844 1845 1846 1847 | # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` | | | | 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 | # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` export ac_cv_exeext break;; * ) break;; esac done else { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link See \`config.log' for more details." >&5 echo "$as_me: error: cannot compute suffix of executables: cannot compile and link |
︙ | ︙ | |||
1867 1868 1869 1870 1871 1872 1873 | ac_exeext=$EXEEXT echo "$as_me:$LINENO: checking for suffix of object files" >&5 echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 if test "${ac_cv_objext+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 | ac_exeext=$EXEEXT echo "$as_me:$LINENO: checking for suffix of object files" >&5 echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 if test "${ac_cv_objext+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int |
︙ | ︙ | |||
1918 1919 1920 1921 1922 1923 1924 | ac_objext=$OBJEXT echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 if test "${ac_cv_c_compiler_gnu+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < | > > > > > > > > > > | | | 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 | ac_objext=$OBJEXT echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 if test "${ac_cv_c_compiler_gnu+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_compiler_gnu=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_compiler_gnu=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 GCC=`test $ac_compiler_gnu = yes && echo yes` ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS CFLAGS="-g" echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 if test "${ac_cv_prog_cc_g+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_prog_cc_g=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_prog_cc_g=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then |
︙ | ︙ | |||
2032 2033 2034 2035 2036 2037 2038 | echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 if test "${ac_cv_prog_cc_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_prog_cc_stdc=no ac_save_CC=$CC cat >conftest.$ac_ext <<_ACEOF | < | 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 | echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 if test "${ac_cv_prog_cc_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_prog_cc_stdc=no ac_save_CC=$CC cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <stdarg.h> #include <stdio.h> |
︙ | ︙ | |||
2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 | char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int | > > > > > > > > > > | 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 | char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std1 is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std1. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int |
︙ | ︙ | |||
2086 2087 2088 2089 2090 2091 2092 | # HP-UX older versions -Aa -D_HPUX_SOURCE # SVR4 -Xc -D__EXTENSIONS__ for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | | | 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 | # HP-UX older versions -Aa -D_HPUX_SOURCE # SVR4 -Xc -D__EXTENSIONS__ for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_prog_cc_stdc=$ac_arg break else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext done rm -f conftest.$ac_ext conftest.$ac_objext CC=$ac_save_CC fi case "x$ac_cv_prog_cc_stdc" in |
︙ | ︙ | |||
2131 2132 2133 2134 2135 2136 2137 | cat >conftest.$ac_ext <<_ACEOF #ifndef __cplusplus choke me #endif _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | | < < < > | > > > > > > > > > > | | < | > > > > > > > > > > | | | < | 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 | cat >conftest.$ac_ext <<_ACEOF #ifndef __cplusplus choke me #endif _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then for ac_declaration in \ '' \ 'extern "C" void std::exit (int) throw (); using std::exit;' \ 'extern "C" void std::exit (int); using std::exit;' \ 'extern "C" void exit (int) throw ();' \ 'extern "C" void exit (int);' \ 'void exit (int);' do cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_declaration #include <stdlib.h> int main () { exit (42); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then : else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 continue fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_declaration int main () { exit (42); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then break else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext done rm -f conftest* if test -n "$ac_declaration"; then echo '#ifdef __cplusplus' >>confdefs.h echo $ac_declaration >>confdefs.h echo '#endif' >>confdefs.h fi else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu #-------------------------------------------------------------------- # Supply substitutes for missing POSIX header files. Special notes: # - stdlib.h doesn't define strtol, strtoul, or # strtod insome versions of SunOS # - some versions of string.h don't declare procedures such # as strstr # Do this early, otherwise an autoconf bug throws errors on configure #-------------------------------------------------------------------- ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5 |
︙ | ︙ | |||
2281 2282 2283 2284 2285 2286 2287 | # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since # <limits.h> exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF | < | > < > | 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 | # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since # <limits.h> exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif Syntax error _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then : else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <ac_nonexistent.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then |
︙ | ︙ | |||
2388 2389 2390 2391 2392 2393 2394 | # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since # <limits.h> exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF | < | > < > | 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 | # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since # <limits.h> exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif Syntax error _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then : else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <ac_nonexistent.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then |
︙ | ︙ | |||
2509 2510 2511 2512 2513 2514 2515 | echo "$as_me:$LINENO: checking for ANSI C header files" >&5 echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 if test "${ac_cv_header_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < | 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 | echo "$as_me:$LINENO: checking for ANSI C header files" >&5 echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 if test "${ac_cv_header_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <stdlib.h> #include <stdarg.h> #include <string.h> #include <float.h> int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_header_stdc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_stdc=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <string.h> |
︙ | ︙ | |||
2574 2575 2576 2577 2578 2579 2580 | 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 <<_ACEOF | < | 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 | 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 <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <stdlib.h> |
︙ | ︙ | |||
2599 2600 2601 2602 2603 2604 2605 | 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 <<_ACEOF | < | | | | | 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 | 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 <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <ctype.h> #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #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); } _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 |
︙ | ︙ | |||
2649 2650 2651 2652 2653 2654 2655 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_header_stdc=no fi | | | 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_header_stdc=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi fi echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 echo "${ECHO_T}$ac_cv_header_stdc" >&6 if test $ac_cv_header_stdc = yes; then |
︙ | ︙ | |||
2674 2675 2676 2677 2678 2679 2680 | for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ | | < | > > > > > > > > > > | | > > > > | < | 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 | for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_Header=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_Header=no" fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done echo "$as_me:$LINENO: checking dirent.h" >&5 echo $ECHO_N "checking dirent.h... $ECHO_C" >&6 if test "${tcl_cv_dirent_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/types.h> #include <dirent.h> |
︙ | ︙ | |||
2766 2767 2768 2769 2770 2771 2772 | ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | | | > | > > | | 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 | ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_dirent_h=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_dirent_h=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi if test $tcl_cv_dirent_h = no; then cat >>confdefs.h <<\_ACEOF #define NO_DIRENT_H 1 _ACEOF fi |
︙ | ︙ | |||
2808 2809 2810 2811 2812 2813 2814 | echo "$as_me:$LINENO: result: $ac_cv_header_errno_h" >&5 echo "${ECHO_T}$ac_cv_header_errno_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking errno.h usability" >&5 echo $ECHO_N "checking errno.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | 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 | echo "$as_me:$LINENO: result: $ac_cv_header_errno_h" >&5 echo "${ECHO_T}$ac_cv_header_errno_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking errno.h usability" >&5 echo $ECHO_N "checking errno.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <errno.h> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking errno.h presence" >&5 echo $ECHO_N "checking errno.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <errno.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: errno.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: errno.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: errno.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: errno.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: errno.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: errno.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: errno.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: errno.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for errno.h" >&5 echo $ECHO_N "checking for errno.h... $ECHO_C" >&6 |
︙ | ︙ | |||
2948 2949 2950 2951 2952 2953 2954 | echo "$as_me:$LINENO: result: $ac_cv_header_float_h" >&5 echo "${ECHO_T}$ac_cv_header_float_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking float.h usability" >&5 echo $ECHO_N "checking float.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | 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 | echo "$as_me:$LINENO: result: $ac_cv_header_float_h" >&5 echo "${ECHO_T}$ac_cv_header_float_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking float.h usability" >&5 echo $ECHO_N "checking float.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <float.h> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking float.h presence" >&5 echo $ECHO_N "checking float.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <float.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: float.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: float.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: float.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: float.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: float.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: float.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: float.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: float.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: float.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: float.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: float.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: float.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: float.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: float.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for float.h" >&5 echo $ECHO_N "checking for float.h... $ECHO_C" >&6 |
︙ | ︙ | |||
3088 3089 3090 3091 3092 3093 3094 | echo "$as_me:$LINENO: result: $ac_cv_header_values_h" >&5 echo "${ECHO_T}$ac_cv_header_values_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking values.h usability" >&5 echo $ECHO_N "checking values.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | 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 | echo "$as_me:$LINENO: result: $ac_cv_header_values_h" >&5 echo "${ECHO_T}$ac_cv_header_values_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking values.h usability" >&5 echo $ECHO_N "checking values.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <values.h> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking values.h presence" >&5 echo $ECHO_N "checking values.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <values.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: values.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: values.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: values.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: values.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: values.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: values.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: values.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: values.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: values.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: values.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: values.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: values.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: values.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: values.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for values.h" >&5 echo $ECHO_N "checking for values.h... $ECHO_C" >&6 |
︙ | ︙ | |||
3228 3229 3230 3231 3232 3233 3234 | echo "$as_me:$LINENO: result: $ac_cv_header_limits_h" >&5 echo "${ECHO_T}$ac_cv_header_limits_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking limits.h usability" >&5 echo $ECHO_N "checking limits.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | 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 | echo "$as_me:$LINENO: result: $ac_cv_header_limits_h" >&5 echo "${ECHO_T}$ac_cv_header_limits_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking limits.h usability" >&5 echo $ECHO_N "checking limits.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <limits.h> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking limits.h presence" >&5 echo $ECHO_N "checking limits.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <limits.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: limits.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: limits.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: limits.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: limits.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: limits.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: limits.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: limits.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: limits.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: limits.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: limits.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: limits.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: limits.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: limits.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: limits.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: limits.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: limits.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for limits.h" >&5 echo $ECHO_N "checking for limits.h... $ECHO_C" >&6 |
︙ | ︙ | |||
3372 3373 3374 3375 3376 3377 3378 | echo "$as_me:$LINENO: result: $ac_cv_header_stdlib_h" >&5 echo "${ECHO_T}$ac_cv_header_stdlib_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking stdlib.h usability" >&5 echo $ECHO_N "checking stdlib.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | 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 | echo "$as_me:$LINENO: result: $ac_cv_header_stdlib_h" >&5 echo "${ECHO_T}$ac_cv_header_stdlib_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking stdlib.h usability" >&5 echo $ECHO_N "checking stdlib.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <stdlib.h> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking stdlib.h presence" >&5 echo $ECHO_N "checking stdlib.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <stdlib.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: stdlib.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: stdlib.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: stdlib.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: stdlib.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: stdlib.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: stdlib.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: stdlib.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: stdlib.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for stdlib.h" >&5 echo $ECHO_N "checking for stdlib.h... $ECHO_C" >&6 |
︙ | ︙ | |||
3496 3497 3498 3499 3500 3501 3502 | tcl_ok=1 else tcl_ok=0 fi cat >conftest.$ac_ext <<_ACEOF | < < < | 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 | tcl_ok=1 else tcl_ok=0 fi cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <stdlib.h> _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "strtol" >/dev/null 2>&1; then : else tcl_ok=0 fi rm -f conftest* cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <stdlib.h> _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "strtoul" >/dev/null 2>&1; then : else tcl_ok=0 fi rm -f conftest* cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <stdlib.h> |
︙ | ︙ | |||
3569 3570 3571 3572 3573 3574 3575 | echo "$as_me:$LINENO: result: $ac_cv_header_string_h" >&5 echo "${ECHO_T}$ac_cv_header_string_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking string.h usability" >&5 echo $ECHO_N "checking string.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | 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 | echo "$as_me:$LINENO: result: $ac_cv_header_string_h" >&5 echo "${ECHO_T}$ac_cv_header_string_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking string.h usability" >&5 echo $ECHO_N "checking string.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <string.h> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking string.h presence" >&5 echo $ECHO_N "checking string.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <string.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: string.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: string.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: string.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: string.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: string.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: string.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: string.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: string.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: string.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: string.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: string.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: string.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: string.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: string.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for string.h" >&5 echo $ECHO_N "checking for string.h... $ECHO_C" >&6 |
︙ | ︙ | |||
3693 3694 3695 3696 3697 3698 3699 | tcl_ok=1 else tcl_ok=0 fi cat >conftest.$ac_ext <<_ACEOF | < < | 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 | tcl_ok=1 else tcl_ok=0 fi cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <string.h> _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "strstr" >/dev/null 2>&1; then : else tcl_ok=0 fi rm -f conftest* cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <string.h> |
︙ | ︙ | |||
3753 3754 3755 3756 3757 3758 3759 | echo "$as_me:$LINENO: result: $ac_cv_header_sys_wait_h" >&5 echo "${ECHO_T}$ac_cv_header_sys_wait_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking sys/wait.h usability" >&5 echo $ECHO_N "checking sys/wait.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | 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 | echo "$as_me:$LINENO: result: $ac_cv_header_sys_wait_h" >&5 echo "${ECHO_T}$ac_cv_header_sys_wait_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking sys/wait.h usability" >&5 echo $ECHO_N "checking sys/wait.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <sys/wait.h> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking sys/wait.h presence" >&5 echo $ECHO_N "checking sys/wait.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/wait.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: sys/wait.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: sys/wait.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: sys/wait.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: sys/wait.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: sys/wait.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: sys/wait.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: sys/wait.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: sys/wait.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: sys/wait.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: sys/wait.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: sys/wait.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: sys/wait.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: sys/wait.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for sys/wait.h" >&5 echo $ECHO_N "checking for sys/wait.h... $ECHO_C" >&6 |
︙ | ︙ | |||
3893 3894 3895 3896 3897 3898 3899 | echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5 echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking dlfcn.h usability" >&5 echo $ECHO_N "checking dlfcn.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | 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 | echo "$as_me:$LINENO: result: $ac_cv_header_dlfcn_h" >&5 echo "${ECHO_T}$ac_cv_header_dlfcn_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking dlfcn.h usability" >&5 echo $ECHO_N "checking dlfcn.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <dlfcn.h> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking dlfcn.h presence" >&5 echo $ECHO_N "checking dlfcn.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <dlfcn.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: dlfcn.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: dlfcn.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: dlfcn.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: dlfcn.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: dlfcn.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: dlfcn.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: dlfcn.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: dlfcn.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: dlfcn.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: dlfcn.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: dlfcn.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: dlfcn.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: dlfcn.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for dlfcn.h" >&5 echo $ECHO_N "checking for dlfcn.h... $ECHO_C" >&6 |
︙ | ︙ | |||
4039 4040 4041 4042 4043 4044 4045 | echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | | 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 | echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF |
︙ | ︙ | |||
4202 4203 4204 4205 4206 4207 4208 | # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention cat >>confdefs.h <<\_ACEOF #define USE_THREAD_ALLOC 1 _ACEOF | < < < < < < < | 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 | # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention cat >>confdefs.h <<\_ACEOF #define USE_THREAD_ALLOC 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define _REENTRANT 1 _ACEOF if test "`uname -s`" = "SunOS" ; then |
︙ | ︙ | |||
4234 4235 4236 4237 4238 4239 4240 | echo $ECHO_N "checking for pthread_mutex_init in -lpthread... $ECHO_C" >&6 if test "${ac_cv_lib_pthread_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF | < | 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 | echo $ECHO_N "checking for pthread_mutex_init in -lpthread... $ECHO_C" >&6 if test "${ac_cv_lib_pthread_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
4258 4259 4260 4261 4262 4263 4264 | pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 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 | pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_pthread_pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_pthread_pthread_mutex_init" >&6 if test $ac_cv_lib_pthread_pthread_mutex_init = yes; then tcl_ok=yes else |
︙ | ︙ | |||
4300 4301 4302 4303 4304 4305 4306 | echo $ECHO_N "checking for __pthread_mutex_init in -lpthread... $ECHO_C" >&6 if test "${ac_cv_lib_pthread___pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF | < | 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 | echo $ECHO_N "checking for __pthread_mutex_init in -lpthread... $ECHO_C" >&6 if test "${ac_cv_lib_pthread___pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
4324 4325 4326 4327 4328 4329 4330 | __pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 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 | __pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_pthread___pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread___pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_pthread___pthread_mutex_init" >&6 if test $ac_cv_lib_pthread___pthread_mutex_init = yes; then tcl_ok=yes else |
︙ | ︙ | |||
4366 4367 4368 4369 4370 4371 4372 | echo $ECHO_N "checking for pthread_mutex_init in -lpthreads... $ECHO_C" >&6 if test "${ac_cv_lib_pthreads_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthreads $LIBS" cat >conftest.$ac_ext <<_ACEOF | < | 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 | echo $ECHO_N "checking for pthread_mutex_init in -lpthreads... $ECHO_C" >&6 if test "${ac_cv_lib_pthreads_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthreads $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
4390 4391 4392 4393 4394 4395 4396 | pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 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 | pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_pthreads_pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthreads_pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_pthreads_pthread_mutex_init" >&6 if test $ac_cv_lib_pthreads_pthread_mutex_init = yes; then tcl_ok=yes else |
︙ | ︙ | |||
4430 4431 4432 4433 4434 4435 4436 | echo $ECHO_N "checking for pthread_mutex_init in -lc... $ECHO_C" >&6 if test "${ac_cv_lib_c_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lc $LIBS" cat >conftest.$ac_ext <<_ACEOF | < | 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 | echo $ECHO_N "checking for pthread_mutex_init in -lc... $ECHO_C" >&6 if test "${ac_cv_lib_c_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lc $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
4454 4455 4456 4457 4458 4459 4460 | pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < | 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 | pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_c_pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_c_pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_c_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_c_pthread_mutex_init" >&6 if test $ac_cv_lib_c_pthread_mutex_init = yes; then tcl_ok=yes else tcl_ok=no fi if test "$tcl_ok" = "no"; then echo "$as_me:$LINENO: checking for pthread_mutex_init in -lc_r" >&5 echo $ECHO_N "checking for pthread_mutex_init in -lc_r... $ECHO_C" >&6 if test "${ac_cv_lib_c_r_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lc_r $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
4515 4516 4517 4518 4519 4520 4521 | pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 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 | pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_c_r_pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_c_r_pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_c_r_pthread_mutex_init" >&6 if test $ac_cv_lib_c_r_pthread_mutex_init = yes; then tcl_ok=yes else |
︙ | ︙ | |||
4570 4571 4572 4573 4574 4575 4576 | as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < > > > > > > > > | 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 | as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef $ac_func /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
4615 4616 4617 4618 4619 4620 4621 | return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < > > > > > > > > | 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 | return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_var=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done echo "$as_me:$LINENO: checking for pthread_attr_get_np" >&5 echo $ECHO_N "checking for pthread_attr_get_np... $ECHO_C" >&6 if test "${ac_cv_func_pthread_attr_get_np+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define pthread_attr_get_np to an innocuous variant, in case <limits.h> declares pthread_attr_get_np. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define pthread_attr_get_np innocuous_pthread_attr_get_np /* System header to define __stub macros and hopefully few prototypes, which can conflict with char pthread_attr_get_np (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef pthread_attr_get_np /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
4695 4696 4697 4698 4699 4700 4701 | return f != pthread_attr_get_np; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 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 | return f != pthread_attr_get_np; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_pthread_attr_get_np=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_pthread_attr_get_np=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_pthread_attr_get_np" >&5 echo "${ECHO_T}$ac_cv_func_pthread_attr_get_np" >&6 if test $ac_cv_func_pthread_attr_get_np = yes; then tcl_ok=yes else tcl_ok=no |
︙ | ︙ | |||
4734 4735 4736 4737 4738 4739 4740 | echo "$as_me:$LINENO: checking for pthread_attr_get_np declaration" >&5 echo $ECHO_N "checking for pthread_attr_get_np declaration... $ECHO_C" >&6 if test "${tcl_cv_grep_pthread_attr_get_np+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 | echo "$as_me:$LINENO: checking for pthread_attr_get_np declaration" >&5 echo $ECHO_N "checking for pthread_attr_get_np declaration... $ECHO_C" >&6 if test "${tcl_cv_grep_pthread_attr_get_np+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <pthread.h> |
︙ | ︙ | |||
4769 4770 4771 4772 4773 4774 4775 | else echo "$as_me:$LINENO: checking for pthread_getattr_np" >&5 echo $ECHO_N "checking for pthread_getattr_np... $ECHO_C" >&6 if test "${ac_cv_func_pthread_getattr_np+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < > > > > > > > > | 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 | else echo "$as_me:$LINENO: checking for pthread_getattr_np" >&5 echo $ECHO_N "checking for pthread_getattr_np... $ECHO_C" >&6 if test "${ac_cv_func_pthread_getattr_np+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define pthread_getattr_np to an innocuous variant, in case <limits.h> declares pthread_getattr_np. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define pthread_getattr_np innocuous_pthread_getattr_np /* System header to define __stub macros and hopefully few prototypes, which can conflict with char pthread_getattr_np (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef pthread_getattr_np /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
4814 4815 4816 4817 4818 4819 4820 | return f != pthread_getattr_np; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 | return f != pthread_getattr_np; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_pthread_getattr_np=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_pthread_getattr_np=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_pthread_getattr_np" >&5 echo "${ECHO_T}$ac_cv_func_pthread_getattr_np" >&6 if test $ac_cv_func_pthread_getattr_np = yes; then tcl_ok=yes else tcl_ok=no |
︙ | ︙ | |||
4853 4854 4855 4856 4857 4858 4859 | echo "$as_me:$LINENO: checking for pthread_getattr_np declaration" >&5 echo $ECHO_N "checking for pthread_getattr_np declaration... $ECHO_C" >&6 if test "${tcl_cv_grep_pthread_getattr_np+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 | echo "$as_me:$LINENO: checking for pthread_getattr_np declaration" >&5 echo $ECHO_N "checking for pthread_getattr_np declaration... $ECHO_C" >&6 if test "${tcl_cv_grep_pthread_getattr_np+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <pthread.h> |
︙ | ︙ | |||
4884 4885 4886 4887 4888 4889 4890 | #define GETATTRNP_NOT_DECLARED 1 _ACEOF fi fi fi LIBS=$ac_saved_libs | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 | #define GETATTRNP_NOT_DECLARED 1 _ACEOF fi fi fi LIBS=$ac_saved_libs else TCL_THREADS=0 echo "$as_me:$LINENO: result: no (default)" >&5 echo "${ECHO_T}no (default)" >&6 fi |
︙ | ︙ | |||
5137 5138 5139 5140 5141 5142 5143 | if test -z "$no_pipe"; then if test -n "$GCC"; then echo "$as_me:$LINENO: checking if the compiler understands -pipe" >&5 echo $ECHO_N "checking if the compiler understands -pipe... $ECHO_C" >&6 OLDCC="$CC" CC="$CC -pipe" cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | | 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 | if test -z "$no_pipe"; then if test -n "$GCC"; then echo "$as_me:$LINENO: checking if the compiler understands -pipe" >&5 echo $ECHO_N "checking if the compiler understands -pipe... $ECHO_C" >&6 OLDCC="$CC" CC="$CC -pipe" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CC="$OLDCC" echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi fi #-------------------------------------------------------------------- # Look for libraries that we will need when compiling the Tcl shell #-------------------------------------------------------------------- |
︙ | ︙ | |||
5196 5197 5198 5199 5200 5201 5202 | echo "$as_me:$LINENO: checking for sin" >&5 echo $ECHO_N "checking for sin... $ECHO_C" >&6 if test "${ac_cv_func_sin+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < > > > > > > > > | 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 | echo "$as_me:$LINENO: checking for sin" >&5 echo $ECHO_N "checking for sin... $ECHO_C" >&6 if test "${ac_cv_func_sin+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define sin to an innocuous variant, in case <limits.h> declares sin. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define sin innocuous_sin /* System header to define __stub macros and hopefully few prototypes, which can conflict with char sin (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef sin /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
5241 5242 5243 5244 5245 5246 5247 | return f != sin; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < | > > > > > > > > > > | > | | 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 | return f != sin; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_sin=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_sin=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_sin" >&5 echo "${ECHO_T}$ac_cv_func_sin" >&6 if test $ac_cv_func_sin = yes; then MATH_LIBS="" else MATH_LIBS="-lm" fi echo "$as_me:$LINENO: checking for main in -lieee" >&5 echo $ECHO_N "checking for main in -lieee... $ECHO_C" >&6 if test "${ac_cv_lib_ieee_main+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lieee $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { main (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_ieee_main=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_ieee_main=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_ieee_main" >&5 echo "${ECHO_T}$ac_cv_lib_ieee_main" >&6 if test $ac_cv_lib_ieee_main = yes; then MATH_LIBS="-lieee $MATH_LIBS" fi |
︙ | ︙ | |||
5334 5335 5336 5337 5338 5339 5340 | echo $ECHO_N "checking for main in -linet... $ECHO_C" >&6 if test "${ac_cv_lib_inet_main+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-linet $LIBS" cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | > | | 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 | echo $ECHO_N "checking for main in -linet... $ECHO_C" >&6 if test "${ac_cv_lib_inet_main+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-linet $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { main (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_inet_main=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_inet_main=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_inet_main" >&5 echo "${ECHO_T}$ac_cv_lib_inet_main" >&6 if test $ac_cv_lib_inet_main = yes; then LIBS="$LIBS -linet" fi |
︙ | ︙ | |||
5391 5392 5393 5394 5395 5396 5397 | echo "$as_me:$LINENO: result: $ac_cv_header_net_errno_h" >&5 echo "${ECHO_T}$ac_cv_header_net_errno_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking net/errno.h usability" >&5 echo $ECHO_N "checking net/errno.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 | echo "$as_me:$LINENO: result: $ac_cv_header_net_errno_h" >&5 echo "${ECHO_T}$ac_cv_header_net_errno_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking net/errno.h usability" >&5 echo $ECHO_N "checking net/errno.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <net/errno.h> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking net/errno.h presence" >&5 echo $ECHO_N "checking net/errno.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <net/errno.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: net/errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: net/errno.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: net/errno.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: net/errno.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: net/errno.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: net/errno.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: net/errno.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: net/errno.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: net/errno.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: net/errno.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: net/errno.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: net/errno.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: net/errno.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: net/errno.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for net/errno.h" >&5 echo $ECHO_N "checking for net/errno.h... $ECHO_C" >&6 |
︙ | ︙ | |||
5543 5544 5545 5546 5547 5548 5549 | tcl_checkBoth=0 echo "$as_me:$LINENO: checking for connect" >&5 echo $ECHO_N "checking for connect... $ECHO_C" >&6 if test "${ac_cv_func_connect+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < > > > > > > > > | 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 | tcl_checkBoth=0 echo "$as_me:$LINENO: checking for connect" >&5 echo $ECHO_N "checking for connect... $ECHO_C" >&6 if test "${ac_cv_func_connect+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define connect to an innocuous variant, in case <limits.h> declares connect. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define connect innocuous_connect /* System header to define __stub macros and hopefully few prototypes, which can conflict with char connect (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef connect /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
5588 5589 5590 5591 5592 5593 5594 | return f != connect; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < > > > > > > > > | 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 | return f != connect; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_connect=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_connect=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_connect" >&5 echo "${ECHO_T}$ac_cv_func_connect" >&6 if test $ac_cv_func_connect = yes; then tcl_checkSocket=0 else tcl_checkSocket=1 fi if test "$tcl_checkSocket" = 1; then echo "$as_me:$LINENO: checking for setsockopt" >&5 echo $ECHO_N "checking for setsockopt... $ECHO_C" >&6 if test "${ac_cv_func_setsockopt+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define setsockopt to an innocuous variant, in case <limits.h> declares setsockopt. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define setsockopt innocuous_setsockopt /* System header to define __stub macros and hopefully few prototypes, which can conflict with char setsockopt (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef setsockopt /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
5667 5668 5669 5670 5671 5672 5673 | return f != setsockopt; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < | 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 | return f != setsockopt; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_setsockopt=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_setsockopt=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_setsockopt" >&5 echo "${ECHO_T}$ac_cv_func_setsockopt" >&6 if test $ac_cv_func_setsockopt = yes; then : else echo "$as_me:$LINENO: checking for setsockopt in -lsocket" >&5 echo $ECHO_N "checking for setsockopt in -lsocket... $ECHO_C" >&6 if test "${ac_cv_lib_socket_setsockopt+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsocket $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
5723 5724 5725 5726 5727 5728 5729 | setsockopt (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 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 | setsockopt (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_socket_setsockopt=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_socket_setsockopt=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_socket_setsockopt" >&5 echo "${ECHO_T}$ac_cv_lib_socket_setsockopt" >&6 if test $ac_cv_lib_socket_setsockopt = yes; then LIBS="$LIBS -lsocket" else |
︙ | ︙ | |||
5763 5764 5765 5766 5767 5768 5769 | LIBS="$LIBS -lsocket -lnsl" echo "$as_me:$LINENO: checking for accept" >&5 echo $ECHO_N "checking for accept... $ECHO_C" >&6 if test "${ac_cv_func_accept+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < > > > > > > > > | 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 | LIBS="$LIBS -lsocket -lnsl" echo "$as_me:$LINENO: checking for accept" >&5 echo $ECHO_N "checking for accept... $ECHO_C" >&6 if test "${ac_cv_func_accept+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define accept to an innocuous variant, in case <limits.h> declares accept. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define accept innocuous_accept /* System header to define __stub macros and hopefully few prototypes, which can conflict with char accept (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef accept /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
5808 5809 5810 5811 5812 5813 5814 | return f != accept; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < > > > > > > > > | 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 | return f != accept; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_accept=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_accept=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_accept" >&5 echo "${ECHO_T}$ac_cv_func_accept" >&6 if test $ac_cv_func_accept = yes; then tcl_checkNsl=0 else LIBS=$tk_oldLibs fi fi echo "$as_me:$LINENO: checking for gethostbyname" >&5 echo $ECHO_N "checking for gethostbyname... $ECHO_C" >&6 if test "${ac_cv_func_gethostbyname+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define gethostbyname to an innocuous variant, in case <limits.h> declares gethostbyname. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define gethostbyname innocuous_gethostbyname /* System header to define __stub macros and hopefully few prototypes, which can conflict with char gethostbyname (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef gethostbyname /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
5887 5888 5889 5890 5891 5892 5893 | return f != gethostbyname; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < | 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 | return f != gethostbyname; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_gethostbyname=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_gethostbyname=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_gethostbyname" >&5 echo "${ECHO_T}$ac_cv_func_gethostbyname" >&6 if test $ac_cv_func_gethostbyname = yes; then : else echo "$as_me:$LINENO: checking for gethostbyname in -lnsl" >&5 echo $ECHO_N "checking for gethostbyname in -lnsl... $ECHO_C" >&6 if test "${ac_cv_lib_nsl_gethostbyname+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lnsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
5943 5944 5945 5946 5947 5948 5949 | gethostbyname (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 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 | gethostbyname (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_nsl_gethostbyname=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_nsl_gethostbyname=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_nsl_gethostbyname" >&5 echo "${ECHO_T}$ac_cv_lib_nsl_gethostbyname" >&6 if test $ac_cv_lib_nsl_gethostbyname = yes; then LIBS="$LIBS -lnsl" fi |
︙ | ︙ | |||
6180 6181 6182 6183 6184 6185 6186 | echo $ECHO_N "checking for dlopen in -ldl... $ECHO_C" >&6 if test "${ac_cv_lib_dl_dlopen+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF | < | 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 | echo $ECHO_N "checking for dlopen in -ldl... $ECHO_C" >&6 if test "${ac_cv_lib_dl_dlopen+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
6204 6205 6206 6207 6208 6209 6210 | dlopen (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 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 | dlopen (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_dl_dlopen=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlopen=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlopen" >&5 echo "${ECHO_T}$ac_cv_lib_dl_dlopen" >&6 if test $ac_cv_lib_dl_dlopen = yes; then have_dl=yes else |
︙ | ︙ | |||
6303 6304 6305 6306 6307 6308 6309 6310 | { { echo "$as_me:$LINENO: error: Required archive tool 'ar' not found on PATH." >&5 echo "$as_me: error: Required archive tool 'ar' not found on PATH." >&2;} { (exit 1); exit 1; }; } fi STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" PLAT_OBJS="" case $system in | > | < < | | | | | 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 | { { echo "$as_me:$LINENO: error: Required archive tool 'ar' not found on PATH." >&5 echo "$as_me: error: Required archive tool 'ar' not found on PATH." >&2;} { (exit 1); exit 1; }; } fi STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" PLAT_OBJS="" PLAT_SRCS="" case $system in AIX-*) if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then # AIX requires the _r compiler when gcc isn't being used if test "${CC}" != "cc_r" ; then CC=${CC}_r fi echo "$as_me:$LINENO: result: Using $CC for compiling with threads" >&5 echo "${ECHO_T}Using $CC for compiling with threads" >&6 fi LIBS="$LIBS -lc" SHLIB_CFLAGS="" # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" LD_LIBRARY_PATH_VAR="LIBPATH" # Check to enable 64-bit flags for compiler/linker on AIX 4+ if test "$do64bit" = "yes" -a "`uname -v`" -gt "3" ; then if test "$GCC" = "yes" ; then { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} else do64bit_ok=yes CFLAGS="$CFLAGS -q64" LDFLAGS_ARCH="-q64" RANLIB="${RANLIB} -X64" AR="${AR} -X64" SHLIB_LD_FLAGS="-b64" |
︙ | ︙ | |||
6352 6353 6354 6355 6356 6357 6358 | if test "$GCC" = "yes" ; then CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' else CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' else | > > > | > > | < < < < < < < < < < < < < < < < < < < < < > > > > > | < < > < < < < < < < < < < < | | < < | 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 | if test "$GCC" = "yes" ; then CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' else CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' else if test "$GCC" = "yes" ; then SHLIB_LD="gcc -shared" else SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" fi SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix ${SHLIB_LD} ${SHLIB_LD_FLAGS}" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}.exp' fi # AIX v<=4.1 has some different flags than 4.2+ if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then case $LIBOBJS in "tclLoadAix.$ac_objext" | \ *" tclLoadAix.$ac_objext" | \ "tclLoadAix.$ac_objext "* | \ *" tclLoadAix.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS tclLoadAix.$ac_objext" ;; esac DL_LIBS="-lld" fi # On AIX <=v4 systems, libbsd.a has to be linked in to support # non-blocking file IO. This library has to be linked in after # the MATH_LIBS or it breaks the pow() function. The way to # insure proper sequencing, is to add it to the tail of MATH_LIBS. # This library also supplies gettimeofday. # |
︙ | ︙ | |||
6423 6424 6425 6426 6427 6428 6429 | echo $ECHO_N "checking for gettimeofday in -lbsd... $ECHO_C" >&6 if test "${ac_cv_lib_bsd_gettimeofday+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lbsd $LIBS" cat >conftest.$ac_ext <<_ACEOF | < | 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 | echo $ECHO_N "checking for gettimeofday in -lbsd... $ECHO_C" >&6 if test "${ac_cv_lib_bsd_gettimeofday+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lbsd $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
6447 6448 6449 6450 6451 6452 6453 | gettimeofday (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 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 | gettimeofday (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_bsd_gettimeofday=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_bsd_gettimeofday=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_bsd_gettimeofday" >&5 echo "${ECHO_T}$ac_cv_lib_bsd_gettimeofday" >&6 if test $ac_cv_lib_bsd_gettimeofday = yes; then libbsd=yes else |
︙ | ︙ | |||
6505 6506 6507 6508 6509 6510 6511 | echo $ECHO_N "checking for inet_ntoa in -lbind... $ECHO_C" >&6 if test "${ac_cv_lib_bind_inet_ntoa+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lbind $LIBS" cat >conftest.$ac_ext <<_ACEOF | < | 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 | echo $ECHO_N "checking for inet_ntoa in -lbind... $ECHO_C" >&6 if test "${ac_cv_lib_bind_inet_ntoa+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lbind $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
6529 6530 6531 6532 6533 6534 6535 | inet_ntoa (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 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 | inet_ntoa (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_bind_inet_ntoa=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_bind_inet_ntoa=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_bind_inet_ntoa" >&5 echo "${ECHO_T}$ac_cv_lib_bind_inet_ntoa" >&6 if test $ac_cv_lib_bind_inet_ntoa = yes; then LIBS="$LIBS -lbind -lsocket" fi |
︙ | ︙ | |||
6610 6611 6612 6613 6614 6615 6616 | echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6 if test "${ac_cv_lib_dld_shl_load+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat >conftest.$ac_ext <<_ACEOF | < | 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 | echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6 if test "${ac_cv_lib_dld_shl_load+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
6634 6635 6636 6637 6638 6639 6640 | shl_load (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 | shl_load (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_dld_shl_load=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dld_shl_load=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5 echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6 if test $ac_cv_lib_dld_shl_load = yes; then tcl_ok=yes else |
︙ | ︙ | |||
6676 6677 6678 6679 6680 6681 6682 | CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi if test "$GCC" = "yes" ; then SHLIB_LD="gcc -shared" SHLIB_LD_LIBS='${LIBS}' | | < | | | 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 | CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi if test "$GCC" = "yes" ; then SHLIB_LD="gcc -shared" SHLIB_LD_LIBS='${LIBS}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc #CFLAGS="$CFLAGS +DAportable" # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" ; then if test "$GCC" = "yes" ; then hpux_arch=`gcc -dumpmachine` case $hpux_arch in hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD="gcc -shared" SHLIB_LD_LIBS='${LIBS}' CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on $system\"" >&5 echo "$as_me: WARNING: \"64bit mode not supported with GCC on $system\"" >&2;} ;; esac else |
︙ | ︙ | |||
6718 6719 6720 6721 6722 6723 6724 | echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6 if test "${ac_cv_lib_dld_shl_load+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat >conftest.$ac_ext <<_ACEOF | < | 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 | echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6 if test "${ac_cv_lib_dld_shl_load+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
6742 6743 6744 6745 6746 6747 6748 | shl_load (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 7013 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 7025 7026 7027 7028 7029 7030 7031 7032 | shl_load (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_dld_shl_load=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dld_shl_load=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5 echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6 if test $ac_cv_lib_dld_shl_load = yes; then tcl_ok=yes else |
︙ | ︙ | |||
6782 6783 6784 6785 6786 6787 6788 | DL_LIBS="-ldld" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi ;; | < < < < < < < < < < < < | 7041 7042 7043 7044 7045 7046 7047 7048 7049 7050 7051 7052 7053 7054 | DL_LIBS="-ldld" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi ;; IRIX-5.*) SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" |
︙ | ︙ | |||
6885 6886 6887 6888 6889 6890 6891 | echo "$as_me:$LINENO: result: $ac_cv_header_dld_h" >&5 echo "${ECHO_T}$ac_cv_header_dld_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking dld.h usability" >&5 echo $ECHO_N "checking dld.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 | echo "$as_me:$LINENO: result: $ac_cv_header_dld_h" >&5 echo "${ECHO_T}$ac_cv_header_dld_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking dld.h usability" >&5 echo $ECHO_N "checking dld.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <dld.h> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking dld.h presence" >&5 echo $ECHO_N "checking dld.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <dld.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: dld.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: dld.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: dld.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: dld.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: dld.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: dld.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: dld.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: dld.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for dld.h" >&5 echo $ECHO_N "checking for dld.h... $ECHO_C" >&6 |
︙ | ︙ | |||
7061 7062 7063 7064 7065 7066 7067 | echo "$as_me:$LINENO: result: $ac_cv_header_dld_h" >&5 echo "${ECHO_T}$ac_cv_header_dld_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking dld.h usability" >&5 echo $ECHO_N "checking dld.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 7430 7431 7432 7433 7434 7435 7436 7437 | echo "$as_me:$LINENO: result: $ac_cv_header_dld_h" >&5 echo "${ECHO_T}$ac_cv_header_dld_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking dld.h usability" >&5 echo $ECHO_N "checking dld.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <dld.h> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking dld.h presence" >&5 echo $ECHO_N "checking dld.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <dld.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: dld.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: dld.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: dld.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: dld.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: dld.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: dld.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: dld.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: dld.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: dld.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: dld.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for dld.h" >&5 echo $ECHO_N "checking for dld.h... $ECHO_C" >&6 |
︙ | ︙ | |||
7214 7215 7216 7217 7218 7219 7220 | DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,-Bexport" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; NetBSD-*|FreeBSD-[1-2].*) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 7477 7478 7479 7480 7481 7482 7483 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 7534 7535 7536 7537 7538 7539 7540 7541 7542 7543 7544 7545 7546 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 | DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,-Bexport" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; NetBSD-*|FreeBSD-[1-2].*) # 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="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' echo "$as_me:$LINENO: checking for ELF" >&5 echo $ECHO_N "checking for ELF... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __ELF__ yes #endif _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "yes" >/dev/null 2>&1; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' fi rm -f conftest* # Ancient FreeBSD doesn't handle version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; OpenBSD-*) # OpenBSD/SPARC[64] needs -fPIC, -fpic will not do. case `machine` in sparc|sparc64) SHLIB_CFLAGS="-fPIC";; *) SHLIB_CFLAGS="-fpic";; esac SHLIB_LD="${CC} -shared ${SHLIB_CFLAGS}" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' echo "$as_me:$LINENO: checking for ELF" >&5 echo $ECHO_N "checking for ELF... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __ELF__ yes #endif _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "yes" >/dev/null 2>&1; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 LDFLAGS=-Wl,-export-dynamic else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 LDFLAGS="" fi rm -f conftest* # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.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}' |
︙ | ︙ | |||
7466 7467 7468 7469 7470 7471 7472 | LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" fi case $system in FreeBSD-3.*) # FreeBSD-3 doesn't handle version numbers with dots. | | | | > > > > > > | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 7659 7660 7661 7662 7663 7664 7665 7666 7667 7668 7669 7670 7671 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 7829 7830 7831 7832 7833 7834 7835 7836 7837 7838 7839 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 7881 7882 7883 7884 7885 7886 7887 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 7944 7945 7946 7947 7948 7949 7950 7951 7952 7953 7954 7955 7956 7957 7958 7959 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 8032 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 8053 8054 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 8100 8101 8102 8103 8104 8105 8106 8107 8108 8109 8110 8111 8112 8113 8114 8115 8116 8117 8118 8119 8120 8121 8122 8123 8124 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 | LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" fi case $system in FreeBSD-3.*) # FreeBSD-3 doesn't handle version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' TCL_LIB_VERSIONS_OK=nodots ;; esac ;; Darwin-*) CFLAGS_OPTIMIZE="-Os" SHLIB_CFLAGS="-fno-common" SHLIB_LD="cc -dynamiclib \${LDFLAGS}" echo "$as_me:$LINENO: checking if ld accepts -single_module flag" >&5 echo $ECHO_N "checking if ld accepts -single_module flag... $ECHO_C" >&6 if test "${tcl_cv_ld_single_module+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { int i; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_ld_single_module=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_ld_single_module=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags fi echo "$as_me:$LINENO: result: $tcl_cv_ld_single_module" >&5 echo "${ECHO_T}$tcl_cv_ld_single_module" >&6 if test $tcl_cv_ld_single_module = yes; then SHLIB_LD="${SHLIB_LD} -Wl,-single_module" fi SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".dylib" DL_OBJS="tclLoadDyld.o" DL_LIBS="" LDFLAGS="$LDFLAGS -prebind -headerpad_max_install_names" echo "$as_me:$LINENO: checking if ld accepts -search_paths_first flag" >&5 echo $ECHO_N "checking if ld accepts -search_paths_first flag... $ECHO_C" >&6 if test "${tcl_cv_ld_search_paths_first+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-search_paths_first" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { int i; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_ld_search_paths_first=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_ld_search_paths_first=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags fi echo "$as_me:$LINENO: result: $tcl_cv_ld_search_paths_first" >&5 echo "${ECHO_T}$tcl_cv_ld_search_paths_first" >&6 if test $tcl_cv_ld_search_paths_first = yes; then LDFLAGS="$LDFLAGS -Wl,-search_paths_first" fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" PLAT_OBJS='${MAC_OSX_OBJS}' PLAT_SRCS='${MAC_OSX_SRCS}' echo "$as_me:$LINENO: checking whether to use CoreFoundation" >&5 echo $ECHO_N "checking whether to use CoreFoundation... $ECHO_C" >&6 # Check whether --enable-corefoundation or --disable-corefoundation was given. if test "${enable_corefoundation+set}" = set; then enableval="$enable_corefoundation" tcl_corefoundation=$enableval else tcl_corefoundation=yes fi; echo "$as_me:$LINENO: result: $tcl_corefoundation" >&5 echo "${ECHO_T}$tcl_corefoundation" >&6 if test $tcl_corefoundation = yes; then echo "$as_me:$LINENO: checking for CoreFoundation.framework" >&5 echo $ECHO_N "checking for CoreFoundation.framework... $ECHO_C" >&6 if test "${tcl_cv_lib_corefoundation+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_libs=$LIBS LIBS="$LIBS -framework CoreFoundation" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <CoreFoundation/CoreFoundation.h> int main () { CFBundleRef b = CFBundleGetMainBundle(); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_lib_corefoundation=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_lib_corefoundation=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$hold_libs fi echo "$as_me:$LINENO: result: $tcl_cv_lib_corefoundation" >&5 echo "${ECHO_T}$tcl_cv_lib_corefoundation" >&6 if test $tcl_cv_lib_corefoundation = yes; then LIBS="$LIBS -framework CoreFoundation" cat >>confdefs.h <<\_ACEOF #define HAVE_COREFOUNDATION 1 _ACEOF fi fi for ac_header in libkern/OSAtomic.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` if eval "test \"\${$as_ac_Header+set}\" = set"; then echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in OSSpinLockLock do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef $ac_func /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_$ac_func) || defined (__stub___$ac_func) choke me #else char (*f) () = $ac_func; #endif #ifdef __cplusplus } #endif int main () { return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_var=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done cat >>confdefs.h <<\_ACEOF #define MAC_OSX_TCL 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define USE_VFORK 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define TCL_DEFAULT_ENCODING "utf-8" _ACEOF cat >>confdefs.h <<\_ACEOF #define MODULE_SCOPE __private_extern__ _ACEOF cat >>confdefs.h <<\_ACEOF #define TCL_LOAD_FROM_MEMORY 1 _ACEOF # prior to Darwin 7, realpath is not threadsafe, so don't # use it when threads are enabled, c.f. bug # 711232: echo "$as_me:$LINENO: checking for realpath" >&5 echo $ECHO_N "checking for realpath... $ECHO_C" >&6 if test "${ac_cv_func_realpath+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define realpath to an innocuous variant, in case <limits.h> declares realpath. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define realpath innocuous_realpath /* System header to define __stub macros and hopefully few prototypes, which can conflict with char realpath (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef realpath /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char realpath (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_realpath) || defined (__stub___realpath) choke me #else char (*f) () = realpath; #endif #ifdef __cplusplus } #endif int main () { return f != realpath; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_realpath=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_realpath=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_realpath" >&5 echo "${ECHO_T}$ac_cv_func_realpath" >&6 if test "$ac_cv_func_realpath" = yes -a "${TCL_THREADS}" = 1 \ -a `uname -r | awk -F. '{print $1}'` -lt 7 ; then ac_cv_func_realpath=no fi ;; NEXTSTEP-*) SHLIB_CFLAGS="" SHLIB_LD="cc -nostdlib -r" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadNext.o" |
︙ | ︙ | |||
7600 7601 7602 7603 7604 7605 7606 | SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" # dlopen is in -lc on QNX DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; | < < < < < < < < < < < | 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 | SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" # dlopen is in -lc on QNX DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SCO_SV-3.2*) # Note, dlopen is available only on SCO 3.2.5 and greater. However, # this test works, since "uname -s" was non-standard in 3.2.4 and # below. if test "$GCC" = "yes" ; then SHLIB_CFLAGS="-fPIC -melf" LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" |
︙ | ︙ | |||
7655 7656 7657 7658 7659 7660 7661 | 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 | | | | > | 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 | 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}.so.1.0' UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; SunOS-5.[0-6]) # Careful to not let 5.10+ fall into this case # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. cat >>confdefs.h <<\_ACEOF #define _REENTRANT 1 |
︙ | ︙ | |||
7695 7696 7697 7698 7699 7700 7701 | 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*) | < | 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 | 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 <<\_ACEOF #define _REENTRANT 1 _ACEOF |
︙ | ︙ | |||
7717 7718 7719 7720 7721 7722 7723 | SHLIB_CFLAGS="-KPIC" # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" ; then arch=`isainfo` if test "$arch" = "sparcv9 sparc" ; then if test "$GCC" = "yes" ; then | > | | > > > > > > > > > > | > > > > > | | > > > > > > > > > < < < < < < < < < < < < < < < | > > > > > > > > > > | > | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 | SHLIB_CFLAGS="-KPIC" # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" ; then arch=`isainfo` if test "$arch" = "sparcv9 sparc" ; then if test "$GCC" = "yes" ; then if test "`gcc -dumpversion | awk -F. '{print $1}'`" -lt "3" ; then { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;} else do64bit_ok=yes CFLAGS="$CFLAGS -m64 -mcpu=v9" LDFLAGS="$LDFLAGS -m64 -mcpu=v9" SHLIB_CFLAGS="-fPIC" fi else do64bit_ok=yes if test "$do64bitVIS" = "yes" ; then CFLAGS="$CFLAGS -xarch=v9a" LDFLAGS_ARCH="-xarch=v9a" else CFLAGS="$CFLAGS -xarch=v9" LDFLAGS_ARCH="-xarch=v9" fi fi elif test "$arch" = "amd64 i386" ; then if test "$GCC" = "yes" ; then { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} else do64bit_ok=yes CFLAGS="$CFLAGS -xarch=amd64" LDFLAGS="$LDFLAGS -xarch=amd64" fi else { echo "$as_me:$LINENO: WARNING: 64bit mode not supported for $arch" >&5 echo "$as_me: WARNING: 64bit mode not supported for $arch" >&2;} fi fi # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" if test "$GCC" = "yes" ; then SHLIB_LD="$CC -shared" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} if test "$do64bit_ok" = "yes" ; then # We need to specify -static-libgcc or we need to # add the path to the sparv9 libgcc. SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" # for finding sparcv9 libgcc, get the regular libgcc # path, remove so name and append 'sparcv9' #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" fi else SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' fi ;; 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 "$as_me:$LINENO: checking for ld accepts -Bexport flag" >&5 echo $ECHO_N "checking for ld accepts -Bexport flag... $ECHO_C" >&6 LDFLAGS="$LDFLAGS -Wl,-Bexport" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { int i; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then found=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 LDFLAGS=$hold_ldflags found=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext echo "$as_me:$LINENO: result: $found" >&5 echo "${ECHO_T}$found" >&6 CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; esac if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then { echo "$as_me:$LINENO: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5 echo "$as_me: WARNING: 64bit support being disabled -- don't know magic for this platform" >&2;} fi if test "$do64bit" = "yes" -a "$do64bit_ok" = "yes" ; then cat >>confdefs.h <<\_ACEOF #define TCL_CFG_DO64BIT 1 _ACEOF fi # Step 4: disable dynamic loading if requested via a command-line switch. # Check whether --enable-load or --disable-load was given. if test "${enable_load+set}" = set; then enableval="$enable_load" tcl_ok=$enableval else tcl_ok=yes |
︙ | ︙ | |||
8080 8081 8082 8083 8084 8085 8086 | ;; BSD/OS*) ;; IRIX*) ;; NetBSD-*|FreeBSD-*) ;; | | | | | | 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 8601 8602 | ;; BSD/OS*) ;; IRIX*) ;; NetBSD-*|FreeBSD-*) ;; Darwin-*) ;; RISCos-*) ;; SCO_SV-3.2*) ;; ULTRIX-4.*) ;; *) SHLIB_CFLAGS="-fPIC" ;; esac fi fi if test "$SHARED_LIB_SUFFIX" = "" ; then SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' fi if test "$UNSHARED_LIB_SUFFIX" = "" ; then UNSHARED_LIB_SUFFIX='${VERSION}.a' fi if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then LIB_SUFFIX=${SHARED_LIB_SUFFIX} MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)' else LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} if test "$RANLIB" = "" ; then MAKE_LIB='$(STLIB_LD) $@ ${OBJS}' INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)' |
︙ | ︙ | |||
8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 | 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" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' | > < < > | | < < < | > > > > > > > > > > | < | > > > > > > > > > > | | | < | > > > > > > > > > > | < | > > > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | > > > > > > > > > > | | < | > > > > > > > > > > | | | 8672 8673 8674 8675 8676 8677 8678 8679 8680 8681 8682 8683 8684 8685 8686 8687 8688 8689 8690 8691 8692 8693 8694 8695 8696 8697 8698 8699 8700 8701 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 8715 8716 8717 8718 8719 8720 8721 8722 8723 8724 8725 8726 8727 8728 8729 8730 8731 8732 8733 8734 8735 8736 8737 8738 8739 8740 8741 8742 8743 8744 8745 8746 8747 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 8778 8779 8780 8781 8782 8783 8784 8785 8786 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 8806 8807 8808 8809 8810 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 8825 8826 8827 8828 8829 8830 8831 8832 8833 8834 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 8860 8861 8862 8863 8864 8865 8866 8867 8868 8869 8870 8871 8872 8873 8874 8875 8876 8877 8878 8879 8880 8881 8882 8883 8884 8885 8886 8887 8888 8889 8890 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 8914 8915 8916 8917 8918 8919 8920 8921 8922 8923 8924 8925 8926 8927 8928 8929 8930 8931 8932 8933 8934 8935 8936 8937 8938 8939 8940 8941 8942 8943 8944 8945 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 8977 8978 8979 8980 8981 8982 8983 8984 8985 8986 8987 8988 8989 8990 8991 8992 8993 8994 8995 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 9010 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 9053 9054 9055 9056 9057 9058 9059 9060 9061 9062 9063 9064 9065 9066 9067 9068 9069 9070 9071 9072 9073 9074 9075 9076 9077 9078 9079 9080 9081 9082 9083 9084 9085 9086 9087 9088 9089 9090 9091 9092 9093 9094 9095 9096 9097 9098 9099 9100 9101 9102 9103 9104 9105 9106 9107 9108 9109 9110 9111 9112 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 9123 9124 9125 9126 9127 9128 9129 9130 9131 9132 9133 9134 9135 9136 9137 9138 9139 9140 9141 9142 9143 9144 9145 9146 9147 9148 9149 9150 9151 9152 9153 9154 9155 9156 9157 9158 9159 9160 9161 9162 9163 9164 9165 9166 9167 9168 9169 9170 9171 9172 9173 9174 9175 9176 | 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. DBGX="" if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 cat >>confdefs.h <<\_ACEOF #define TCL_CFG_OPTIMIZED 1 _ACEOF else CFLAGS_DEFAULT='$(CFLAGS_DEBUG)' LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)' if test "$tcl_ok" = "yes"; then echo "$as_me:$LINENO: result: yes (standard debugging)" >&5 echo "${ECHO_T}yes (standard debugging)" >&6 fi fi ### FIXME: Surely TCL_CFG_DEBUG should be set to whether we're debugging? cat >>confdefs.h <<\_ACEOF #define TCL_CFG_DEBUG 1 _ACEOF if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then cat >>confdefs.h <<\_ACEOF #define TCL_MEM_DEBUG 1 _ACEOF fi if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then cat >>confdefs.h <<\_ACEOF #define TCL_COMPILE_DEBUG 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define TCL_COMPILE_STATS 1 _ACEOF fi if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then if test "$tcl_ok" = "all"; then echo "$as_me:$LINENO: result: enabled symbols mem compile debugging" >&5 echo "${ECHO_T}enabled symbols mem compile debugging" >&6 else echo "$as_me:$LINENO: result: enabled $tcl_ok debugging" >&5 echo "${ECHO_T}enabled $tcl_ok debugging" >&6 fi fi #-------------------------------------------------------------------- # Detect what compiler flags to set for 64-bit support. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for required early compiler flags" >&5 echo $ECHO_N "checking for required early compiler flags... $ECHO_C" >&6 tcl_flags="" if test "${tcl_cv_flag__isoc99_source+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <stdlib.h> int main () { char *p = (char *)strtoll; char *q = (char *)strtoull; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__isoc99_source=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define _ISOC99_SOURCE 1 #include <stdlib.h> int main () { char *p = (char *)strtoll; char *q = (char *)strtoull; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__isoc99_source=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_flag__isoc99_source=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__isoc99_source}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define _ISOC99_SOURCE 1 _ACEOF tcl_flags="$tcl_flags _ISOC99_SOURCE" fi if test "${tcl_cv_flag__largefile64_source+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/stat.h> int main () { struct stat64 buf; int i = stat64("/", &buf); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__largefile64_source=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define _LARGEFILE64_SOURCE 1 #include <sys/stat.h> int main () { struct stat64 buf; int i = stat64("/", &buf); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__largefile64_source=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_flag__largefile64_source=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__largefile64_source}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define _LARGEFILE64_SOURCE 1 _ACEOF tcl_flags="$tcl_flags _LARGEFILE64_SOURCE" fi if test "${tcl_cv_flag__largefile_source64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/stat.h> int main () { char *p = (char *)open64; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__largefile_source64=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define _LARGEFILE_SOURCE64 1 #include <sys/stat.h> int main () { char *p = (char *)open64; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__largefile_source64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_flag__largefile_source64=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__largefile_source64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define _LARGEFILE_SOURCE64 1 _ACEOF tcl_flags="$tcl_flags _LARGEFILE_SOURCE64" fi if test "x${tcl_flags}" = "x" ; then echo "$as_me:$LINENO: result: none" >&5 echo "${ECHO_T}none" >&6 else echo "$as_me:$LINENO: result: ${tcl_flags}" >&5 echo "${ECHO_T}${tcl_flags}" >&6 fi echo "$as_me:$LINENO: checking for 64-bit integer type" >&5 echo $ECHO_N "checking for 64-bit integer type... $ECHO_C" >&6 if test "${tcl_cv_type_64bit+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else tcl_cv_type_64bit=none # See if the compiler knows natively about __int64 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { __int64 value = (__int64) 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_type_64bit=__int64 else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_type_64bit="long long" fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext # See if we should use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { switch (0) { case 1: case (sizeof(${tcl_type_64bit})==sizeof(long)): ; } ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_type_64bit=${tcl_type_64bit} else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "${tcl_cv_type_64bit}" = none ; then cat >>confdefs.h <<\_ACEOF #define TCL_WIDE_INT_IS_LONG 1 _ACEOF |
︙ | ︙ | |||
8550 8551 8552 8553 8554 8555 8556 | echo "$as_me:$LINENO: checking for struct dirent64" >&5 echo $ECHO_N "checking for struct dirent64... $ECHO_C" >&6 if test "${tcl_cv_struct_dirent64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < | > > > > > > > > > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > | 9190 9191 9192 9193 9194 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 9206 9207 9208 9209 9210 9211 9212 9213 9214 9215 9216 9217 9218 9219 9220 9221 9222 9223 9224 9225 9226 9227 9228 9229 9230 9231 9232 9233 9234 9235 9236 9237 9238 9239 9240 9241 9242 9243 9244 9245 9246 9247 9248 9249 9250 9251 9252 9253 9254 9255 9256 9257 9258 9259 9260 9261 9262 9263 9264 9265 9266 9267 9268 9269 9270 9271 9272 9273 9274 9275 9276 9277 9278 9279 9280 9281 9282 9283 9284 9285 9286 9287 9288 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 9300 9301 9302 9303 9304 9305 9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 9317 9318 9319 9320 9321 9322 9323 9324 9325 9326 9327 9328 9329 9330 9331 9332 9333 9334 9335 9336 9337 9338 9339 9340 9341 9342 9343 9344 9345 9346 9347 9348 9349 9350 9351 9352 9353 9354 9355 9356 9357 | echo "$as_me:$LINENO: checking for struct dirent64" >&5 echo $ECHO_N "checking for struct dirent64... $ECHO_C" >&6 if test "${tcl_cv_struct_dirent64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/types.h> #include <sys/dirent.h> int main () { struct dirent64 p; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_struct_dirent64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_struct_dirent64=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define HAVE_STRUCT_DIRENT64 1 _ACEOF fi echo "$as_me:$LINENO: result: ${tcl_cv_struct_dirent64}" >&5 echo "${ECHO_T}${tcl_cv_struct_dirent64}" >&6 echo "$as_me:$LINENO: checking for struct stat64" >&5 echo $ECHO_N "checking for struct stat64... $ECHO_C" >&6 if test "${tcl_cv_struct_stat64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/stat.h> int main () { struct stat64 p; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_struct_stat64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_struct_stat64=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_struct_stat64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define HAVE_STRUCT_STAT64 1 _ACEOF fi echo "$as_me:$LINENO: result: ${tcl_cv_struct_stat64}" >&5 echo "${ECHO_T}${tcl_cv_struct_stat64}" >&6 for ac_func in open64 lseek64 do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef $ac_func /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
8754 8755 8756 8757 8758 8759 8760 | return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 9374 9375 9376 9377 9378 9379 9380 9381 9382 9383 9384 9385 9386 9387 9388 9389 9390 9391 9392 9393 9394 9395 9396 9397 9398 9399 9400 9401 9402 9403 9404 9405 9406 9407 9408 9409 9410 9411 9412 9413 9414 9415 9416 9417 9418 9419 9420 9421 9422 9423 9424 9425 9426 9427 9428 9429 9430 9431 9432 9433 9434 9435 9436 9437 9438 9439 9440 9441 9442 9443 9444 9445 9446 9447 9448 9449 9450 9451 9452 9453 9454 9455 9456 9457 9458 9459 9460 9461 9462 9463 9464 9465 9466 9467 9468 9469 9470 9471 9472 9473 9474 9475 9476 9477 9478 9479 9480 | return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_var=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done echo "$as_me:$LINENO: checking for off64_t" >&5 echo $ECHO_N "checking for off64_t... $ECHO_C" >&6 if test "${tcl_cv_type_off64_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/types.h> int main () { off64_t offset; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_type_off64_t=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_type_off64_t=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_type_off64_t}" = "xyes" && \ test "x${ac_cv_func_lseek64}" = "xyes" && \ test "x${ac_cv_func_open64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define HAVE_TYPE_OFF64_T 1 |
︙ | ︙ | |||
8811 8812 8813 8814 8815 8816 8817 | echo "$as_me:$LINENO: checking whether byte ordering is bigendian" >&5 echo $ECHO_N "checking whether byte ordering is bigendian... $ECHO_C" >&6 if test "${ac_cv_c_bigendian+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else # See if sys/param.h defines the BYTE_ORDER macro. cat >conftest.$ac_ext <<_ACEOF | < | 9496 9497 9498 9499 9500 9501 9502 9503 9504 9505 9506 9507 9508 9509 | echo "$as_me:$LINENO: checking whether byte ordering is bigendian" >&5 echo $ECHO_N "checking whether byte ordering is bigendian... $ECHO_C" >&6 if test "${ac_cv_c_bigendian+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else # See if sys/param.h defines the BYTE_ORDER macro. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/types.h> #include <sys/param.h> |
︙ | ︙ | |||
8833 8834 8835 8836 8837 8838 8839 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | < | 9517 9518 9519 9520 9521 9522 9523 9524 9525 9526 9527 9528 9529 9530 9531 9532 9533 9534 9535 9536 9537 9538 9539 9540 9541 9542 9543 9544 9545 9546 9547 9548 9549 9550 9551 9552 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then # It does; now see whether it defined to BIG_ENDIAN or not. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/types.h> #include <sys/param.h> |
︙ | ︙ | |||
8867 8868 8869 8870 8871 8872 8873 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | | < | 9560 9561 9562 9563 9564 9565 9566 9567 9568 9569 9570 9571 9572 9573 9574 9575 9576 9577 9578 9579 9580 9581 9582 9583 9584 9585 9586 9587 9588 9589 9590 9591 9592 9593 9594 9595 9596 9597 9598 9599 9600 9601 9602 9603 9604 9605 9606 9607 9608 9609 9610 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_c_bigendian=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_c_bigendian=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # It does not; compile a test program. if test "$cross_compiling" = yes; then # try to guess the endianness by grepping values into an object file ac_cv_c_bigendian=unknown cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ short ascii_mm[] = { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 }; short ascii_ii[] = { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 }; |
︙ | ︙ | |||
8916 8917 8918 8919 8920 8921 8922 | _ascii (); _ebcdic (); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | | 9618 9619 9620 9621 9622 9623 9624 9625 9626 9627 9628 9629 9630 9631 9632 9633 9634 9635 9636 9637 9638 9639 9640 9641 9642 9643 9644 9645 9646 | _ascii (); _ebcdic (); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then if grep BIGenDianSyS conftest.$ac_objext >/dev/null ; then ac_cv_c_bigendian=yes |
︙ | ︙ | |||
8942 8943 8944 8945 8946 8947 8948 | fi fi else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi | | < | 9654 9655 9656 9657 9658 9659 9660 9661 9662 9663 9664 9665 9666 9667 9668 9669 9670 | fi fi else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () |
︙ | ︙ | |||
8984 8985 8986 8987 8988 8989 8990 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_c_bigendian=yes fi | | | | 9695 9696 9697 9698 9699 9700 9701 9702 9703 9704 9705 9706 9707 9708 9709 9710 9711 9712 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_c_bigendian=yes fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_c_bigendian" >&5 echo "${ECHO_T}$ac_cv_c_bigendian" >&6 case $ac_cv_c_bigendian in yes) cat >>confdefs.h <<\_ACEOF |
︙ | ︙ | |||
9025 9026 9027 9028 9029 9030 9031 | as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < > > > > > > > > | 9736 9737 9738 9739 9740 9741 9742 9743 9744 9745 9746 9747 9748 9749 9750 9751 9752 9753 9754 9755 9756 9757 9758 9759 9760 9761 9762 9763 9764 9765 9766 9767 9768 9769 9770 9771 | as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef $ac_func /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
9070 9071 9072 9073 9074 9075 9076 | return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 9788 9789 9790 9791 9792 9793 9794 9795 9796 9797 9798 9799 9800 9801 9802 9803 9804 9805 9806 9807 9808 9809 9810 9811 9812 9813 9814 9815 9816 9817 9818 9819 9820 9821 9822 9823 9824 9825 9826 9827 9828 9829 9830 | return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_var=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF |
︙ | ︙ | |||
9110 9111 9112 9113 9114 9115 9116 | done # 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 ? | > > > > | < > > > > > > > > | 9839 9840 9841 9842 9843 9844 9845 9846 9847 9848 9849 9850 9851 9852 9853 9854 9855 9856 9857 9858 9859 9860 9861 9862 9863 9864 9865 9866 9867 9868 9869 9870 9871 9872 9873 9874 9875 9876 9877 9878 9879 9880 9881 9882 9883 9884 9885 9886 9887 | done # 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 strtol strtoll strtoull tmpnam waitpid do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef $ac_func /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
9164 9165 9166 9167 9168 9169 9170 | return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | < < | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < > > > > > > > > | 9904 9905 9906 9907 9908 9909 9910 9911 9912 9913 9914 9915 9916 9917 9918 9919 9920 9921 9922 9923 9924 9925 9926 9927 9928 9929 9930 9931 9932 9933 9934 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 9945 9946 9947 9948 9949 9950 9951 9952 9953 9954 9955 9956 9957 9958 9959 9960 9961 9962 9963 9964 9965 9966 9967 9968 9969 9970 9971 9972 9973 9974 9975 9976 9977 9978 9979 9980 9981 9982 9983 9984 9985 9986 9987 9988 9989 9990 9991 9992 9993 9994 9995 | return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_var=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF else case $LIBOBJS in "$ac_func.$ac_objext" | \ *" $ac_func.$ac_objext" | \ "$ac_func.$ac_objext "* | \ *" $ac_func.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS $ac_func.$ac_objext" ;; esac fi done echo "$as_me:$LINENO: checking for strerror" >&5 echo $ECHO_N "checking for strerror... $ECHO_C" >&6 if test "${ac_cv_func_strerror+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define strerror to an innocuous variant, in case <limits.h> declares strerror. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define strerror innocuous_strerror /* System header to define __stub macros and hopefully few prototypes, which can conflict with char strerror (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef strerror /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
9339 9340 9341 9342 9343 9344 9345 | return f != strerror; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < > > > > > > > > | 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 10024 10025 10026 10027 10028 10029 10030 10031 10032 10033 10034 10035 10036 10037 10038 10039 10040 10041 10042 10043 10044 10045 10046 10047 10048 10049 10050 10051 10052 10053 10054 10055 10056 10057 10058 10059 10060 10061 10062 10063 10064 10065 10066 10067 10068 10069 10070 10071 10072 10073 10074 10075 10076 10077 10078 10079 10080 10081 10082 10083 10084 10085 10086 10087 10088 10089 10090 10091 10092 10093 10094 10095 | return f != strerror; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_strerror=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_strerror=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_strerror" >&5 echo "${ECHO_T}$ac_cv_func_strerror" >&6 if test $ac_cv_func_strerror = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_STRERROR 1 _ACEOF fi echo "$as_me:$LINENO: checking for getwd" >&5 echo $ECHO_N "checking for getwd... $ECHO_C" >&6 if test "${ac_cv_func_getwd+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define getwd to an innocuous variant, in case <limits.h> declares getwd. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define getwd innocuous_getwd /* System header to define __stub macros and hopefully few prototypes, which can conflict with char getwd (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef getwd /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
9421 9422 9423 9424 9425 9426 9427 | return f != getwd; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < > > > > > > > > | 10112 10113 10114 10115 10116 10117 10118 10119 10120 10121 10122 10123 10124 10125 10126 10127 10128 10129 10130 10131 10132 10133 10134 10135 10136 10137 10138 10139 10140 10141 10142 10143 10144 10145 10146 10147 10148 10149 10150 10151 10152 10153 10154 10155 10156 10157 10158 10159 10160 10161 10162 10163 10164 10165 10166 10167 10168 10169 10170 10171 10172 10173 10174 10175 10176 10177 10178 10179 10180 10181 10182 10183 10184 10185 10186 10187 10188 10189 10190 10191 10192 10193 10194 10195 | return f != getwd; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_getwd=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_getwd=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_getwd" >&5 echo "${ECHO_T}$ac_cv_func_getwd" >&6 if test $ac_cv_func_getwd = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_GETWD 1 _ACEOF fi echo "$as_me:$LINENO: checking for wait3" >&5 echo $ECHO_N "checking for wait3... $ECHO_C" >&6 if test "${ac_cv_func_wait3+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define wait3 to an innocuous variant, in case <limits.h> declares wait3. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define wait3 innocuous_wait3 /* System header to define __stub macros and hopefully few prototypes, which can conflict with char wait3 (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef wait3 /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
9503 9504 9505 9506 9507 9508 9509 | return f != wait3; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < > > > > > > > > | 10212 10213 10214 10215 10216 10217 10218 10219 10220 10221 10222 10223 10224 10225 10226 10227 10228 10229 10230 10231 10232 10233 10234 10235 10236 10237 10238 10239 10240 10241 10242 10243 10244 10245 10246 10247 10248 10249 10250 10251 10252 10253 10254 10255 10256 10257 10258 10259 10260 10261 10262 10263 10264 10265 10266 10267 10268 10269 10270 10271 10272 10273 10274 10275 10276 10277 10278 10279 10280 10281 10282 10283 10284 10285 10286 10287 10288 10289 10290 10291 10292 10293 10294 10295 | return f != wait3; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_wait3=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_wait3=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_wait3" >&5 echo "${ECHO_T}$ac_cv_func_wait3" >&6 if test $ac_cv_func_wait3 = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_WAIT3 1 _ACEOF fi echo "$as_me:$LINENO: checking for uname" >&5 echo $ECHO_N "checking for uname... $ECHO_C" >&6 if test "${ac_cv_func_uname+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define uname to an innocuous variant, in case <limits.h> declares uname. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define uname innocuous_uname /* System header to define __stub macros and hopefully few prototypes, which can conflict with char uname (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef uname /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
9585 9586 9587 9588 9589 9590 9591 | return f != uname; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < > > > > > > > > | 10312 10313 10314 10315 10316 10317 10318 10319 10320 10321 10322 10323 10324 10325 10326 10327 10328 10329 10330 10331 10332 10333 10334 10335 10336 10337 10338 10339 10340 10341 10342 10343 10344 10345 10346 10347 10348 10349 10350 10351 10352 10353 10354 10355 10356 10357 10358 10359 10360 10361 10362 10363 10364 10365 10366 10367 10368 10369 10370 10371 10372 10373 10374 10375 10376 10377 10378 10379 10380 10381 10382 10383 10384 10385 10386 10387 10388 10389 10390 10391 10392 10393 10394 10395 | return f != uname; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_uname=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_uname=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_uname" >&5 echo "${ECHO_T}$ac_cv_func_uname" >&6 if test $ac_cv_func_uname = yes; then : else cat >>confdefs.h <<\_ACEOF #define NO_UNAME 1 _ACEOF fi echo "$as_me:$LINENO: checking for realpath" >&5 echo $ECHO_N "checking for realpath... $ECHO_C" >&6 if test "${ac_cv_func_realpath+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define realpath to an innocuous variant, in case <limits.h> declares realpath. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define realpath innocuous_realpath /* System header to define __stub macros and hopefully few prototypes, which can conflict with char realpath (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef realpath /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
9667 9668 9669 9670 9671 9672 9673 | return f != realpath; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 10412 10413 10414 10415 10416 10417 10418 10419 10420 10421 10422 10423 10424 10425 10426 10427 10428 10429 10430 10431 10432 10433 10434 10435 10436 10437 10438 10439 10440 10441 10442 10443 10444 10445 10446 10447 10448 10449 10450 10451 10452 10453 10454 | return f != realpath; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_realpath=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_realpath=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_realpath" >&5 echo "${ECHO_T}$ac_cv_func_realpath" >&6 if test $ac_cv_func_realpath = yes; then : else |
︙ | ︙ | |||
9723 9724 9725 9726 9727 9728 9729 | echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | | 10479 10480 10481 10482 10483 10484 10485 10486 10487 10488 10489 10490 10491 10492 10493 10494 10495 10496 10497 10498 10499 10500 10501 10502 10503 10504 10505 10506 10507 10508 10509 10510 10511 10512 10513 10514 10515 10516 10517 10518 10519 10520 10521 10522 10523 10524 10525 10526 10527 10528 10529 10530 10531 10532 10533 10534 10535 10536 10537 10538 10539 10540 10541 10542 10543 10544 10545 10546 10547 10548 10549 10550 10551 10552 10553 10554 10555 10556 10557 10558 10559 10560 10561 10562 10563 10564 10565 10566 10567 10568 10569 10570 10571 10572 10573 10574 10575 10576 10577 10578 10579 10580 10581 10582 10583 10584 10585 10586 10587 10588 10589 10590 10591 10592 10593 10594 10595 10596 10597 10598 10599 10600 10601 10602 10603 10604 10605 10606 10607 10608 10609 10610 10611 | echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF |
︙ | ︙ | |||
9858 9859 9860 9861 9862 9863 9864 | echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then tcl_cv_api_serial=no else cat >conftest.$ac_ext <<_ACEOF | < | 10622 10623 10624 10625 10626 10627 10628 10629 10630 10631 10632 10633 10634 10635 | echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then tcl_cv_api_serial=no else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <termios.h> |
︙ | ︙ | |||
9897 9898 9899 9900 9901 9902 9903 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi | | < | 10660 10661 10662 10663 10664 10665 10666 10667 10668 10669 10670 10671 10672 10673 10674 10675 10676 10677 10678 10679 10680 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext 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 <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <termio.h> |
︙ | ︙ | |||
9942 9943 9944 9945 9946 9947 9948 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi | | < | 10704 10705 10706 10707 10708 10709 10710 10711 10712 10713 10714 10715 10716 10717 10718 10719 10720 10721 10722 10723 10724 10725 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext 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 <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sgtty.h> |
︙ | ︙ | |||
9989 9990 9991 9992 9993 9994 9995 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi | | < | 10750 10751 10752 10753 10754 10755 10756 10757 10758 10759 10760 10761 10762 10763 10764 10765 10766 10767 10768 10769 10770 10771 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext 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 <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <termios.h> |
︙ | ︙ | |||
10038 10039 10040 10041 10042 10043 10044 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi | | < | 10798 10799 10800 10801 10802 10803 10804 10805 10806 10807 10808 10809 10810 10811 10812 10813 10814 10815 10816 10817 10818 10819 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext 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 <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <termio.h> |
︙ | ︙ | |||
10086 10087 10088 10089 10090 10091 10092 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi | | < | 10845 10846 10847 10848 10849 10850 10851 10852 10853 10854 10855 10856 10857 10858 10859 10860 10861 10862 10863 10864 10865 10866 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext 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 <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sgtty.h> |
︙ | ︙ | |||
10135 10136 10137 10138 10139 10140 10141 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=none fi | | | 10893 10894 10895 10896 10897 10898 10899 10900 10901 10902 10903 10904 10905 10906 10907 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_api_serial=none fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi fi case $tcl_cv_api_serial in termios) cat >>confdefs.h <<\_ACEOF |
︙ | ︙ | |||
10177 10178 10179 10180 10181 10182 10183 | echo "$as_me:$LINENO: checking for fd_set in sys/types" >&5 echo $ECHO_N "checking for fd_set in sys/types... $ECHO_C" >&6 if test "${tcl_cv_type_fd_set+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < | 10935 10936 10937 10938 10939 10940 10941 10942 10943 10944 10945 10946 10947 10948 10949 10950 10951 10952 10953 10954 10955 10956 10957 10958 10959 10960 10961 10962 10963 10964 10965 10966 10967 10968 10969 10970 10971 10972 10973 10974 10975 10976 10977 10978 10979 10980 10981 10982 10983 10984 10985 10986 10987 10988 10989 10990 10991 10992 10993 10994 10995 10996 10997 10998 10999 11000 11001 11002 11003 11004 | echo "$as_me:$LINENO: checking for fd_set in sys/types" >&5 echo $ECHO_N "checking for fd_set in sys/types... $ECHO_C" >&6 if test "${tcl_cv_type_fd_set+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/types.h> int main () { fd_set readMask, writeMask; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_type_fd_set=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_type_fd_set=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_type_fd_set" >&5 echo "${ECHO_T}$tcl_cv_type_fd_set" >&6 tk_ok=$tcl_cv_type_fd_set if test $tcl_cv_type_fd_set = no; then echo "$as_me:$LINENO: checking for fd_mask in sys/select" >&5 echo $ECHO_N "checking for fd_mask in sys/select... $ECHO_C" >&6 if test "${tcl_cv_grep_fd_mask+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/select.h> |
︙ | ︙ | |||
10272 10273 10274 10275 10276 10277 10278 | echo "$as_me:$LINENO: checking whether struct tm is in sys/time.h or time.h" >&5 echo $ECHO_N "checking whether struct tm is in sys/time.h or time.h... $ECHO_C" >&6 if test "${ac_cv_struct_tm+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | | 11038 11039 11040 11041 11042 11043 11044 11045 11046 11047 11048 11049 11050 11051 11052 11053 11054 11055 11056 11057 11058 11059 11060 11061 11062 11063 11064 11065 11066 11067 11068 11069 11070 11071 11072 11073 11074 11075 11076 11077 11078 11079 11080 11081 11082 11083 11084 11085 11086 11087 11088 11089 11090 11091 11092 11093 11094 11095 11096 11097 | echo "$as_me:$LINENO: checking whether struct tm is in sys/time.h or time.h" >&5 echo $ECHO_N "checking whether struct tm is in sys/time.h or time.h... $ECHO_C" >&6 if test "${ac_cv_struct_tm+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/types.h> #include <time.h> int main () { struct tm *tp; tp->tm_sec; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_struct_tm=time.h else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_struct_tm=sys/time.h fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_struct_tm" >&5 echo "${ECHO_T}$ac_cv_struct_tm" >&6 if test $ac_cv_struct_tm = sys/time.h; then cat >>confdefs.h <<\_ACEOF #define TM_IN_SYS_TIME 1 |
︙ | ︙ | |||
10338 10339 10340 10341 10342 10343 10344 | echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | < | > > > > > > > > > > | | < | 11113 11114 11115 11116 11117 11118 11119 11120 11121 11122 11123 11124 11125 11126 11127 11128 11129 11130 11131 11132 11133 11134 11135 11136 11137 11138 11139 11140 11141 11142 11143 11144 11145 11146 11147 11148 11149 11150 11151 11152 11153 11154 11155 11156 11157 11158 11159 11160 11161 11162 11163 11164 11165 11166 11167 11168 11169 11170 11171 11172 11173 11174 11175 11176 11177 11178 11179 11180 11181 11182 11183 11184 11185 11186 11187 11188 11189 11190 11191 11192 11193 11194 11195 11196 11197 11198 11199 11200 11201 11202 11203 11204 11205 11206 11207 11208 11209 11210 11211 11212 11213 11214 11215 11216 11217 11218 11219 11220 11221 11222 11223 11224 11225 11226 11227 11228 11229 11230 11231 11232 11233 11234 11235 11236 11237 11238 11239 11240 11241 11242 11243 11244 11245 11246 11247 11248 11249 11250 11251 11252 11253 11254 11255 11256 11257 11258 11259 11260 11261 11262 11263 11264 11265 11266 11267 11268 11269 11270 11271 11272 11273 11274 11275 11276 11277 11278 11279 11280 11281 11282 11283 11284 11285 11286 11287 11288 11289 11290 11291 11292 11293 11294 11295 11296 11297 11298 11299 11300 11301 11302 11303 11304 11305 11306 11307 11308 11309 11310 11311 11312 11313 11314 11315 11316 11317 11318 11319 11320 11321 11322 11323 11324 11325 11326 11327 11328 11329 11330 | echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done echo "$as_me:$LINENO: checking whether time.h and sys/time.h may both be included" >&5 echo $ECHO_N "checking whether time.h and sys/time.h may both be included... $ECHO_C" >&6 if test "${ac_cv_header_time+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/types.h> #include <sys/time.h> #include <time.h> int main () { if ((struct tm *) 0) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_header_time=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_time=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_header_time" >&5 echo "${ECHO_T}$ac_cv_header_time" >&6 if test $ac_cv_header_time = yes; then cat >>confdefs.h <<\_ACEOF #define TIME_WITH_SYS_TIME 1 _ACEOF fi echo "$as_me:$LINENO: checking for struct tm.tm_zone" >&5 echo $ECHO_N "checking for struct tm.tm_zone... $ECHO_C" >&6 if test "${ac_cv_member_struct_tm_tm_zone+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/types.h> #include <$ac_cv_struct_tm> |
︙ | ︙ | |||
10547 10548 10549 10550 10551 10552 10553 | return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | < | 11338 11339 11340 11341 11342 11343 11344 11345 11346 11347 11348 11349 11350 11351 11352 11353 11354 11355 11356 11357 11358 11359 11360 11361 11362 11363 11364 11365 11366 11367 11368 11369 11370 11371 11372 11373 11374 11375 11376 11377 | return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_member_struct_tm_tm_zone=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/types.h> #include <$ac_cv_struct_tm> |
︙ | ︙ | |||
10585 10586 10587 10588 10589 10590 10591 | return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | | | | 11385 11386 11387 11388 11389 11390 11391 11392 11393 11394 11395 11396 11397 11398 11399 11400 11401 11402 11403 11404 11405 11406 11407 11408 11409 11410 11411 11412 11413 11414 11415 11416 11417 11418 11419 11420 11421 11422 11423 11424 11425 11426 11427 11428 | return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_member_struct_tm_tm_zone=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_member_struct_tm_tm_zone=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_member_struct_tm_tm_zone" >&5 echo "${ECHO_T}$ac_cv_member_struct_tm_tm_zone" >&6 if test $ac_cv_member_struct_tm_tm_zone = yes; then cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_TM_TM_ZONE 1 |
︙ | ︙ | |||
10630 10631 10632 10633 10634 10635 10636 | else echo "$as_me:$LINENO: checking for tzname" >&5 echo $ECHO_N "checking for tzname... $ECHO_C" >&6 if test "${ac_cv_var_tzname+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | > | | 11440 11441 11442 11443 11444 11445 11446 11447 11448 11449 11450 11451 11452 11453 11454 11455 11456 11457 11458 11459 11460 11461 11462 11463 11464 11465 11466 11467 11468 11469 11470 11471 11472 11473 11474 11475 11476 11477 11478 11479 11480 11481 11482 11483 11484 11485 11486 11487 11488 11489 11490 11491 11492 11493 11494 11495 11496 11497 11498 11499 11500 11501 11502 | else echo "$as_me:$LINENO: checking for tzname" >&5 echo $ECHO_N "checking for tzname... $ECHO_C" >&6 if test "${ac_cv_var_tzname+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end 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; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_var_tzname=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_var_tzname=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_var_tzname" >&5 echo "${ECHO_T}$ac_cv_var_tzname" >&6 if test $ac_cv_var_tzname = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_TZNAME 1 |
︙ | ︙ | |||
10694 10695 10696 10697 10698 10699 10700 | as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < > > > > > > > > | 11514 11515 11516 11517 11518 11519 11520 11521 11522 11523 11524 11525 11526 11527 11528 11529 11530 11531 11532 11533 11534 11535 11536 11537 11538 11539 11540 11541 11542 11543 11544 11545 11546 11547 11548 11549 | as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef $ac_func /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
10739 10740 10741 10742 10743 10744 10745 | return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < | > > > > > > > > > > | | < | > > > > > > > > > > | | | 11566 11567 11568 11569 11570 11571 11572 11573 11574 11575 11576 11577 11578 11579 11580 11581 11582 11583 11584 11585 11586 11587 11588 11589 11590 11591 11592 11593 11594 11595 11596 11597 11598 11599 11600 11601 11602 11603 11604 11605 11606 11607 11608 11609 11610 11611 11612 11613 11614 11615 11616 11617 11618 11619 11620 11621 11622 11623 11624 11625 11626 11627 11628 11629 11630 11631 11632 11633 11634 11635 11636 11637 11638 11639 11640 11641 11642 11643 11644 11645 11646 11647 11648 11649 11650 11651 11652 11653 11654 11655 11656 11657 11658 11659 11660 11661 11662 11663 11664 11665 11666 11667 11668 11669 11670 11671 11672 11673 11674 11675 11676 11677 11678 11679 11680 11681 11682 11683 11684 11685 11686 11687 11688 11689 11690 11691 11692 11693 11694 11695 11696 11697 11698 11699 11700 11701 11702 11703 11704 11705 11706 11707 11708 11709 11710 11711 11712 11713 11714 11715 11716 11717 11718 11719 11720 11721 11722 11723 11724 11725 11726 11727 11728 11729 11730 11731 11732 | return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_var=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done echo "$as_me:$LINENO: checking tm_tzadj in struct tm" >&5 echo $ECHO_N "checking tm_tzadj in struct tm... $ECHO_C" >&6 if test "${tcl_cv_member_tm_tzadj+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <time.h> int main () { struct tm tm; tm.tm_tzadj; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_member_tm_tzadj=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_member_tm_tzadj=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_member_tm_tzadj" >&5 echo "${ECHO_T}$tcl_cv_member_tm_tzadj" >&6 if test $tcl_cv_member_tm_tzadj = yes ; then cat >>confdefs.h <<\_ACEOF #define HAVE_TM_TZADJ 1 _ACEOF fi echo "$as_me:$LINENO: checking tm_gmtoff in struct tm" >&5 echo $ECHO_N "checking tm_gmtoff in struct tm... $ECHO_C" >&6 if test "${tcl_cv_member_tm_gmtoff+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <time.h> int main () { struct tm tm; tm.tm_gmtoff; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_member_tm_gmtoff=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_member_tm_gmtoff=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_member_tm_gmtoff" >&5 echo "${ECHO_T}$tcl_cv_member_tm_gmtoff" >&6 if test $tcl_cv_member_tm_gmtoff = yes ; then cat >>confdefs.h <<\_ACEOF |
︙ | ︙ | |||
10885 10886 10887 10888 10889 10890 10891 | # echo "$as_me:$LINENO: checking long timezone variable" >&5 echo $ECHO_N "checking long timezone variable... $ECHO_C" >&6 if test "${tcl_cv_var_timezone+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < | > > > > > > > > > > | | | 11741 11742 11743 11744 11745 11746 11747 11748 11749 11750 11751 11752 11753 11754 11755 11756 11757 11758 11759 11760 11761 11762 11763 11764 11765 11766 11767 11768 11769 11770 11771 11772 11773 11774 11775 11776 11777 11778 11779 11780 11781 11782 11783 11784 11785 11786 11787 11788 11789 11790 11791 11792 11793 11794 11795 11796 11797 11798 11799 11800 11801 11802 11803 11804 11805 11806 11807 11808 11809 11810 11811 11812 11813 11814 11815 11816 11817 11818 11819 11820 11821 11822 11823 11824 11825 11826 11827 11828 11829 11830 11831 11832 11833 11834 11835 11836 11837 11838 11839 11840 11841 11842 11843 11844 11845 11846 11847 11848 11849 11850 11851 11852 11853 11854 11855 11856 11857 11858 11859 11860 11861 11862 11863 11864 11865 11866 | # echo "$as_me:$LINENO: checking long timezone variable" >&5 echo $ECHO_N "checking long timezone variable... $ECHO_C" >&6 if test "${tcl_cv_var_timezone+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <time.h> int main () { extern long timezone; timezone += 1; exit (0); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_timezone_long=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_timezone_long=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_timezone_long" >&5 echo "${ECHO_T}$tcl_cv_timezone_long" >&6 if test $tcl_cv_timezone_long = yes ; then cat >>confdefs.h <<\_ACEOF #define HAVE_TIMEZONE_VAR 1 _ACEOF else # # On some systems (eg IRIX 6.2), timezone is a time_t and not a long. # echo "$as_me:$LINENO: checking time_t timezone variable" >&5 echo $ECHO_N "checking time_t timezone variable... $ECHO_C" >&6 if test "${tcl_cv_timezone_time+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <time.h> int main () { extern time_t timezone; timezone += 1; exit (0); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_timezone_time=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_timezone_time=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_timezone_time" >&5 echo "${ECHO_T}$tcl_cv_timezone_time" >&6 if test $tcl_cv_timezone_time = yes ; then cat >>confdefs.h <<\_ACEOF |
︙ | ︙ | |||
11004 11005 11006 11007 11008 11009 11010 | echo "$as_me:$LINENO: checking for struct stat.st_blksize" >&5 echo $ECHO_N "checking for struct stat.st_blksize... $ECHO_C" >&6 if test "${ac_cv_member_struct_stat_st_blksize+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | < | > > > > > > > > > > | | | | 11878 11879 11880 11881 11882 11883 11884 11885 11886 11887 11888 11889 11890 11891 11892 11893 11894 11895 11896 11897 11898 11899 11900 11901 11902 11903 11904 11905 11906 11907 11908 11909 11910 11911 11912 11913 11914 11915 11916 11917 11918 11919 11920 11921 11922 11923 11924 11925 11926 11927 11928 11929 11930 11931 11932 11933 11934 11935 11936 11937 11938 11939 11940 11941 11942 11943 11944 11945 11946 11947 11948 11949 11950 11951 11952 11953 11954 11955 11956 11957 11958 11959 11960 11961 11962 11963 11964 11965 11966 11967 11968 11969 11970 11971 11972 11973 11974 11975 11976 11977 11978 11979 11980 11981 11982 11983 | echo "$as_me:$LINENO: checking for struct stat.st_blksize" >&5 echo $ECHO_N "checking for struct stat.st_blksize... $ECHO_C" >&6 if test "${ac_cv_member_struct_stat_st_blksize+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static struct stat ac_aggr; if (ac_aggr.st_blksize) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_member_struct_stat_st_blksize=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static struct stat ac_aggr; if (sizeof ac_aggr.st_blksize) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_member_struct_stat_st_blksize=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_member_struct_stat_st_blksize=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_member_struct_stat_st_blksize" >&5 echo "${ECHO_T}$ac_cv_member_struct_stat_st_blksize" >&6 if test $ac_cv_member_struct_stat_st_blksize = yes; then cat >>confdefs.h <<_ACEOF #define HAVE_STRUCT_STAT_ST_BLKSIZE 1 |
︙ | ︙ | |||
11101 11102 11103 11104 11105 11106 11107 | echo "$as_me:$LINENO: checking for fstatfs" >&5 echo $ECHO_N "checking for fstatfs... $ECHO_C" >&6 if test "${ac_cv_func_fstatfs+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < > > > > > > > > | 11993 11994 11995 11996 11997 11998 11999 12000 12001 12002 12003 12004 12005 12006 12007 12008 12009 12010 12011 12012 12013 12014 12015 12016 12017 12018 12019 12020 12021 12022 12023 12024 12025 12026 12027 12028 | echo "$as_me:$LINENO: checking for fstatfs" >&5 echo $ECHO_N "checking for fstatfs... $ECHO_C" >&6 if test "${ac_cv_func_fstatfs+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define fstatfs to an innocuous variant, in case <limits.h> declares fstatfs. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define fstatfs innocuous_fstatfs /* System header to define __stub macros and hopefully few prototypes, which can conflict with char fstatfs (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef fstatfs /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
11146 11147 11148 11149 11150 11151 11152 | return f != fstatfs; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 12045 12046 12047 12048 12049 12050 12051 12052 12053 12054 12055 12056 12057 12058 12059 12060 12061 12062 12063 12064 12065 12066 12067 12068 12069 12070 12071 12072 12073 12074 12075 12076 12077 12078 12079 12080 12081 12082 12083 12084 12085 12086 12087 | return f != fstatfs; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_fstatfs=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_fstatfs=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_fstatfs" >&5 echo "${ECHO_T}$ac_cv_func_fstatfs" >&6 if test $ac_cv_func_fstatfs = yes; then : else |
︙ | ︙ | |||
11191 11192 11193 11194 11195 11196 11197 | if test "${ac_cv_func_memcmp_working+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then ac_cv_func_memcmp_working=no else cat >conftest.$ac_ext <<_ACEOF | < | | | | | | | | 12101 12102 12103 12104 12105 12106 12107 12108 12109 12110 12111 12112 12113 12114 12115 12116 12117 12118 12119 12120 12121 12122 12123 12124 12125 12126 12127 12128 12129 12130 12131 12132 12133 12134 12135 12136 12137 12138 12139 12140 12141 12142 12143 12144 | if test "${ac_cv_func_memcmp_working+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then ac_cv_func_memcmp_working=no else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { /* Some versions of memcmp are not 8-bit clean. */ char c0 = 0x40, c1 = 0x80, c2 = 0x81; if (memcmp(&c0, &c2, 1) >= 0 || memcmp(&c1, &c2, 1) >= 0) exit (1); /* The Next x86 OpenStep bug shows up only when comparing 16 bytes or more and with at least one buffer not starting on a 4-byte boundary. William Lewis provided this test program. */ { char foo[21]; char bar[21]; int i; for (i = 0; i < 4; i++) { char *a = foo + i; char *b = bar + i; strcpy (a, "--------01111111"); strcpy (b, "--------10000000"); if (memcmp (a, b, 16) >= 0) exit (1); } exit (0); } ; return 0; } |
︙ | ︙ | |||
11250 11251 11252 11253 11254 11255 11256 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_func_memcmp_working=no fi | | | > > > > > > > < > > > > > > > > | 12159 12160 12161 12162 12163 12164 12165 12166 12167 12168 12169 12170 12171 12172 12173 12174 12175 12176 12177 12178 12179 12180 12181 12182 12183 12184 12185 12186 12187 12188 12189 12190 12191 12192 12193 12194 12195 12196 12197 12198 12199 12200 12201 12202 12203 12204 12205 12206 12207 12208 12209 12210 12211 12212 12213 12214 12215 12216 12217 12218 12219 12220 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_func_memcmp_working=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi echo "$as_me:$LINENO: result: $ac_cv_func_memcmp_working" >&5 echo "${ECHO_T}$ac_cv_func_memcmp_working" >&6 test $ac_cv_func_memcmp_working = no && case $LIBOBJS in "memcmp.$ac_objext" | \ *" memcmp.$ac_objext" | \ "memcmp.$ac_objext "* | \ *" memcmp.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS memcmp.$ac_objext" ;; esac #-------------------------------------------------------------------- # 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 "$as_me:$LINENO: checking for memmove" >&5 echo $ECHO_N "checking for memmove... $ECHO_C" >&6 if test "${ac_cv_func_memmove+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define memmove to an innocuous variant, in case <limits.h> declares memmove. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define memmove innocuous_memmove /* System header to define __stub macros and hopefully few prototypes, which can conflict with char memmove (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef memmove /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
11314 11315 11316 11317 11318 11319 11320 | return f != memmove; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 12237 12238 12239 12240 12241 12242 12243 12244 12245 12246 12247 12248 12249 12250 12251 12252 12253 12254 12255 12256 12257 12258 12259 12260 12261 12262 12263 12264 12265 12266 12267 12268 12269 12270 12271 12272 12273 12274 12275 12276 12277 12278 12279 | return f != memmove; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_memmove=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_memmove=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_memmove" >&5 echo "${ECHO_T}$ac_cv_func_memmove" >&6 if test $ac_cv_func_memmove = yes; then : else |
︙ | ︙ | |||
11357 11358 11359 11360 11361 11362 11363 | #-------------------------------------------------------------------- # On some systems strstr is broken: it returns a pointer even # even if the original string is empty. #-------------------------------------------------------------------- | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | | < | | < < < | | | > | | | > > | < < > > > > > > > > > | > > | | > | < > > > > > > > > | 12291 12292 12293 12294 12295 12296 12297 12298 12299 12300 12301 12302 12303 12304 12305 12306 12307 12308 12309 12310 12311 12312 12313 12314 12315 12316 12317 12318 12319 12320 12321 12322 12323 12324 12325 12326 12327 12328 12329 12330 12331 12332 12333 12334 12335 12336 12337 12338 12339 12340 12341 12342 12343 12344 12345 12346 12347 12348 12349 12350 12351 12352 12353 12354 12355 12356 12357 12358 12359 12360 12361 12362 12363 12364 12365 12366 12367 12368 12369 12370 12371 12372 12373 12374 12375 12376 12377 12378 12379 12380 12381 12382 12383 12384 12385 12386 12387 12388 12389 12390 12391 12392 12393 12394 12395 12396 12397 12398 12399 12400 12401 12402 12403 12404 12405 12406 12407 12408 12409 12410 12411 12412 12413 12414 12415 12416 12417 12418 12419 12420 12421 12422 12423 12424 12425 12426 12427 12428 12429 12430 12431 12432 12433 12434 12435 12436 12437 12438 12439 12440 12441 12442 12443 12444 12445 12446 12447 12448 12449 12450 12451 12452 12453 12454 12455 12456 12457 12458 12459 12460 12461 12462 12463 12464 12465 12466 12467 12468 12469 12470 12471 12472 12473 12474 12475 12476 12477 12478 12479 12480 12481 12482 12483 12484 12485 12486 12487 12488 12489 12490 12491 12492 12493 12494 12495 12496 12497 12498 12499 12500 | #-------------------------------------------------------------------- # On some systems strstr is broken: it returns a pointer even # even if the original string is empty. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for strstr" >&5 echo $ECHO_N "checking for strstr... $ECHO_C" >&6 if test "${ac_cv_func_strstr+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define strstr to an innocuous variant, in case <limits.h> declares strstr. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define strstr innocuous_strstr /* System header to define __stub macros and hopefully few prototypes, which can conflict with char strstr (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef strstr /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char strstr (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_strstr) || defined (__stub___strstr) choke me #else char (*f) () = strstr; #endif #ifdef __cplusplus } #endif int main () { return f != strstr; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_strstr=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_strstr=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_strstr" >&5 echo "${ECHO_T}$ac_cv_func_strstr" >&6 if test $ac_cv_func_strstr = yes; then tcl_ok=1 else tcl_ok=0 fi if test "$tcl_ok" = 1; then echo "$as_me:$LINENO: checking proper strstr implementation" >&5 echo $ECHO_N "checking proper strstr implementation... $ECHO_C" >&6 if test "${tcl_cv_strstr_unbroken+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then tcl_cv_strstr_unbroken=unknown else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main() { extern int strstr(); exit(strstr("\0test", "test") ? 1 : 0); } _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_strstr_unbroken=ok else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_strstr_unbroken=broken fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi echo "$as_me:$LINENO: result: $tcl_cv_strstr_unbroken" >&5 echo "${ECHO_T}$tcl_cv_strstr_unbroken" >&6 if test "$tcl_cv_strstr_unbroken" = "ok"; then tcl_ok=1 else tcl_ok=0 fi fi if test "$tcl_ok" = 0; then case $LIBOBJS in "strstr.$ac_objext" | \ *" strstr.$ac_objext" | \ "strstr.$ac_objext "* | \ *" strstr.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS strstr.$ac_objext" ;; esac USE_COMPAT=1 fi #-------------------------------------------------------------------- # Check for strtoul function. This is tricky because under some # versions of AIX strtoul returns an incorrect terminator # pointer for the string "0". #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for strtoul" >&5 echo $ECHO_N "checking for strtoul... $ECHO_C" >&6 if test "${ac_cv_func_strtoul+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define strtoul to an innocuous variant, in case <limits.h> declares strtoul. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define strtoul innocuous_strtoul /* System header to define __stub macros and hopefully few prototypes, which can conflict with char strtoul (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef strtoul /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
11466 11467 11468 11469 11470 11471 11472 | return f != strtoul; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | > > > > > > | | < | | < < < | < | < < < < < > | | > > > > > > > > > > | > > | > > | > > | | > | < > > > > > > > > | 12517 12518 12519 12520 12521 12522 12523 12524 12525 12526 12527 12528 12529 12530 12531 12532 12533 12534 12535 12536 12537 12538 12539 12540 12541 12542 12543 12544 12545 12546 12547 12548 12549 12550 12551 12552 12553 12554 12555 12556 12557 12558 12559 12560 12561 12562 12563 12564 12565 12566 12567 12568 12569 12570 12571 12572 12573 12574 12575 12576 12577 12578 12579 12580 12581 12582 12583 12584 12585 12586 12587 12588 12589 12590 12591 12592 12593 12594 12595 12596 12597 12598 12599 12600 12601 12602 12603 12604 12605 12606 12607 12608 12609 12610 12611 12612 12613 12614 12615 12616 12617 12618 12619 12620 12621 12622 12623 12624 12625 12626 12627 12628 12629 12630 12631 12632 12633 12634 12635 12636 12637 12638 12639 12640 12641 12642 12643 12644 12645 12646 12647 12648 12649 12650 12651 12652 12653 12654 12655 12656 12657 12658 12659 12660 12661 12662 12663 12664 12665 12666 12667 | return f != strtoul; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_strtoul=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_strtoul=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_strtoul" >&5 echo "${ECHO_T}$ac_cv_func_strtoul" >&6 if test $ac_cv_func_strtoul = yes; then tcl_ok=1 else tcl_ok=0 fi if test "$tcl_ok" = 1; then echo "$as_me:$LINENO: checking proper strtoul implementation" >&5 echo $ECHO_N "checking proper strtoul implementation... $ECHO_C" >&6 if test "${tcl_cv_strtoul_unbroken+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then tcl_cv_strtoul_unbroken=unknown else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main() { extern int strtoul(); char *term, *string = "0"; exit(strtoul(string,&term,0) != 0 || term != string+1); } _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_strtoul_unbroken=ok else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_strtoul_unbroken=broken fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi echo "$as_me:$LINENO: result: $tcl_cv_strtoul_unbroken" >&5 echo "${ECHO_T}$tcl_cv_strtoul_unbroken" >&6 if test "$tcl_cv_strtoul_unbroken" = "ok"; then tcl_ok=1 else tcl_ok=0 fi fi if test "$tcl_ok" = 0; then case $LIBOBJS in "strtoul.$ac_objext" | \ *" strtoul.$ac_objext" | \ "strtoul.$ac_objext "* | \ *" strtoul.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS strtoul.$ac_objext" ;; esac USE_COMPAT=1 fi #-------------------------------------------------------------------- # Check for the strtod function. This is tricky because in some # versions of Linux strtod mis-parses strings starting with "+". #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for strtod" >&5 echo $ECHO_N "checking for strtod... $ECHO_C" >&6 if test "${ac_cv_func_strtod+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define strtod to an innocuous variant, in case <limits.h> declares strtod. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define strtod innocuous_strtod /* System header to define __stub macros and hopefully few prototypes, which can conflict with char strtod (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef strtod /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
11601 11602 11603 11604 11605 11606 11607 | return f != strtod; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | > > > > > > | | < | | < < < | < | < < < < < > | | > > > > > > > > > > | > > | > > | > > | | < > > > > > > > > | 12684 12685 12686 12687 12688 12689 12690 12691 12692 12693 12694 12695 12696 12697 12698 12699 12700 12701 12702 12703 12704 12705 12706 12707 12708 12709 12710 12711 12712 12713 12714 12715 12716 12717 12718 12719 12720 12721 12722 12723 12724 12725 12726 12727 12728 12729 12730 12731 12732 12733 12734 12735 12736 12737 12738 12739 12740 12741 12742 12743 12744 12745 12746 12747 12748 12749 12750 12751 12752 12753 12754 12755 12756 12757 12758 12759 12760 12761 12762 12763 12764 12765 12766 12767 12768 12769 12770 12771 12772 12773 12774 12775 12776 12777 12778 12779 12780 12781 12782 12783 12784 12785 12786 12787 12788 12789 12790 12791 12792 12793 12794 12795 12796 12797 12798 12799 12800 12801 12802 12803 12804 12805 12806 12807 12808 12809 12810 12811 12812 12813 12814 12815 12816 12817 12818 12819 12820 12821 12822 12823 12824 12825 12826 12827 12828 12829 12830 12831 12832 12833 12834 12835 12836 | return f != strtod; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_strtod=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_strtod=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_strtod" >&5 echo "${ECHO_T}$ac_cv_func_strtod" >&6 if test $ac_cv_func_strtod = yes; then tcl_ok=1 else tcl_ok=0 fi if test "$tcl_ok" = 1; then echo "$as_me:$LINENO: checking proper strtod implementation" >&5 echo $ECHO_N "checking proper strtod implementation... $ECHO_C" >&6 if test "${tcl_cv_strtod_unbroken+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then tcl_cv_strtod_unbroken=unknown else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main() { extern double strtod(); char *term, *string = " +69"; exit(strtod(string,&term) != 69 || term != string+4); } _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_strtod_unbroken=ok else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_strtod_unbroken=broken fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi echo "$as_me:$LINENO: result: $tcl_cv_strtod_unbroken" >&5 echo "${ECHO_T}$tcl_cv_strtod_unbroken" >&6 if test "$tcl_cv_strtod_unbroken" = "ok"; then tcl_ok=1 else tcl_ok=0 fi fi if test "$tcl_ok" = 0; then case $LIBOBJS in "strtod.$ac_objext" | \ *" strtod.$ac_objext" | \ "strtod.$ac_objext "* | \ *" strtod.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS strtod.$ac_objext" ;; esac USE_COMPAT=1 fi #-------------------------------------------------------------------- # Under Solaris 2.4, strtod returns the wrong value for the # terminating character under some conditions. Check for this # and if the problem exists use a substitute procedure # "fixstrtod" that corrects the error. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for strtod" >&5 echo $ECHO_N "checking for strtod... $ECHO_C" >&6 if test "${ac_cv_func_strtod+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define strtod to an innocuous variant, in case <limits.h> declares strtod. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define strtod innocuous_strtod /* System header to define __stub macros and hopefully few prototypes, which can conflict with char strtod (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef strtod /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
11739 11740 11741 11742 11743 11744 11745 | return f != strtod; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < | 12853 12854 12855 12856 12857 12858 12859 12860 12861 12862 12863 12864 12865 12866 12867 12868 12869 12870 12871 12872 12873 12874 12875 12876 12877 12878 12879 12880 12881 12882 12883 12884 12885 12886 12887 12888 12889 12890 12891 12892 12893 12894 12895 12896 12897 12898 12899 12900 12901 12902 12903 12904 12905 12906 12907 12908 12909 12910 12911 12912 12913 12914 12915 | return f != strtod; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_strtod=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_strtod=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_strtod" >&5 echo "${ECHO_T}$ac_cv_func_strtod" >&6 if test $ac_cv_func_strtod = yes; then tcl_strtod=1 else tcl_strtod=0 fi if test "$tcl_strtod" = 1; then echo "$as_me:$LINENO: checking for Solaris2.4/Tru64 strtod bugs" >&5 echo $ECHO_N "checking for Solaris2.4/Tru64 strtod bugs... $ECHO_C" >&6 if test "${tcl_cv_strtod_buggy+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then tcl_cv_strtod_buggy=0 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ extern double strtod(); |
︙ | ︙ | |||
11824 11825 11826 11827 11828 11829 11830 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_strtod_buggy=0 fi | | > > > > > | > > | 12948 12949 12950 12951 12952 12953 12954 12955 12956 12957 12958 12959 12960 12961 12962 12963 12964 12965 12966 12967 12968 12969 12970 12971 12972 12973 12974 12975 12976 12977 12978 12979 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_strtod_buggy=0 fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi if test "$tcl_cv_strtod_buggy" = 1; then echo "$as_me:$LINENO: result: ok" >&5 echo "${ECHO_T}ok" >&6 else echo "$as_me:$LINENO: result: buggy" >&5 echo "${ECHO_T}buggy" >&6 case $LIBOBJS in "fixstrtod.$ac_objext" | \ *" fixstrtod.$ac_objext" | \ "fixstrtod.$ac_objext "* | \ *" fixstrtod.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS fixstrtod.$ac_objext" ;; esac USE_COMPAT=1 cat >>confdefs.h <<\_ACEOF #define strtod fixstrtod _ACEOF fi |
︙ | ︙ | |||
11856 11857 11858 11859 11860 11861 11862 | echo "$as_me:$LINENO: checking for mode_t" >&5 echo $ECHO_N "checking for mode_t... $ECHO_C" >&6 if test "${ac_cv_type_mode_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < | > > > > > > > > > > | | < | > > > > > > > > > > | | < | 12987 12988 12989 12990 12991 12992 12993 12994 12995 12996 12997 12998 12999 13000 13001 13002 13003 13004 13005 13006 13007 13008 13009 13010 13011 13012 13013 13014 13015 13016 13017 13018 13019 13020 13021 13022 13023 13024 13025 13026 13027 13028 13029 13030 13031 13032 13033 13034 13035 13036 13037 13038 13039 13040 13041 13042 13043 13044 13045 13046 13047 13048 13049 13050 13051 13052 13053 13054 13055 13056 13057 13058 13059 13060 13061 13062 13063 13064 13065 13066 13067 13068 13069 13070 13071 13072 13073 13074 13075 13076 13077 13078 13079 13080 13081 13082 13083 13084 13085 13086 13087 13088 13089 13090 13091 13092 13093 13094 13095 13096 13097 13098 13099 13100 13101 13102 13103 13104 13105 13106 13107 13108 13109 13110 13111 13112 13113 13114 13115 13116 13117 13118 13119 13120 13121 13122 13123 13124 13125 13126 13127 13128 13129 13130 13131 13132 13133 13134 13135 13136 13137 13138 13139 13140 13141 13142 13143 13144 13145 13146 13147 13148 13149 13150 13151 13152 13153 13154 13155 13156 13157 13158 13159 13160 13161 13162 13163 13164 13165 13166 13167 13168 13169 13170 13171 13172 13173 13174 13175 13176 13177 13178 13179 13180 13181 13182 13183 13184 13185 13186 13187 13188 13189 13190 13191 13192 13193 13194 13195 13196 13197 13198 | echo "$as_me:$LINENO: checking for mode_t" >&5 echo $ECHO_N "checking for mode_t... $ECHO_C" >&6 if test "${ac_cv_type_mode_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if ((mode_t *) 0) return 0; if (sizeof (mode_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_type_mode_t=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_mode_t=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_mode_t" >&5 echo "${ECHO_T}$ac_cv_type_mode_t" >&6 if test $ac_cv_type_mode_t = yes; then : else cat >>confdefs.h <<_ACEOF #define mode_t int _ACEOF fi echo "$as_me:$LINENO: checking for pid_t" >&5 echo $ECHO_N "checking for pid_t... $ECHO_C" >&6 if test "${ac_cv_type_pid_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if ((pid_t *) 0) return 0; if (sizeof (pid_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_type_pid_t=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_pid_t=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_pid_t" >&5 echo "${ECHO_T}$ac_cv_type_pid_t" >&6 if test $ac_cv_type_pid_t = yes; then : else cat >>confdefs.h <<_ACEOF #define pid_t int _ACEOF fi echo "$as_me:$LINENO: checking for size_t" >&5 echo $ECHO_N "checking for size_t... $ECHO_C" >&6 if test "${ac_cv_type_size_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if ((size_t *) 0) return 0; if (sizeof (size_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_type_size_t=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_size_t=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_size_t" >&5 echo "${ECHO_T}$ac_cv_type_size_t" >&6 if test $ac_cv_type_size_t = yes; then : else cat >>confdefs.h <<_ACEOF #define size_t unsigned _ACEOF fi echo "$as_me:$LINENO: checking for uid_t in sys/types.h" >&5 echo $ECHO_N "checking for uid_t in sys/types.h... $ECHO_C" >&6 if test "${ac_cv_type_uid_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/types.h> |
︙ | ︙ | |||
12067 12068 12069 12070 12071 12072 12073 | echo "$as_me:$LINENO: checking for socklen_t" >&5 echo $ECHO_N "checking for socklen_t... $ECHO_C" >&6 if test "${ac_cv_type_socklen_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | 13224 13225 13226 13227 13228 13229 13230 13231 13232 13233 13234 13235 13236 13237 | echo "$as_me:$LINENO: checking for socklen_t" >&5 echo $ECHO_N "checking for socklen_t... $ECHO_C" >&6 if test "${ac_cv_type_socklen_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/types.h> |
︙ | ︙ | |||
12115 12116 12117 12118 12119 12120 12121 | echo "$as_me:$LINENO: checking for opendir" >&5 echo $ECHO_N "checking for opendir... $ECHO_C" >&6 if test "${ac_cv_func_opendir+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < > > > > > > > > | 13271 13272 13273 13274 13275 13276 13277 13278 13279 13280 13281 13282 13283 13284 13285 13286 13287 13288 13289 13290 13291 13292 13293 13294 13295 13296 13297 13298 13299 13300 13301 13302 13303 13304 13305 13306 | echo "$as_me:$LINENO: checking for opendir" >&5 echo $ECHO_N "checking for opendir... $ECHO_C" >&6 if test "${ac_cv_func_opendir+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define opendir to an innocuous variant, in case <limits.h> declares opendir. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define opendir innocuous_opendir /* System header to define __stub macros and hopefully few prototypes, which can conflict with char opendir (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef opendir /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
12160 12161 12162 12163 12164 12165 12166 | return f != opendir; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 13323 13324 13325 13326 13327 13328 13329 13330 13331 13332 13333 13334 13335 13336 13337 13338 13339 13340 13341 13342 13343 13344 13345 13346 13347 13348 13349 13350 13351 13352 13353 13354 13355 13356 13357 13358 13359 13360 13361 13362 13363 13364 13365 | return f != opendir; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_opendir=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_opendir=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_opendir" >&5 echo "${ECHO_T}$ac_cv_func_opendir" >&6 if test $ac_cv_func_opendir = yes; then : else |
︙ | ︙ | |||
12206 12207 12208 12209 12210 12211 12212 | echo "$as_me:$LINENO: checking union wait" >&5 echo $ECHO_N "checking union wait... $ECHO_C" >&6 if test "${tcl_cv_union_wait+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | 13380 13381 13382 13383 13384 13385 13386 13387 13388 13389 13390 13391 13392 13393 | echo "$as_me:$LINENO: checking union wait" >&5 echo $ECHO_N "checking union wait... $ECHO_C" >&6 if test "${tcl_cv_union_wait+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/types.h> #include <sys/wait.h> |
︙ | ︙ | |||
12228 12229 12230 12231 12232 12233 12234 | ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 13401 13402 13403 13404 13405 13406 13407 13408 13409 13410 13411 13412 13413 13414 13415 13416 13417 13418 13419 13420 13421 13422 13423 13424 13425 13426 13427 13428 13429 13430 13431 13432 13433 13434 13435 13436 13437 13438 13439 13440 13441 13442 13443 | ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_union_wait=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_union_wait=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_union_wait" >&5 echo "${ECHO_T}$tcl_cv_union_wait" >&6 if test $tcl_cv_union_wait = no; then cat >>confdefs.h <<\_ACEOF |
︙ | ︙ | |||
12270 12271 12272 12273 12274 12275 12276 | echo "$as_me:$LINENO: checking for strncasecmp" >&5 echo $ECHO_N "checking for strncasecmp... $ECHO_C" >&6 if test "${ac_cv_func_strncasecmp+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < > > > > > > > > | 13454 13455 13456 13457 13458 13459 13460 13461 13462 13463 13464 13465 13466 13467 13468 13469 13470 13471 13472 13473 13474 13475 13476 13477 13478 13479 13480 13481 13482 13483 13484 13485 13486 13487 13488 13489 | echo "$as_me:$LINENO: checking for strncasecmp" >&5 echo $ECHO_N "checking for strncasecmp... $ECHO_C" >&6 if test "${ac_cv_func_strncasecmp+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define strncasecmp to an innocuous variant, in case <limits.h> declares strncasecmp. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define strncasecmp innocuous_strncasecmp /* System header to define __stub macros and hopefully few prototypes, which can conflict with char strncasecmp (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef strncasecmp /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
12315 12316 12317 12318 12319 12320 12321 | return f != strncasecmp; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < | 13506 13507 13508 13509 13510 13511 13512 13513 13514 13515 13516 13517 13518 13519 13520 13521 13522 13523 13524 13525 13526 13527 13528 13529 13530 13531 13532 13533 13534 13535 13536 13537 13538 13539 13540 13541 13542 13543 13544 13545 13546 13547 13548 13549 13550 13551 13552 13553 13554 13555 13556 13557 13558 13559 13560 13561 13562 13563 13564 13565 13566 | return f != strncasecmp; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_strncasecmp=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_strncasecmp=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_strncasecmp" >&5 echo "${ECHO_T}$ac_cv_func_strncasecmp" >&6 if test $ac_cv_func_strncasecmp = yes; then tcl_ok=1 else tcl_ok=0 fi if test "$tcl_ok" = 0; then echo "$as_me:$LINENO: checking for strncasecmp in -lsocket" >&5 echo $ECHO_N "checking for strncasecmp in -lsocket... $ECHO_C" >&6 if test "${ac_cv_lib_socket_strncasecmp+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsocket $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
12375 12376 12377 12378 12379 12380 12381 | strncasecmp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < | 13576 13577 13578 13579 13580 13581 13582 13583 13584 13585 13586 13587 13588 13589 13590 13591 13592 13593 13594 13595 13596 13597 13598 13599 13600 13601 13602 13603 13604 13605 13606 13607 13608 13609 13610 13611 13612 13613 13614 13615 13616 13617 13618 13619 13620 13621 13622 13623 13624 13625 13626 13627 13628 13629 13630 13631 13632 13633 13634 13635 13636 13637 13638 | strncasecmp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_socket_strncasecmp=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_socket_strncasecmp=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_socket_strncasecmp" >&5 echo "${ECHO_T}$ac_cv_lib_socket_strncasecmp" >&6 if test $ac_cv_lib_socket_strncasecmp = yes; then tcl_ok=1 else tcl_ok=0 fi fi if test "$tcl_ok" = 0; then echo "$as_me:$LINENO: checking for strncasecmp in -linet" >&5 echo $ECHO_N "checking for strncasecmp in -linet... $ECHO_C" >&6 if test "${ac_cv_lib_inet_strncasecmp+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-linet $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ |
︙ | ︙ | |||
12437 12438 12439 12440 12441 12442 12443 | strncasecmp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | > > > > > | > > < > > > > > > > > | 13648 13649 13650 13651 13652 13653 13654 13655 13656 13657 13658 13659 13660 13661 13662 13663 13664 13665 13666 13667 13668 13669 13670 13671 13672 13673 13674 13675 13676 13677 13678 13679 13680 13681 13682 13683 13684 13685 13686 13687 13688 13689 13690 13691 13692 13693 13694 13695 13696 13697 13698 13699 13700 13701 13702 13703 13704 13705 13706 13707 13708 13709 13710 13711 13712 13713 13714 13715 13716 13717 13718 13719 13720 13721 13722 13723 13724 13725 13726 13727 13728 13729 13730 13731 13732 13733 13734 13735 13736 13737 13738 13739 13740 13741 13742 13743 13744 13745 13746 13747 13748 13749 13750 13751 13752 | strncasecmp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_inet_strncasecmp=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_inet_strncasecmp=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_inet_strncasecmp" >&5 echo "${ECHO_T}$ac_cv_lib_inet_strncasecmp" >&6 if test $ac_cv_lib_inet_strncasecmp = yes; then tcl_ok=1 else tcl_ok=0 fi fi if test "$tcl_ok" = 0; then case $LIBOBJS in "strncasecmp.$ac_objext" | \ *" strncasecmp.$ac_objext" | \ "strncasecmp.$ac_objext "* | \ *" strncasecmp.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS strncasecmp.$ac_objext" ;; esac USE_COMPAT=1 fi #-------------------------------------------------------------------- # The code below deals with several issues related to gettimeofday: # 1. Some systems don't provide a gettimeofday function at all # (set NO_GETTOD if this is the case). # 2. SGI systems don't use the BSD form of the gettimeofday function, # 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 "$as_me:$LINENO: checking for BSDgettimeofday" >&5 echo $ECHO_N "checking for BSDgettimeofday... $ECHO_C" >&6 if test "${ac_cv_func_BSDgettimeofday+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define BSDgettimeofday to an innocuous variant, in case <limits.h> declares BSDgettimeofday. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define BSDgettimeofday innocuous_BSDgettimeofday /* System header to define __stub macros and hopefully few prototypes, which can conflict with char BSDgettimeofday (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef BSDgettimeofday /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
12533 12534 12535 12536 12537 12538 12539 | return f != BSDgettimeofday; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | < > > > > > > > > | 13769 13770 13771 13772 13773 13774 13775 13776 13777 13778 13779 13780 13781 13782 13783 13784 13785 13786 13787 13788 13789 13790 13791 13792 13793 13794 13795 13796 13797 13798 13799 13800 13801 13802 13803 13804 13805 13806 13807 13808 13809 13810 13811 13812 13813 13814 13815 13816 13817 13818 13819 13820 13821 13822 13823 13824 13825 13826 13827 13828 13829 13830 13831 13832 13833 13834 13835 13836 13837 13838 13839 13840 13841 13842 13843 13844 13845 13846 13847 13848 13849 13850 | return f != BSDgettimeofday; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_BSDgettimeofday=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_BSDgettimeofday=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_BSDgettimeofday" >&5 echo "${ECHO_T}$ac_cv_func_BSDgettimeofday" >&6 if test $ac_cv_func_BSDgettimeofday = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_BSDGETTIMEOFDAY 1 _ACEOF else echo "$as_me:$LINENO: checking for gettimeofday" >&5 echo $ECHO_N "checking for gettimeofday... $ECHO_C" >&6 if test "${ac_cv_func_gettimeofday+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define gettimeofday to an innocuous variant, in case <limits.h> declares gettimeofday. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define gettimeofday innocuous_gettimeofday /* System header to define __stub macros and hopefully few prototypes, which can conflict with char gettimeofday (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef gettimeofday /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
12613 12614 12615 12616 12617 12618 12619 | return f != gettimeofday; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | > | | 13867 13868 13869 13870 13871 13872 13873 13874 13875 13876 13877 13878 13879 13880 13881 13882 13883 13884 13885 13886 13887 13888 13889 13890 13891 13892 13893 13894 13895 13896 13897 13898 13899 13900 13901 13902 13903 13904 13905 13906 13907 13908 13909 | return f != gettimeofday; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_gettimeofday=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_gettimeofday=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_gettimeofday" >&5 echo "${ECHO_T}$ac_cv_func_gettimeofday" >&6 if test $ac_cv_func_gettimeofday = yes; then : else |
︙ | ︙ | |||
12653 12654 12655 12656 12657 12658 12659 | echo "$as_me:$LINENO: checking for gettimeofday declaration" >&5 echo $ECHO_N "checking for gettimeofday declaration... $ECHO_C" >&6 if test "${tcl_cv_grep_gettimeofday+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | 13918 13919 13920 13921 13922 13923 13924 13925 13926 13927 13928 13929 13930 13931 | echo "$as_me:$LINENO: checking for gettimeofday declaration" >&5 echo $ECHO_N "checking for gettimeofday declaration... $ECHO_C" >&6 if test "${tcl_cv_grep_gettimeofday+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <sys/time.h> |
︙ | ︙ | |||
12695 12696 12697 12698 12699 12700 12701 | echo "$as_me:$LINENO: checking whether char is unsigned" >&5 echo $ECHO_N "checking whether char is unsigned... $ECHO_C" >&6 if test "${ac_cv_c_char_unsigned+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < | > > > > > > > > > > | | | 13959 13960 13961 13962 13963 13964 13965 13966 13967 13968 13969 13970 13971 13972 13973 13974 13975 13976 13977 13978 13979 13980 13981 13982 13983 13984 13985 13986 13987 13988 13989 13990 13991 13992 13993 13994 13995 13996 13997 13998 13999 14000 14001 14002 14003 14004 14005 14006 14007 14008 14009 14010 14011 14012 14013 14014 14015 14016 14017 14018 14019 14020 14021 14022 14023 14024 14025 14026 14027 14028 14029 14030 14031 14032 14033 14034 14035 14036 14037 14038 14039 14040 14041 14042 14043 14044 14045 14046 14047 14048 14049 14050 14051 14052 14053 14054 14055 14056 14057 14058 14059 14060 14061 14062 14063 14064 14065 14066 14067 14068 14069 14070 14071 14072 14073 14074 14075 14076 14077 14078 14079 14080 14081 | echo "$as_me:$LINENO: checking whether char is unsigned" >&5 echo $ECHO_N "checking whether char is unsigned... $ECHO_C" >&6 if test "${ac_cv_c_char_unsigned+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(((char) -1) < 0)]; test_array [0] = 0 ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_c_char_unsigned=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_c_char_unsigned=yes fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_c_char_unsigned" >&5 echo "${ECHO_T}$ac_cv_c_char_unsigned" >&6 if test $ac_cv_c_char_unsigned = yes && test "$GCC" != yes; then cat >>confdefs.h <<\_ACEOF #define __CHAR_UNSIGNED__ 1 _ACEOF fi echo "$as_me:$LINENO: checking signed char declarations" >&5 echo $ECHO_N "checking signed char declarations... $ECHO_C" >&6 if test "${tcl_cv_char_signed+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { signed char *p; p = 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_char_signed=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_char_signed=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_char_signed" >&5 echo "${ECHO_T}$tcl_cv_char_signed" >&6 if test $tcl_cv_char_signed = yes; then cat >>confdefs.h <<\_ACEOF |
︙ | ︙ | |||
12811 12812 12813 12814 12815 12816 12817 | if test "${tcl_cv_putenv_copy+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then tcl_cv_putenv_copy=no else cat >conftest.$ac_ext <<_ACEOF | < | 14093 14094 14095 14096 14097 14098 14099 14100 14101 14102 14103 14104 14105 14106 | if test "${tcl_cv_putenv_copy+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then tcl_cv_putenv_copy=no else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <stdlib.h> |
︙ | ︙ | |||
12857 12858 12859 12860 12861 12862 12863 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_putenv_copy=yes fi | | | 14138 14139 14140 14141 14142 14143 14144 14145 14146 14147 14148 14149 14150 14151 14152 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_putenv_copy=yes fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi echo "$as_me:$LINENO: result: $tcl_cv_putenv_copy" >&5 echo "${ECHO_T}$tcl_cv_putenv_copy" >&6 if test $tcl_cv_putenv_copy = yes; then |
︙ | ︙ | |||
12901 12902 12903 12904 12905 12906 12907 | echo "$as_me:$LINENO: result: $ac_cv_header_langinfo_h" >&5 echo "${ECHO_T}$ac_cv_header_langinfo_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking langinfo.h usability" >&5 echo $ECHO_N "checking langinfo.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | 14182 14183 14184 14185 14186 14187 14188 14189 14190 14191 14192 14193 14194 14195 14196 14197 14198 14199 14200 14201 14202 14203 14204 14205 14206 14207 14208 14209 14210 14211 14212 14213 14214 14215 14216 14217 14218 14219 14220 14221 14222 14223 14224 14225 14226 14227 14228 14229 14230 14231 14232 14233 14234 14235 14236 14237 14238 14239 14240 14241 14242 14243 14244 14245 14246 14247 14248 14249 14250 14251 14252 14253 14254 14255 14256 14257 14258 14259 14260 14261 14262 14263 14264 14265 14266 14267 14268 14269 14270 14271 14272 14273 14274 14275 14276 14277 14278 14279 14280 14281 14282 14283 14284 14285 14286 14287 14288 14289 14290 14291 14292 14293 14294 14295 14296 14297 14298 14299 14300 14301 14302 14303 | echo "$as_me:$LINENO: result: $ac_cv_header_langinfo_h" >&5 echo "${ECHO_T}$ac_cv_header_langinfo_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking langinfo.h usability" >&5 echo $ECHO_N "checking langinfo.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <langinfo.h> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking langinfo.h presence" >&5 echo $ECHO_N "checking langinfo.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <langinfo.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: langinfo.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: langinfo.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: langinfo.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: langinfo.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: langinfo.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: langinfo.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: langinfo.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: langinfo.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: langinfo.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: langinfo.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: langinfo.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: langinfo.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: langinfo.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: langinfo.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: langinfo.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: langinfo.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for langinfo.h" >&5 echo $ECHO_N "checking for langinfo.h... $ECHO_C" >&6 |
︙ | ︙ | |||
13030 13031 13032 13033 13034 13035 13036 | fi fi echo "$as_me:$LINENO: checking whether to use nl_langinfo" >&5 echo $ECHO_N "checking whether to use nl_langinfo... $ECHO_C" >&6 if test "$langinfo_ok" = "yes"; then cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | | 14319 14320 14321 14322 14323 14324 14325 14326 14327 14328 14329 14330 14331 14332 14333 14334 14335 14336 14337 14338 14339 14340 14341 14342 14343 14344 14345 14346 14347 14348 14349 14350 14351 14352 14353 14354 14355 14356 14357 14358 14359 14360 14361 14362 14363 14364 14365 14366 14367 14368 14369 14370 14371 14372 14373 14374 14375 14376 | fi fi echo "$as_me:$LINENO: checking whether to use nl_langinfo" >&5 echo $ECHO_N "checking whether to use nl_langinfo... $ECHO_C" >&6 if test "$langinfo_ok" = "yes"; then cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <langinfo.h> int main () { nl_langinfo(CODESET); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then langinfo_ok=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 langinfo_ok=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext if test "$langinfo_ok" = "no"; then langinfo_ok="no (could not compile with nl_langinfo)"; fi if test "$langinfo_ok" = "yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_LANGINFO 1 |
︙ | ︙ | |||
13094 13095 13096 13097 13098 13099 13100 | as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 14392 14393 14394 14395 14396 14397 14398 14399 14400 14401 14402 14403 14404 14405 14406 14407 14408 14409 14410 14411 14412 14413 14414 14415 14416 14417 14418 14419 14420 14421 14422 14423 14424 14425 14426 14427 14428 14429 14430 14431 14432 14433 14434 14435 14436 14437 14438 14439 14440 14441 14442 14443 14444 14445 14446 14447 14448 14449 14450 14451 14452 14453 14454 14455 14456 14457 14458 14459 14460 14461 14462 14463 14464 14465 14466 14467 14468 14469 14470 14471 14472 14473 14474 14475 14476 14477 14478 14479 14480 14481 14482 14483 14484 14485 14486 14487 14488 14489 14490 14491 14492 14493 14494 14495 14496 14497 14498 14499 14500 14501 14502 14503 14504 14505 14506 14507 14508 14509 14510 14511 14512 14513 14514 14515 14516 14517 14518 14519 14520 14521 14522 14523 14524 14525 14526 14527 14528 14529 14530 14531 14532 14533 14534 | as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef $ac_func /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_$ac_func) || defined (__stub___$ac_func) choke me #else char (*f) () = $ac_func; #endif #ifdef __cplusplus } #endif int main () { return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_var=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done #-------------------------------------------------------------------- # Check for support of getattrlist function (Darwin, HFS+) #-------------------------------------------------------------------- for ac_func in getattrlist do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func. For example, HP-UX 11i <limits.h> declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer <limits.h> to <assert.h> if __STDC__ is defined, since <limits.h> exists even on freestanding compilers. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif #undef $ac_func /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ |
︙ | ︙ | |||
13139 13140 13141 13142 13143 13144 13145 | return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 | | > > > > > > > > > > | < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 14551 14552 14553 14554 14555 14556 14557 14558 14559 14560 14561 14562 14563 14564 14565 14566 14567 14568 14569 14570 14571 14572 14573 14574 14575 14576 14577 14578 14579 14580 14581 14582 14583 14584 14585 14586 14587 14588 14589 14590 14591 14592 14593 | return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_var=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF |
︙ | ︙ | |||
13283 13284 13285 13286 13287 13288 13289 | echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | | 14617 14618 14619 14620 14621 14622 14623 14624 14625 14626 14627 14628 14629 14630 14631 14632 14633 14634 14635 14636 14637 14638 14639 14640 14641 14642 14643 14644 14645 14646 14647 14648 14649 14650 14651 14652 14653 14654 14655 14656 14657 14658 14659 14660 14661 14662 14663 14664 14665 14666 14667 14668 14669 14670 14671 14672 14673 14674 14675 14676 14677 14678 14679 14680 14681 14682 14683 14684 14685 14686 14687 14688 14689 14690 14691 14692 14693 14694 14695 14696 14697 14698 14699 14700 14701 14702 14703 14704 14705 14706 14707 14708 14709 14710 14711 14712 14713 14714 14715 14716 14717 14718 14719 14720 14721 14722 14723 14724 14725 14726 14727 14728 14729 14730 14731 14732 14733 14734 14735 14736 14737 14738 14739 14740 14741 14742 14743 14744 14745 14746 14747 14748 14749 | echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF |
︙ | ︙ | |||
13425 13426 13427 13428 13429 13430 13431 | echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | | 14767 14768 14769 14770 14771 14772 14773 14774 14775 14776 14777 14778 14779 14780 14781 14782 14783 14784 14785 14786 14787 14788 14789 14790 14791 14792 14793 14794 14795 14796 14797 14798 14799 14800 14801 14802 14803 14804 14805 14806 14807 14808 14809 14810 14811 14812 14813 14814 14815 14816 14817 14818 14819 14820 14821 14822 14823 14824 14825 14826 14827 14828 14829 14830 14831 14832 14833 14834 14835 14836 14837 14838 14839 14840 14841 14842 14843 14844 14845 14846 14847 14848 14849 14850 14851 14852 14853 14854 14855 14856 14857 14858 14859 14860 14861 14862 14863 14864 14865 14866 14867 14868 14869 14870 14871 14872 14873 14874 14875 14876 14877 14878 14879 14880 14881 14882 14883 14884 14885 14886 14887 14888 14889 14890 14891 14892 14893 14894 14895 14896 14897 14898 14899 | echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------ ## ## Report this to the tcl lists. ## ## ------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF |
︙ | ︙ | |||
13609 13610 13611 13612 13613 13614 13615 13616 13617 13618 13619 13620 13621 13622 13623 13624 13625 13626 13627 13628 13629 13630 13631 13632 | ;; *) echo "$as_me:$LINENO: result: O_NONBLOCK" >&5 echo "${ECHO_T}O_NONBLOCK" >&6 ;; esac #-------------------------------------------------------------------- # 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 "$as_me:$LINENO: checking how to package libraries" >&5 echo $ECHO_N "checking how to package libraries... $ECHO_C" >&6 # Check whether --enable-framework or --disable-framework was given. if test "${enable_framework+set}" = set; then enableval="$enable_framework" tcl_ok=$enableval | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 14959 14960 14961 14962 14963 14964 14965 14966 14967 14968 14969 14970 14971 14972 14973 14974 14975 14976 14977 14978 14979 14980 14981 14982 14983 14984 14985 14986 14987 14988 14989 14990 14991 14992 14993 14994 14995 14996 14997 14998 14999 15000 15001 15002 15003 15004 15005 15006 15007 15008 15009 15010 15011 15012 15013 15014 15015 | ;; *) echo "$as_me:$LINENO: result: O_NONBLOCK" >&5 echo "${ECHO_T}O_NONBLOCK" >&6 ;; esac #------------------------------------------------------------------------ # Check whether --enable-dll-unloading or --disable-dll-unloading was given. if test "${enable_dll_unloading+set}" = set; then enableval="$enable_dll_unloading" tcl_ok=$enableval else tcl_ok=yes fi; if test $tcl_ok = yes; then cat >>confdefs.h <<\_ACEOF #define TCL_UNLOAD_DLLS 1 _ACEOF fi #-------------------------------------------------------------------- # The statements below define a collection of symbols related to # building libtcl as a shared library instead of a static library. #-------------------------------------------------------------------- TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX} eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}" # tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed # since on some platforms TCL_LIB_FILE contains shell escapes. # (See also: TCL_TRIM_DOTS). eval "TCL_LIB_FILE=${TCL_LIB_FILE}" TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)' PRIVATE_INCLUDE_DIR='$(includedir)' HTML_DIR='$(DISTDIR)/html' # Note: in the following variable, it's important to use the absolute # path name of the Tcl directory rather than "..": this is because # AIX remembers this path and will attempt to use it at run-time to look # up the Tcl library. if test "`uname -s`" = "Darwin" ; then echo "$as_me:$LINENO: checking how to package libraries" >&5 echo $ECHO_N "checking how to package libraries... $ECHO_C" >&6 # Check whether --enable-framework or --disable-framework was given. if test "${enable_framework+set}" = set; then enableval="$enable_framework" tcl_ok=$enableval |
︙ | ︙ | |||
13646 13647 13648 13649 13650 13651 13652 13653 13654 13655 13656 13657 13658 | echo "${ECHO_T}framework" >&6 FRAMEWORK_BUILD=1 if test "${SHARED_BUILD}" = "0" ; then { echo "$as_me:$LINENO: WARNING: \"Frameworks can only be built if --enable-shared is yes\"" >&5 echo "$as_me: WARNING: \"Frameworks can only be built if --enable-shared is yes\"" >&2;} FRAMEWORK_BUILD=0 fi else echo "$as_me:$LINENO: result: standard shared library" >&5 echo "${ECHO_T}standard shared library" >&6 FRAMEWORK_BUILD=0 fi | > > > > > | < < | < < < | < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | < < < | | | | | | > | > > > > > > > > > > < > | | | | < < < < < < < < < < < < < < < < < | 15029 15030 15031 15032 15033 15034 15035 15036 15037 15038 15039 15040 15041 15042 15043 15044 15045 15046 15047 15048 15049 15050 15051 15052 15053 15054 15055 15056 15057 15058 15059 15060 15061 15062 15063 15064 15065 15066 15067 15068 15069 15070 15071 15072 15073 15074 15075 15076 15077 15078 15079 15080 15081 15082 15083 15084 15085 15086 15087 15088 15089 15090 15091 15092 15093 15094 15095 15096 15097 15098 15099 15100 15101 15102 15103 15104 15105 15106 15107 15108 15109 15110 15111 15112 15113 15114 15115 15116 15117 15118 15119 15120 15121 15122 15123 15124 15125 15126 15127 15128 15129 15130 15131 15132 15133 15134 15135 15136 15137 15138 15139 15140 15141 15142 15143 15144 15145 15146 15147 15148 15149 15150 15151 15152 15153 15154 15155 15156 15157 15158 15159 15160 15161 15162 15163 15164 15165 15166 15167 15168 15169 15170 15171 15172 | echo "${ECHO_T}framework" >&6 FRAMEWORK_BUILD=1 if test "${SHARED_BUILD}" = "0" ; then { echo "$as_me:$LINENO: WARNING: \"Frameworks can only be built if --enable-shared is yes\"" >&5 echo "$as_me: WARNING: \"Frameworks can only be built if --enable-shared is yes\"" >&2;} FRAMEWORK_BUILD=0 fi if test $tcl_corefoundation = no; then { echo "$as_me:$LINENO: WARNING: \"Frameworks can only be used when CoreFoundation is available\"" >&5 echo "$as_me: WARNING: \"Frameworks can only be used when CoreFoundation is available\"" >&2;} FRAMEWORK_BUILD=0 fi else echo "$as_me:$LINENO: result: standard shared library" >&5 echo "${ECHO_T}standard shared library" >&6 FRAMEWORK_BUILD=0 fi TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk '{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}'`" TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name ${DYLIB_INSTALL_DIR}/${TCL_LIB_FILE} -seg1addr 0xa000000' fi if test "$FRAMEWORK_BUILD" = "1" ; then cat >>confdefs.h <<\_ACEOF #define TCL_FRAMEWORK 1 _ACEOF ac_config_files="$ac_config_files Tcl-Info.plist:../macosx/Tcl-Info.plist.in" # Construct a fake local framework structure to make linking with # '-framework Tcl' and running of tcltest work ac_config_commands="$ac_config_commands Tcl.framework" LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH" if test "${libdir}" = '${exec_prefix}/lib'; then # override libdir default libdir="/Library/Frameworks" fi TCL_LIB_FILE="Tcl" TCL_LIB_FLAG="-framework Tcl" TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl" TCL_LIB_SPEC="-F${libdir} -framework Tcl" libdir="${libdir}/Tcl.framework/Versions/\${VERSION}" TCL_LIBRARY="${libdir}/Resources/Scripts" includedir="${libdir}/Headers" PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders" HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" EXTRA_INSTALL="install-private-headers html-tcl" EXTRA_BUILD_HTML='@ln -fs contents.htm $(HTML_INSTALL_DIR)/TclTOC.html' EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' TCL_YEAR="`date +%Y`" # Don't use AC_DEFINE for the following as the framework version define # needs to go into the Makefile even when using autoheader, so that we # can pick up a potential make override of VERSION. Also, don't put this # into CFLAGS as it should not go into tclConfig.sh EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"' else # libdir must be a fully qualified path and not ${exec_prefix}/lib eval libdir="$libdir" if test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then TCL_LIB_FLAG="-ltcl${TCL_VERSION}" else TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`" fi TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}" TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}" else TCL_BUILD_EXP_FILE="lib.exp" eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}" if test "$GCC" = "yes" ; then TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`" TCL_LIB_SPEC="-Wl,-bI:${libdir}/${TCL_EXP_FILE} -L`pwd`" else TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}" TCL_LIB_SPEC="-bI:${libdir}/${TCL_EXP_FILE}" fi fi fi VERSION='${VERSION}' eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}" eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}" eval "CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}" VERSION=${TCL_VERSION} #-------------------------------------------------------------------- # The statements below define the symbol TCL_PACKAGE_PATH, which # gives a list of directories that may contain packages. The list # consists of one directory for machine-dependent binaries and # another for platform-independent scripts. #-------------------------------------------------------------------- if test "$FRAMEWORK_BUILD" = "1" ; then TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl ~/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks" TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl" elif test "$prefix/lib" != "$libdir"; then TCL_PACKAGE_PATH="${libdir} ${prefix}/lib" else TCL_PACKAGE_PATH="${prefix}/lib" fi # If a system share directory like /usr/local/share already exists, then add # it to the package search path. if test -d "${prefix}/share" ; then TCL_PACKAGE_PATH="${TCL_PACKAGE_PATH} ${prefix}/share" fi #-------------------------------------------------------------------- # The statements below define various symbols relating to Tcl # stub support. #-------------------------------------------------------------------- # Replace ${VERSION} with contents of ${TCL_VERSION} # double-eval to account for TCL_TRIM_DOTS. # eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" eval "TCL_STUB_LIB_DIR=${libdir}" if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}" else TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`" fi TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}" TCL_STUB_LIB_SPEC="-L${TCL_STUB_LIB_DIR} ${TCL_STUB_LIB_FLAG}" TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}" TCL_STUB_LIB_PATH="${TCL_STUB_LIB_DIR}/${TCL_STUB_LIB_FILE}" # Install time header dir can be set via --includedir eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" #------------------------------------------------------------------------ # tclConfig.sh refers to this by a different name #------------------------------------------------------------------------ TCL_SHARED_BUILD=${SHARED_BUILD} |
︙ | ︙ | |||
13784 13785 13786 13787 13788 13789 13790 |
| | | | > > > > > > | 15184 15185 15186 15187 15188 15189 15190 15191 15192 15193 15194 15195 15196 15197 15198 15199 15200 15201 15202 15203 15204 15205 15206 | |
︙ | ︙ | |||
13810 13811 13812 13813 13814 13815 13816 13817 13818 13819 13820 13821 13822 13823 | ac_config_files="$ac_config_files Makefile dltest/Makefile tclConfig.sh" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # | > | 15216 15217 15218 15219 15220 15221 15222 15223 15224 15225 15226 15227 15228 15229 15230 | ac_config_files="$ac_config_files Makefile dltest/Makefile tclConfig.sh" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # |
︙ | ︙ | |||
13838 13839 13840 13841 13842 13843 13844 | { (set) 2>&1 | case `(ac_space=' '; set | grep ac_space) 2>&1` in *ac_space=\ *) # `set' does not quote correctly, so add quotes (double-quote # substitution turns \\\\ into \\, and sed turns \\ into \). sed -n \ | | | | | 15245 15246 15247 15248 15249 15250 15251 15252 15253 15254 15255 15256 15257 15258 15259 15260 15261 15262 15263 15264 15265 | { (set) 2>&1 | case `(ac_space=' '; set | grep ac_space) 2>&1` in *ac_space=\ *) # `set' does not quote correctly, so add quotes (double-quote # substitution turns \\\\ into \\, and sed turns \\ into \). sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n \ "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } | sed ' t clear : clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ |
︙ | ︙ | |||
13874 13875 13876 13877 13878 13879 13880 | test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # VPATH may cause trouble with some makes, so we remove $(srcdir), # ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then | | | | | | | < < < < < < < < < < < < < < | 15281 15282 15283 15284 15285 15286 15287 15288 15289 15290 15291 15292 15293 15294 15295 15296 15297 15298 15299 15300 15301 15302 15303 15304 15305 15306 15307 15308 15309 15310 15311 15312 15313 15314 15315 15316 15317 15318 15319 15320 15321 15322 15323 15324 15325 15326 15327 15328 15329 15330 15331 15332 15333 15334 15335 15336 15337 | test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # VPATH may cause trouble with some makes, so we remove $(srcdir), # ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=/{ s/:*\$(srcdir):*/:/; s/:*\${srcdir}:*/:/; s/:*@srcdir@:*/:/; s/^\([^=]*=[ ]*\):*/\1/; s/:*$//; s/^[^=]*=[ ]*$//; }' fi # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then we branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. cat >confdef2opt.sed <<\_ACEOF t clear : clear s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g t quote s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g t quote d : quote s,[ `~#$^&*(){}\\|;'"<>?],\\&,g s,\[,\\&,g s,\],\\&,g s,\$,$$,g p _ACEOF # We use echo to avoid assuming a particular line-breaking character. # The extra dot is to prevent the shell from consuming trailing # line-breaks from the sub-command output. A line-break within # single-quotes doesn't work because, if this script is created in a # platform that uses two characters for line-breaks (e.g., DOS), tr # would break. ac_LF_and_DOT=`echo; echo .` DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'` rm -f confdef2opt.sed : ${CONFIG_STATUS=./config.status} ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 echo "$as_me: creating $CONFIG_STATUS" >&6;} |
︙ | ︙ | |||
13966 13967 13968 13969 13970 13971 13972 13973 13974 | NULLCMD=: # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi # Support unset when possible. | > | | | 15359 15360 15361 15362 15363 15364 15365 15366 15367 15368 15369 15370 15371 15372 15373 15374 15375 15376 15377 15378 15379 15380 15381 15382 15383 15384 15385 15386 15387 15388 15389 15390 15391 15392 15393 15394 15395 | NULLCMD=: # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # Work around bugs in pre-3.0 UWIN ksh. $as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done # Required to use basename. |
︙ | ︙ | |||
14166 14167 14168 14169 14170 14171 14172 14173 14174 14175 14176 14177 14178 | as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. | > | | | 15560 15561 15562 15563 15564 15565 15566 15567 15568 15569 15570 15571 15572 15573 15574 15575 15576 15577 15578 15579 15580 15581 15582 15583 15584 | as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' ' IFS=" $as_nl" |
︙ | ︙ | |||
14202 14203 14204 14205 14206 14207 14208 | sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX } >&5 cat >&5 <<_CSEOF This file was extended by tcl $as_me 8.5, which was | | | 15597 15598 15599 15600 15601 15602 15603 15604 15605 15606 15607 15608 15609 15610 15611 | sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX } >&5 cat >&5 <<_CSEOF This file was extended by tcl $as_me 8.5, which was generated by GNU Autoconf 2.59. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ |
︙ | ︙ | |||
14246 14247 14248 14249 14250 14251 14252 | -h, --help print this help, then exit -V, --version print version number, then exit -q, --quiet do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] | | > > > | < | | 15641 15642 15643 15644 15645 15646 15647 15648 15649 15650 15651 15652 15653 15654 15655 15656 15657 15658 15659 15660 15661 15662 15663 15664 15665 15666 15667 15668 15669 15670 15671 15672 | -h, --help print this help, then exit -V, --version print version number, then exit -q, --quiet do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Configuration commands: $config_commands Report bugs to <[email protected]>." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ tcl config.status 8.5 configured by $0, generated by GNU Autoconf 2.59, with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" Copyright (C) 2003 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." srcdir=$srcdir _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF # If no file are specified by the user, then we need to provide default |
︙ | ︙ | |||
14350 14351 14352 14353 14354 14355 14356 | if \$ac_cs_recheck; then echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6 exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion fi _ACEOF | > | > > > > > > > > > | 15747 15748 15749 15750 15751 15752 15753 15754 15755 15756 15757 15758 15759 15760 15761 15762 15763 15764 15765 15766 15767 15768 15769 15770 15771 15772 15773 15774 15775 15776 15777 15778 15779 15780 15781 15782 15783 15784 15785 15786 15787 15788 15789 15790 15791 15792 15793 15794 | if \$ac_cs_recheck; then echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6 exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF # # INIT-COMMANDS section. # VERSION=${TCL_VERSION} _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF for ac_config_target in $ac_config_targets do case "$ac_config_target" in # Handling of arguments. "Tcl-Info.plist" ) CONFIG_FILES="$CONFIG_FILES Tcl-Info.plist:../macosx/Tcl-Info.plist.in" ;; "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;; "dltest/Makefile" ) CONFIG_FILES="$CONFIG_FILES dltest/Makefile" ;; "tclConfig.sh" ) CONFIG_FILES="$CONFIG_FILES tclConfig.sh" ;; "Tcl.framework" ) CONFIG_COMMANDS="$CONFIG_COMMANDS Tcl.framework" ;; *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 echo "$as_me: error: invalid argument: $ac_config_target" >&2;} { (exit 1); exit 1; }; };; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason to put it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Create a temporary directory, and hook for its removal unless debugging. $debug || |
︙ | ︙ | |||
14464 14465 14466 14467 14468 14469 14470 14471 14472 14473 14474 14475 14476 14477 14478 14479 14480 14481 | s,@ac_ct_RANLIB@,$ac_ct_RANLIB,;t t s,@AR@,$AR,;t t s,@LIBOBJS@,$LIBOBJS,;t t s,@TCL_LIBS@,$TCL_LIBS,;t t s,@DL_LIBS@,$DL_LIBS,;t t s,@DL_OBJS@,$DL_OBJS,;t t s,@PLAT_OBJS@,$PLAT_OBJS,;t t s,@CFLAGS_DEBUG@,$CFLAGS_DEBUG,;t t s,@CFLAGS_OPTIMIZE@,$CFLAGS_OPTIMIZE,;t t s,@CFLAGS_WARNING@,$CFLAGS_WARNING,;t t s,@LDFLAGS_DEBUG@,$LDFLAGS_DEBUG,;t t s,@LDFLAGS_OPTIMIZE@,$LDFLAGS_OPTIMIZE,;t t s,@CC_SEARCH_FLAGS@,$CC_SEARCH_FLAGS,;t t s,@LD_SEARCH_FLAGS@,$LD_SEARCH_FLAGS,;t t s,@STLIB_LD@,$STLIB_LD,;t t s,@SHLIB_LD@,$SHLIB_LD,;t t s,@TCL_SHLIB_LD_EXTRAS@,$TCL_SHLIB_LD_EXTRAS,;t t s,@TK_SHLIB_LD_EXTRAS@,$TK_SHLIB_LD_EXTRAS,;t t | > < > < > > > | > > > > | 15871 15872 15873 15874 15875 15876 15877 15878 15879 15880 15881 15882 15883 15884 15885 15886 15887 15888 15889 15890 15891 15892 15893 15894 15895 15896 15897 15898 15899 15900 15901 15902 15903 15904 15905 15906 15907 15908 15909 15910 15911 15912 15913 15914 15915 15916 15917 15918 15919 15920 15921 15922 15923 15924 15925 15926 15927 15928 15929 15930 15931 15932 15933 15934 15935 15936 15937 15938 15939 15940 15941 15942 15943 15944 | s,@ac_ct_RANLIB@,$ac_ct_RANLIB,;t t s,@AR@,$AR,;t t s,@LIBOBJS@,$LIBOBJS,;t t s,@TCL_LIBS@,$TCL_LIBS,;t t s,@DL_LIBS@,$DL_LIBS,;t t s,@DL_OBJS@,$DL_OBJS,;t t s,@PLAT_OBJS@,$PLAT_OBJS,;t t s,@PLAT_SRCS@,$PLAT_SRCS,;t t s,@CFLAGS_DEBUG@,$CFLAGS_DEBUG,;t t s,@CFLAGS_OPTIMIZE@,$CFLAGS_OPTIMIZE,;t t s,@CFLAGS_WARNING@,$CFLAGS_WARNING,;t t s,@LDFLAGS_DEBUG@,$LDFLAGS_DEBUG,;t t s,@LDFLAGS_OPTIMIZE@,$LDFLAGS_OPTIMIZE,;t t s,@CC_SEARCH_FLAGS@,$CC_SEARCH_FLAGS,;t t s,@LD_SEARCH_FLAGS@,$LD_SEARCH_FLAGS,;t t s,@STLIB_LD@,$STLIB_LD,;t t s,@SHLIB_LD@,$SHLIB_LD,;t t s,@TCL_SHLIB_LD_EXTRAS@,$TCL_SHLIB_LD_EXTRAS,;t t s,@TK_SHLIB_LD_EXTRAS@,$TK_SHLIB_LD_EXTRAS,;t t s,@SHLIB_LD_LIBS@,$SHLIB_LD_LIBS,;t t s,@SHLIB_CFLAGS@,$SHLIB_CFLAGS,;t t s,@SHLIB_SUFFIX@,$SHLIB_SUFFIX,;t t s,@MAKE_LIB@,$MAKE_LIB,;t t s,@MAKE_STUB_LIB@,$MAKE_STUB_LIB,;t t s,@INSTALL_LIB@,$INSTALL_LIB,;t t s,@INSTALL_STUB_LIB@,$INSTALL_STUB_LIB,;t t s,@CFLAGS_DEFAULT@,$CFLAGS_DEFAULT,;t t s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t s,@TCL_VERSION@,$TCL_VERSION,;t t s,@TCL_MAJOR_VERSION@,$TCL_MAJOR_VERSION,;t t s,@TCL_MINOR_VERSION@,$TCL_MINOR_VERSION,;t t s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t s,@TCL_YEAR@,$TCL_YEAR,;t t s,@TCL_LIB_FILE@,$TCL_LIB_FILE,;t t s,@TCL_LIB_FLAG@,$TCL_LIB_FLAG,;t t s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t s,@TCL_STUB_LIB_FILE@,$TCL_STUB_LIB_FILE,;t t s,@TCL_STUB_LIB_FLAG@,$TCL_STUB_LIB_FLAG,;t t s,@TCL_STUB_LIB_SPEC@,$TCL_STUB_LIB_SPEC,;t t s,@TCL_STUB_LIB_PATH@,$TCL_STUB_LIB_PATH,;t t s,@TCL_INCLUDE_SPEC@,$TCL_INCLUDE_SPEC,;t t s,@TCL_BUILD_STUB_LIB_SPEC@,$TCL_BUILD_STUB_LIB_SPEC,;t t s,@TCL_BUILD_STUB_LIB_PATH@,$TCL_BUILD_STUB_LIB_PATH,;t t s,@TCL_SRC_DIR@,$TCL_SRC_DIR,;t t s,@CFG_TCL_SHARED_LIB_SUFFIX@,$CFG_TCL_SHARED_LIB_SUFFIX,;t t s,@CFG_TCL_UNSHARED_LIB_SUFFIX@,$CFG_TCL_UNSHARED_LIB_SUFFIX,;t t s,@CFG_TCL_EXPORT_FILE_SUFFIX@,$CFG_TCL_EXPORT_FILE_SUFFIX,;t t s,@TCL_SHARED_BUILD@,$TCL_SHARED_BUILD,;t t s,@LD_LIBRARY_PATH_VAR@,$LD_LIBRARY_PATH_VAR,;t t s,@TCL_BUILD_LIB_SPEC@,$TCL_BUILD_LIB_SPEC,;t t s,@TCL_NEEDS_EXP_FILE@,$TCL_NEEDS_EXP_FILE,;t t s,@TCL_BUILD_EXP_FILE@,$TCL_BUILD_EXP_FILE,;t t s,@TCL_EXP_FILE@,$TCL_EXP_FILE,;t t s,@TCL_LIB_VERSIONS_OK@,$TCL_LIB_VERSIONS_OK,;t t s,@TCL_SHARED_LIB_SUFFIX@,$TCL_SHARED_LIB_SUFFIX,;t t s,@TCL_UNSHARED_LIB_SUFFIX@,$TCL_UNSHARED_LIB_SUFFIX,;t t s,@TCL_HAS_LONGLONG@,$TCL_HAS_LONGLONG,;t t s,@BUILD_DLTEST@,$BUILD_DLTEST,;t t s,@TCL_PACKAGE_PATH@,$TCL_PACKAGE_PATH,;t t s,@TCL_MODULE_PATH@,$TCL_MODULE_PATH,;t t s,@TCL_LIBRARY@,$TCL_LIBRARY,;t t s,@PRIVATE_INCLUDE_DIR@,$PRIVATE_INCLUDE_DIR,;t t s,@HTML_DIR@,$HTML_DIR,;t t s,@EXTRA_CC_SWITCHES@,$EXTRA_CC_SWITCHES,;t t s,@EXTRA_INSTALL@,$EXTRA_INSTALL,;t t s,@EXTRA_INSTALL_BINARIES@,$EXTRA_INSTALL_BINARIES,;t t s,@EXTRA_BUILD_HTML@,$EXTRA_BUILD_HTML,;t t CEOF _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF # Split the substitutions into bite-sized pieces for seds with # small command number limits, like on Digital OSF/1 and HP-UX. |
︙ | ︙ | |||
14546 14547 14548 14549 14550 14551 14552 | # The purpose of the label and of the branching condition is to # speed up the sed processing (if there are no `@' at all, there # is no need to browse any of the substitutions). # These are the two extra sed commands mentioned above. (echo ':t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed if test -z "$ac_sed_cmds"; then | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 15960 15961 15962 15963 15964 15965 15966 15967 15968 15969 15970 15971 15972 15973 15974 15975 15976 15977 15978 15979 15980 15981 15982 15983 15984 15985 15986 15987 15988 15989 15990 15991 15992 15993 15994 15995 15996 15997 15998 15999 16000 16001 16002 16003 16004 16005 16006 16007 16008 16009 16010 16011 16012 16013 16014 16015 16016 16017 16018 16019 16020 16021 16022 16023 16024 16025 16026 16027 16028 16029 16030 16031 16032 16033 16034 16035 16036 16037 16038 16039 16040 16041 16042 16043 16044 16045 16046 16047 16048 16049 16050 16051 16052 16053 16054 16055 16056 16057 16058 16059 16060 16061 16062 16063 16064 16065 16066 16067 16068 16069 16070 16071 16072 16073 16074 16075 16076 16077 16078 16079 16080 16081 16082 16083 16084 16085 16086 16087 16088 16089 16090 16091 16092 16093 16094 16095 16096 16097 16098 16099 16100 16101 16102 16103 16104 16105 16106 16107 16108 16109 16110 16111 16112 16113 16114 16115 16116 16117 16118 16119 16120 16121 16122 16123 16124 16125 16126 16127 16128 16129 16130 16131 16132 16133 16134 16135 16136 16137 16138 16139 16140 16141 16142 16143 16144 16145 16146 16147 16148 16149 16150 16151 16152 16153 16154 16155 16156 16157 16158 16159 16160 16161 16162 16163 16164 16165 16166 16167 16168 16169 16170 16171 16172 16173 16174 16175 16176 16177 16178 16179 16180 16181 16182 16183 16184 16185 16186 16187 16188 16189 16190 16191 16192 16193 16194 16195 16196 16197 16198 16199 16200 16201 16202 16203 16204 16205 16206 16207 16208 16209 16210 | # The purpose of the label and of the branching condition is to # speed up the sed processing (if there are no `@' at all, there # is no need to browse any of the substitutions). # These are the two extra sed commands mentioned above. (echo ':t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed if test -z "$ac_sed_cmds"; then ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" else ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" fi ac_sed_frag=`expr $ac_sed_frag + 1` ac_beg=$ac_end ac_end=`expr $ac_end + $ac_max_sed_lines` fi done if test -z "$ac_sed_cmds"; then ac_sed_cmds=cat fi fi # test -n "$CONFIG_FILES" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". case $ac_file in - | *:- | *:-:* ) # input from stdin cat >$tmp/stdin ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; * ) ac_file_in=$ac_file.in ;; esac # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. ac_dir=`(dirname "$ac_file") 2>/dev/null || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` { if $as_mkdir_p; then mkdir -p "$ac_dir" else as_dir="$ac_dir" as_dirs= while test ! -d "$as_dir"; do as_dirs="$as_dir $as_dirs" as_dir=`(dirname "$as_dir") 2>/dev/null || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` done test ! -n "$as_dirs" || mkdir $as_dirs fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} { (exit 1); exit 1; }; }; } ac_builddir=. if test "$ac_dir" != .; then ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` # A "../" for each directory in $ac_dir_suffix. ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` else ac_dir_suffix= ac_top_builddir= fi case $srcdir in .) # No --srcdir option. We are building in place. ac_srcdir=. if test -z "$ac_top_builddir"; then ac_top_srcdir=. else ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` fi ;; [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac # Do not use `cd foo && pwd` to compute absolute paths, because # the directories may not exist. case `pwd` in .) ac_abs_builddir="$ac_dir";; *) case "$ac_dir" in .) ac_abs_builddir=`pwd`;; [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; *) ac_abs_builddir=`pwd`/"$ac_dir";; esac;; esac case $ac_abs_builddir in .) ac_abs_top_builddir=${ac_top_builddir}.;; *) case ${ac_top_builddir}. in .) ac_abs_top_builddir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; esac;; esac case $ac_abs_builddir in .) ac_abs_srcdir=$ac_srcdir;; *) case $ac_srcdir in .) ac_abs_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; esac;; esac case $ac_abs_builddir in .) ac_abs_top_srcdir=$ac_top_srcdir;; *) case $ac_top_srcdir in .) ac_abs_top_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; esac;; esac if test x"$ac_file" != x-; then { echo "$as_me:$LINENO: creating $ac_file" >&5 echo "$as_me: creating $ac_file" >&6;} rm -f "$ac_file" fi # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ if test x"$ac_file" = x-; then configure_input= else configure_input="$ac_file. " fi configure_input=$configure_input"Generated from `echo $ac_file_in | sed 's,.*/,,'` by configure." # First look for the input files in the build tree, otherwise in the # src tree. ac_file_inputs=`IFS=: for f in $ac_file_in; do case $f in -) echo $tmp/stdin ;; [\\/$]*) # Absolute (can't be DOS-style, as IFS=:) test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 echo "$as_me: error: cannot find input file: $f" >&2;} { (exit 1); exit 1; }; } echo "$f";; *) # Relative if test -f "$f"; then # Build tree echo "$f" elif test -f "$srcdir/$f"; then # Source tree echo "$srcdir/$f" else # /dev/null tree { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 echo "$as_me: error: cannot find input file: $f" >&2;} { (exit 1); exit 1; }; } fi;; esac done` || { (exit 1); exit 1; } _ACEOF cat >>$CONFIG_STATUS <<_ACEOF sed "$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s,@configure_input@,$configure_input,;t t s,@srcdir@,$ac_srcdir,;t t s,@abs_srcdir@,$ac_abs_srcdir,;t t s,@top_srcdir@,$ac_top_srcdir,;t t s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t s,@builddir@,$ac_builddir,;t t s,@abs_builddir@,$ac_abs_builddir,;t t s,@top_builddir@,$ac_top_builddir,;t t s,@abs_top_builddir@,$ac_abs_top_builddir,;t t " $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out rm -f $tmp/stdin if test x"$ac_file" != x-; then mv $tmp/out $ac_file else cat $tmp/out rm -f $tmp/out fi done _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF # # CONFIG_COMMANDS section. # for ac_file in : $CONFIG_COMMANDS; do test "x$ac_file" = x: && continue ac_dest=`echo "$ac_file" | sed 's,:.*,,'` ac_source=`echo "$ac_file" | sed 's,[^:]*:,,'` ac_dir=`(dirname "$ac_dest") 2>/dev/null || $as_expr X"$ac_dest" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_dest" : 'X\(//\)[^/]' \| \ X"$ac_dest" : 'X\(//\)$' \| \ X"$ac_dest" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$ac_dest" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` { if $as_mkdir_p; then mkdir -p "$ac_dir" else as_dir="$ac_dir" as_dirs= while test ! -d "$as_dir"; do as_dirs="$as_dir $as_dirs" as_dir=`(dirname "$as_dir") 2>/dev/null || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` done |
︙ | ︙ | |||
14637 14638 14639 14640 14641 14642 14643 | [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac | | | > > | > | | | | | | < < | | < < < < < < > | | < < < | < < > | | | < > | < < < < | < < | < | < | < < < < < | | < < < < < < < < < < < | | > | < | | | < < < | | | < < > > > > > > > > > > > | 16234 16235 16236 16237 16238 16239 16240 16241 16242 16243 16244 16245 16246 16247 16248 16249 16250 16251 16252 16253 16254 16255 16256 16257 16258 16259 16260 16261 16262 16263 16264 16265 16266 16267 16268 16269 16270 16271 16272 16273 16274 16275 16276 16277 16278 16279 16280 16281 16282 16283 16284 16285 16286 16287 16288 16289 16290 16291 16292 16293 16294 16295 16296 16297 16298 16299 | [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac # Do not use `cd foo && pwd` to compute absolute paths, because # the directories may not exist. case `pwd` in .) ac_abs_builddir="$ac_dir";; *) case "$ac_dir" in .) ac_abs_builddir=`pwd`;; [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; *) ac_abs_builddir=`pwd`/"$ac_dir";; esac;; esac case $ac_abs_builddir in .) ac_abs_top_builddir=${ac_top_builddir}.;; *) case ${ac_top_builddir}. in .) ac_abs_top_builddir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; esac;; esac case $ac_abs_builddir in .) ac_abs_srcdir=$ac_srcdir;; *) case $ac_srcdir in .) ac_abs_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; esac;; esac case $ac_abs_builddir in .) ac_abs_top_srcdir=$ac_top_srcdir;; *) case $ac_top_srcdir in .) ac_abs_top_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; esac;; esac { echo "$as_me:$LINENO: executing $ac_dest commands" >&5 echo "$as_me: executing $ac_dest commands" >&6;} case $ac_dest in Tcl.framework ) n=Tcl && f=$n.framework && v=Versions/$VERSION && rm -rf $f && mkdir -p $f/$v/Resources && ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v && ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist && unset n f v ;; esac done _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF { (exit 0); exit 0; } _ACEOF |
︙ | ︙ |
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 | #! /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.123.2.8 2005/08/25 15:47:07 dgp Exp $ AC_INIT([tcl],[8.5]) AC_PREREQ(2.59) dnl AC_CONFIG_HEADERS([tclConfig.h]) dnl AC_CONFIG_COMMANDS_PRE([DEFS="-DHAVE_TCL_CONFIG_H -imacros tclConfig.h"]) dnl AH_TOP([#ifndef _TCLCONFIG dnl #define _TCLCONFIG]) dnl AH_BOTTOM([#endif /* _TCLCONFIG */]) TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 TCL_PATCH_LEVEL="a4" 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 TCL_SRC_DIR=`cd $srcdir/..; pwd` #------------------------------------------------------------------------ # Compress and/or soft link the manpages? #------------------------------------------------------------------------ SC_CONFIG_MANPAGES |
︙ | ︙ | |||
102 103 104 105 106 107 108 | # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called # after SC_ENABLE_SHARED checks the configure switches. #-------------------------------------------------------------------- SC_CONFIG_CFLAGS | | < < | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 | # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called # after SC_ENABLE_SHARED checks the configure switches. #-------------------------------------------------------------------- SC_CONFIG_CFLAGS SC_ENABLE_SYMBOLS(bccdebug) #-------------------------------------------------------------------- # Detect what compiler flags to set for 64-bit support. #-------------------------------------------------------------------- SC_TCL_EARLY_FLAGS |
︙ | ︙ | |||
424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 | # The statements below check for systems where POSIX-style # non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. # On these systems (mostly older ones), use the old BSD-style # FIONBIO approach instead. #-------------------------------------------------------------------- SC_BLOCKING_STYLE #-------------------------------------------------------------------- # The statements below define a collection of symbols related to # building libtcl as a shared library instead of a static library. #-------------------------------------------------------------------- TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX} eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}" | > > > > > > > > > > < < < > > < < > > > > > > > > > > < < < < > > > > | < > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | < < < | | | | | | > | > > > > > > > > > > < > | | | | < < < < < < < < < > < < < > > > > > > > > > > > > > | > | 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 | # The statements below check for systems where POSIX-style # non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. # On these systems (mostly older ones), use the old BSD-style # FIONBIO approach instead. #-------------------------------------------------------------------- SC_BLOCKING_STYLE #------------------------------------------------------------------------ AC_ARG_ENABLE(dll-unloading, AC_HELP_STRING([--enable-dll-unloading], [turn on the 'unload' command (default: on)]), [tcl_ok=$enableval], [tcl_ok=yes]) if test $tcl_ok = yes; then AC_DEFINE(TCL_UNLOAD_DLLS, 1, [Do we allow unloading of shared libraries?]) fi #-------------------------------------------------------------------- # The statements below define a collection of symbols related to # building libtcl as a shared library instead of a static library. #-------------------------------------------------------------------- TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX} eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}" # tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed # since on some platforms TCL_LIB_FILE contains shell escapes. # (See also: TCL_TRIM_DOTS). eval "TCL_LIB_FILE=${TCL_LIB_FILE}" TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)' PRIVATE_INCLUDE_DIR='$(includedir)' HTML_DIR='$(DISTDIR)/html' # Note: in the following variable, it's important to use the absolute # path name of the Tcl directory rather than "..": this is because # AIX remembers this path and will attempt to use it at run-time to look # up the Tcl library. if test "`uname -s`" = "Darwin" ; then SC_ENABLE_FRAMEWORK TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk ['{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}']`" TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name ${DYLIB_INSTALL_DIR}/${TCL_LIB_FILE} -seg1addr 0xa000000' fi if test "$FRAMEWORK_BUILD" = "1" ; then AC_DEFINE(TCL_FRAMEWORK, 1, [Is Tcl built as a framework?]) AC_CONFIG_FILES([Tcl-Info.plist:../macosx/Tcl-Info.plist.in]) # Construct a fake local framework structure to make linking with # '-framework Tcl' and running of tcltest work AC_CONFIG_COMMANDS([Tcl.framework], [n=Tcl && f=$n.framework && v=Versions/$VERSION && rm -rf $f && mkdir -p $f/$v/Resources && ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v && ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist && unset n f v ], VERSION=${TCL_VERSION}) LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH" if test "${libdir}" = '${exec_prefix}/lib'; then # override libdir default libdir="/Library/Frameworks" fi TCL_LIB_FILE="Tcl" TCL_LIB_FLAG="-framework Tcl" TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl" TCL_LIB_SPEC="-F${libdir} -framework Tcl" libdir="${libdir}/Tcl.framework/Versions/\${VERSION}" TCL_LIBRARY="${libdir}/Resources/Scripts" includedir="${libdir}/Headers" PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders" HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl" EXTRA_INSTALL="install-private-headers html-tcl" EXTRA_BUILD_HTML='@ln -fs contents.htm $(HTML_INSTALL_DIR)/TclTOC.html' EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' TCL_YEAR="`date +%Y`" # Don't use AC_DEFINE for the following as the framework version define # needs to go into the Makefile even when using autoheader, so that we # can pick up a potential make override of VERSION. Also, don't put this # into CFLAGS as it should not go into tclConfig.sh EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"' else # libdir must be a fully qualified path and not ${exec_prefix}/lib eval libdir="$libdir" if test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then TCL_LIB_FLAG="-ltcl${TCL_VERSION}" else TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`" fi TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}" TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}" else TCL_BUILD_EXP_FILE="lib.exp" eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}" if test "$GCC" = "yes" ; then TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`" TCL_LIB_SPEC="-Wl,-bI:${libdir}/${TCL_EXP_FILE} -L`pwd`" else TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}" TCL_LIB_SPEC="-bI:${libdir}/${TCL_EXP_FILE}" fi fi fi VERSION='${VERSION}' eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}" eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}" eval "CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}" VERSION=${TCL_VERSION} #-------------------------------------------------------------------- # The statements below define the symbol TCL_PACKAGE_PATH, which # gives a list of directories that may contain packages. The list # consists of one directory for machine-dependent binaries and # another for platform-independent scripts. #-------------------------------------------------------------------- if test "$FRAMEWORK_BUILD" = "1" ; then TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl ~/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks" TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl" elif test "$prefix/lib" != "$libdir"; then TCL_PACKAGE_PATH="${libdir} ${prefix}/lib" else TCL_PACKAGE_PATH="${prefix}/lib" fi # If a system share directory like /usr/local/share already exists, then add # it to the package search path. if test -d "${prefix}/share" ; then TCL_PACKAGE_PATH="${TCL_PACKAGE_PATH} ${prefix}/share" fi #-------------------------------------------------------------------- # The statements below define various symbols relating to Tcl # stub support. #-------------------------------------------------------------------- # Replace ${VERSION} with contents of ${TCL_VERSION} # double-eval to account for TCL_TRIM_DOTS. # eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" eval "TCL_STUB_LIB_DIR=${libdir}" if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}" else TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`" fi TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}" TCL_STUB_LIB_SPEC="-L${TCL_STUB_LIB_DIR} ${TCL_STUB_LIB_FLAG}" TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}" TCL_STUB_LIB_PATH="${TCL_STUB_LIB_DIR}/${TCL_STUB_LIB_FILE}" # Install time header dir can be set via --includedir eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" #------------------------------------------------------------------------ # tclConfig.sh refers to this by a different name #------------------------------------------------------------------------ TCL_SHARED_BUILD=${SHARED_BUILD} AC_SUBST(TCL_VERSION) AC_SUBST(TCL_MAJOR_VERSION) AC_SUBST(TCL_MINOR_VERSION) AC_SUBST(TCL_PATCH_LEVEL) AC_SUBST(TCL_YEAR) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) AC_SUBST(TCL_STUB_LIB_FLAG) AC_SUBST(TCL_STUB_LIB_SPEC) 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(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_SUBST(TCL_MODULE_PATH) AC_SUBST(TCL_LIBRARY) AC_SUBST(PRIVATE_INCLUDE_DIR) AC_SUBST(HTML_DIR) AC_SUBST(EXTRA_CC_SWITCHES) AC_SUBST(EXTRA_INSTALL) AC_SUBST(EXTRA_INSTALL_BINARIES) AC_SUBST(EXTRA_BUILD_HTML) dnl Disable the automake-friendly normalization of LIBOBJS dnl performed by autoconf 2.53 and later. It's not correct for us. define([_AC_LIBOBJS_NORMALIZE],[]) AC_CONFIG_FILES([Makefile dltest/Makefile tclConfig.sh]) AC_OUTPUT |
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 | # 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.16.2.1 2005/01/20 14:53:41 kennykb Exp $ CC = @CC@ LIBS = @TCL_BUILD_STUB_LIB_SPEC@ @TCL_LIBS@ AC_FLAGS = @DEFS@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_LD = @SHLIB_LD@ SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ SHLIB_SUFFIX = @SHLIB_SUFFIX@ |
︙ | ︙ |
Changes to unix/tcl.m4.
︙ | ︙ | |||
23 24 25 26 27 28 29 | # First, look for one uninstalled. # the alternative search directory is invoked by --with-tcl # if test x"${no_tcl}" = x ; then # we reset no_tcl in case something fails here no_tcl=true | > > | > > > > > > > > | 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 | # First, look for one uninstalled. # the alternative search directory is invoked by --with-tcl # if test x"${no_tcl}" = x ; then # we reset no_tcl in case something fails here no_tcl=true AC_ARG_WITH(tcl, AC_HELP_STRING([--with-tcl], [directory containing tcl configuration (tclConfig.sh)]), with_tclconfig=${withval}) AC_MSG_CHECKING([for Tcl configuration]) AC_CACHE_VAL(ac_cv_c_tclconfig,[ # First check to see if --with-tcl was specified. if test x"${with_tclconfig}" != x ; then case ${with_tclconfig} in */tclConfig.sh ) if test -f ${with_tclconfig}; then AC_MSG_WARN([--with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself]) with_tclconfig=`echo ${with_tclconfig} | sed 's!/tclConfig\.sh$!!'` fi ;; esac if test -f "${with_tclconfig}/tclConfig.sh" ; then ac_cv_c_tclconfig=`(cd ${with_tclconfig}; pwd)` else AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh]) fi fi |
︙ | ︙ | |||
127 128 129 130 131 132 133 | # First, look for one uninstalled. # the alternative search directory is invoked by --with-tk # if test x"${no_tk}" = x ; then # we reset no_tk in case something fails here no_tk=true | > > | > > > > > > > > | 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 | # First, look for one uninstalled. # the alternative search directory is invoked by --with-tk # if test x"${no_tk}" = x ; then # we reset no_tk in case something fails here no_tk=true AC_ARG_WITH(tk, AC_HELP_STRING([--with-tk], [directory containing tk configuration (tkConfig.sh)]), with_tkconfig=${withval}) AC_MSG_CHECKING([for Tk configuration]) AC_CACHE_VAL(ac_cv_c_tkconfig,[ # First check to see if --with-tkconfig was specified. if test x"${with_tkconfig}" != x ; then case ${with_tkconfig} in */tkConfig.sh ) if test -f ${with_tkconfig}; then AC_MSG_WARN([--with-tk argument should refer to directory containing tkConfig.sh, not to tkConfig.sh itself]) with_tkconfig=`echo ${with_tkconfig} | sed 's!/tkConfig\.sh$!!'` fi ;; esac if test -f "${with_tkconfig}/tkConfig.sh" ; then ac_cv_c_tkconfig=`(cd ${with_tkconfig}; pwd)` else AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh]) fi fi |
︙ | ︙ | |||
247 248 249 250 251 252 253 254 255 256 257 258 259 260 | TCL_LIB_SPEC=${TCL_BUILD_LIB_SPEC} TCL_STUB_LIB_SPEC=${TCL_BUILD_STUB_LIB_SPEC} TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH} fi # # eval is required to do the TCL_DBGX substitution # eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\"" eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\"" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" | > | 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 | TCL_LIB_SPEC=${TCL_BUILD_LIB_SPEC} TCL_STUB_LIB_SPEC=${TCL_BUILD_STUB_LIB_SPEC} TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH} fi # # eval is required to do the TCL_DBGX substitution # (@@@ Is this still the case?) # eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\"" eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\"" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" |
︙ | ︙ | |||
301 302 303 304 305 306 307 308 309 310 311 312 313 314 | fi AC_SUBST(TK_VERSION) AC_SUBST(TK_BIN_DIR) AC_SUBST(TK_SRC_DIR) AC_SUBST(TK_LIB_FILE) ]) #------------------------------------------------------------------------ # SC_ENABLE_SHARED -- # # Allows the building of shared libraries # # Arguments: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | fi AC_SUBST(TK_VERSION) AC_SUBST(TK_BIN_DIR) AC_SUBST(TK_SRC_DIR) AC_SUBST(TK_LIB_FILE) ]) #------------------------------------------------------------------------ # SC_PROG_TCLSH # Locate a tclsh shell installed on the system path. This macro # will only find a Tcl shell that already exists on the system. # It will not find a Tcl shell in the Tcl build directory or # a Tcl shell that has been installed from the Tcl build directory. # If a Tcl shell can't be located on the PATH, then TCLSH_PROG will # be set to "". Extensions should take care not to create Makefile # rules that are run by default and depend on TCLSH_PROG. An # extension can't assume that an executable Tcl shell exists at # build time. # # Arguments # none # # Results # Subst's the following values: # TCLSH_PROG #------------------------------------------------------------------------ AC_DEFUN(SC_PROG_TCLSH, [ AC_MSG_CHECKING([for tclsh]) AC_CACHE_VAL(ac_cv_path_tclsh, [ search_path=`echo ${PATH} | sed -e 's/:/ /g'` for dir in $search_path ; do for j in `ls -r $dir/tclsh[[8-9]]* 2> /dev/null` \ `ls -r $dir/tclsh* 2> /dev/null` ; do if test x"$ac_cv_path_tclsh" = x ; then if test -f "$j" ; then ac_cv_path_tclsh=$j break fi fi done done ]) if test -f "$ac_cv_path_tclsh" ; then TCLSH_PROG="$ac_cv_path_tclsh" AC_MSG_RESULT($TCLSH_PROG) else # It is not an error if an installed version of Tcl can't be located. TCLSH_PROG="" AC_MSG_RESULT([No tclsh found on PATH]) fi AC_SUBST(TCLSH_PROG) ]) #------------------------------------------------------------------------ # SC_BUILD_TCLSH # Determine the fully qualified path name of the tclsh executable # in the Tcl build directory. This macro will correctly determine # the name of the tclsh executable even if tclsh has not yet # been built in the build directory. The build tclsh must be used # when running tests from an extension build directory. It is not # correct to use the TCLSH_PROG in cases like this. # # Arguments # none # # Results # Subst's the following values: # BUILD_TCLSH #------------------------------------------------------------------------ AC_DEFUN(SC_BUILD_TCLSH, [ AC_MSG_CHECKING([for tclsh in Tcl build directory]) BUILD_TCLSH=${TCL_BIN_DIR}/tclsh AC_MSG_RESULT($BUILD_TCLSH) AC_SUBST(BUILD_TCLSH) ]) #------------------------------------------------------------------------ # SC_ENABLE_SHARED -- # # Allows the building of shared libraries # # Arguments: |
︙ | ︙ | |||
326 327 328 329 330 331 332 | # Sets the following vars: # SHARED_BUILD Value of 1 or 0 #------------------------------------------------------------------------ AC_DEFUN(SC_ENABLE_SHARED, [ AC_MSG_CHECKING([how to build libraries]) AC_ARG_ENABLE(shared, | > | | 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | # Sets the following vars: # SHARED_BUILD Value of 1 or 0 #------------------------------------------------------------------------ AC_DEFUN(SC_ENABLE_SHARED, [ AC_MSG_CHECKING([how to build libraries]) AC_ARG_ENABLE(shared, AC_HELP_STRING([--enable-shared], [build and link with shared libraries (default: on)]), [tcl_ok=$enableval], [tcl_ok=yes]) if test "${enable_shared+set}" = set; then enableval="$enable_shared" tcl_ok=$enableval else tcl_ok=yes |
︙ | ︙ | |||
366 367 368 369 370 371 372 | # 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, | > | > > > > | 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 | # 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, AC_HELP_STRING([--enable-framework], [package shared libraries in MacOSX frameworks (default: off)]), [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 if test $tcl_corefoundation = no; then AC_MSG_WARN("Frameworks can only be used when CoreFoundation is available") FRAMEWORK_BUILD=0 fi else AC_MSG_RESULT([standard shared library]) FRAMEWORK_BUILD=0 fi ]) |
︙ | ︙ | |||
414 415 416 417 418 419 420 | # _REENTRANT # _THREAD_SAFE # #------------------------------------------------------------------------ AC_DEFUN(SC_ENABLE_THREADS, [ AC_MSG_CHECKING(for building with threads) | | > > < < < < | 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 | # _REENTRANT # _THREAD_SAFE # #------------------------------------------------------------------------ AC_DEFUN(SC_ENABLE_THREADS, [ AC_MSG_CHECKING(for building with threads) AC_ARG_ENABLE(threads, AC_HELP_STRING([--enable-threads], [build with threads (default: off)]), [tcl_ok=$enableval], [tcl_ok=no]) if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then if test "${TCL_THREADS}" = 1; then AC_MSG_RESULT([yes (threaded core)]) else AC_MSG_RESULT([yes]) fi TCL_THREADS=1 AC_DEFINE(TCL_THREADS, 1, [Are we building with threads enabled?]) # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention AC_DEFINE(USE_THREAD_ALLOC, 1, [Do we want to use the threaded memory allocator?]) AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) if test "`uname -s`" = "SunOS" ; then AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) fi AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?]) AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) |
︙ | ︙ | |||
510 511 512 513 514 515 516 | if test $tcl_cv_grep_pthread_getattr_np = missing ; then AC_DEFINE(GETATTRNP_NOT_DECLARED, 1, [Is pthread_getattr_np declared in <pthread.h>?]) fi fi fi LIBS=$ac_saved_libs | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 608 609 610 611 612 613 614 615 616 617 618 619 620 621 | if test $tcl_cv_grep_pthread_getattr_np = missing ; then AC_DEFINE(GETATTRNP_NOT_DECLARED, 1, [Is pthread_getattr_np declared in <pthread.h>?]) fi fi fi LIBS=$ac_saved_libs else TCL_THREADS=0 AC_MSG_RESULT([no (default)]) fi AC_SUBST(TCL_THREADS) ]) |
︙ | ︙ | |||
580 581 582 583 584 585 586 | # --enable-symbols # # Defines the following vars: # CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true # Sets to $(CFLAGS_OPTIMIZE) if false # LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true # Sets to $(LDFLAGS_OPTIMIZE) if false | | > | > > > > < < > > | | | | | | 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 | # --enable-symbols # # Defines the following vars: # CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true # Sets to $(CFLAGS_OPTIMIZE) if false # LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true # Sets to $(LDFLAGS_OPTIMIZE) if false # DBGX Formerly used as debug library extension; # always blank now. # #------------------------------------------------------------------------ AC_DEFUN(SC_ENABLE_SYMBOLS, [ AC_MSG_CHECKING([for build with symbols]) AC_ARG_ENABLE(symbols, AC_HELP_STRING([--enable-symbols], [build with debugging symbols (default: off)]), [tcl_ok=$enableval], [tcl_ok=no]) # FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. DBGX="" if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' AC_MSG_RESULT([no]) AC_DEFINE(TCL_CFG_OPTIMIZED, 1, [Is this an optimized build?]) else CFLAGS_DEFAULT='$(CFLAGS_DEBUG)' LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)' if test "$tcl_ok" = "yes"; then AC_MSG_RESULT([yes (standard debugging)]) fi fi AC_SUBST(CFLAGS_DEFAULT) AC_SUBST(LDFLAGS_DEFAULT) ### FIXME: Surely TCL_CFG_DEBUG should be set to whether we're debugging? AC_DEFINE(TCL_CFG_DEBUG, 1, [Is debugging enabled?]) if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then AC_DEFINE(TCL_MEM_DEBUG, 1, [Is memory debugging enabled?]) fi ifelse($1,bccdebug,dnl Only enable 'compile' for the Tcl core itself if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then AC_DEFINE(TCL_COMPILE_DEBUG, 1, [Is bytecode debugging enabled?]) AC_DEFINE(TCL_COMPILE_STATS, 1, [Are bytecode statistics enabled?]) fi) if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then if test "$tcl_ok" = "all"; then AC_MSG_RESULT([enabled symbols mem ]ifelse($1,bccdebug,[compile ])[debugging]) else AC_MSG_RESULT([enabled $tcl_ok debugging]) fi fi ]) #------------------------------------------------------------------------ |
︙ | ︙ | |||
645 646 647 648 649 650 651 | # Defines the following vars: # HAVE_LANGINFO Triggers use of nl_langinfo if defined. # #------------------------------------------------------------------------ AC_DEFUN(SC_ENABLE_LANGINFO, [ AC_ARG_ENABLE(langinfo, | | | | 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 | # Defines the following vars: # HAVE_LANGINFO Triggers use of nl_langinfo if defined. # #------------------------------------------------------------------------ AC_DEFUN(SC_ENABLE_LANGINFO, [ AC_ARG_ENABLE(langinfo, AC_HELP_STRING([--enable-langinfo], [use nl_langinfo if possible to determine encoding at startup, otherwise use old heuristic (default: on)]), [langinfo_ok=$enableval], [langinfo_ok=yes]) HAVE_LANGINFO=0 if test "$langinfo_ok" = "yes"; then if test "$langinfo_ok" = "yes"; then AC_CHECK_HEADER(langinfo.h,[langinfo_ok=yes],[langinfo_ok=no]) fi |
︙ | ︙ | |||
695 696 697 698 699 700 701 702 | # # Defines the following variable: # # MAN_FLAGS - The apropriate flags for installManPage # according to the user's selection. # #-------------------------------------------------------------------- AC_DEFUN(SC_CONFIG_MANPAGES, [ | > < | | | | | | | | | | | > | > | > | | | | | | | | | | | | | | | > | > | > | | | | 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 | # # Defines the following variable: # # MAN_FLAGS - The apropriate flags for installManPage # according to the user's selection. # #-------------------------------------------------------------------- AC_DEFUN(SC_CONFIG_MANPAGES, [ AC_MSG_CHECKING([whether to use symlinks for manpages]) AC_ARG_ENABLE(man-symlinks, AC_HELP_STRING([--enable-man-symlinks], [use symlinks for the manpages (default: off)]), test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks", enableval="no") AC_MSG_RESULT([$enableval]) AC_MSG_CHECKING([whether to compress the manpages]) AC_ARG_ENABLE(man-compression, AC_HELP_STRING([--enable-man-compression=PROG], [compress the manpages with PROG (default: off)]), [case $enableval in yes) AC_MSG_ERROR([missing argument to --enable-man-compression]);; no) ;; *) MAN_FLAGS="$MAN_FLAGS --compress $enableval";; esac], enableval="no") AC_MSG_RESULT([$enableval]) if test "$enableval" != "no"; then AC_MSG_CHECKING([for compressed file suffix]) touch TeST $enableval TeST Z=`ls TeST* | sed 's/^....//'` rm -f TeST* MAN_FLAGS="$MAN_FLAGS --extension $Z" AC_MSG_RESULT([$Z]) fi AC_MSG_CHECKING([whether to add a package name suffix for the manpages]) AC_ARG_ENABLE(man-suffix, AC_HELP_STRING([--enable-man-suffix=STRING], [use STRING as a suffix to manpage file names (default: no, AC_PACKAGE_NAME if enabled without specifying STRING)]), [case $enableval in yes) enableval="AC_PACKAGE_NAME";; no) ;; *) MAN_FLAGS="$MAN_FLAGS --suffix $enableval";; esac], enableval="no") AC_MSG_RESULT([$enableval]) AC_SUBST(MAN_FLAGS) ]) #-------------------------------------------------------------------- # SC_CONFIG_CFLAGS # # Try to determine the proper flags to pass to the compiler # for building shared libraries and other such nonsense. |
︙ | ︙ | |||
779 780 781 782 783 784 785 | # 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. | < < < | 851 852 853 854 855 856 857 858 859 860 861 862 863 864 | # STLIB_LD - Base command to use for combining object files # into a static library. # SHLIB_CFLAGS - Flags to pass to cc when compiling the components # of a shared library (may request position-independent # code, among other things). # SHLIB_LD - Base command to use for combining object files # into a shared library. # SHLIB_LD_LIBS - Dependent libraries for the linker to scan when # creating shared libraries. This symbol typically # goes at the end of the "ld" commands that build # shared libraries. The value of the symbol is # "${LIBS}" if all of the dependent libraries should # be specified when creating a shared library. If # dependent libraries should not be specified (as on |
︙ | ︙ | |||
839 840 841 842 843 844 845 | #-------------------------------------------------------------------- AC_DEFUN(SC_CONFIG_CFLAGS, [ # Step 0.a: Enable 64 bit support? AC_MSG_CHECKING([if 64bit support is requested]) | | > > > | > > > | 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 | #-------------------------------------------------------------------- AC_DEFUN(SC_CONFIG_CFLAGS, [ # Step 0.a: Enable 64 bit support? AC_MSG_CHECKING([if 64bit support is requested]) AC_ARG_ENABLE(64bit, AC_HELP_STRING([--enable-64bit], [enable 64bit support (default: off)]), ,enableval="no") if test "$enableval" = "yes"; then do64bit=yes else do64bit=no fi AC_MSG_RESULT($do64bit) # Step 0.b: Enable Solaris 64 bit VIS support? AC_MSG_CHECKING([if 64bit Sparc VIS support is requested]) AC_ARG_ENABLE(64bit-vis, AC_HELP_STRING([--enable-64bit-vis], [enable 64bit Sparc VIS support (default: off)]), ,enableval="no") if test "$enableval" = "yes"; then # Force 64bit on with VIS do64bit=yes do64bitVIS=yes else do64bitVIS=no |
︙ | ︙ | |||
929 930 931 932 933 934 935 936 | AC_CHECK_PROG(AR, ar, ar) if test "${AR}" = "" ; then AC_MSG_ERROR([Required archive tool 'ar' not found on PATH.]) fi STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" PLAT_OBJS="" case $system in | > | | < < | | | | 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 | AC_CHECK_PROG(AR, ar, ar) if test "${AR}" = "" ; then AC_MSG_ERROR([Required archive tool 'ar' not found on PATH.]) fi STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" PLAT_OBJS="" PLAT_SRCS="" case $system in AIX-*) if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then # AIX requires the _r compiler when gcc isn't being used if test "${CC}" != "cc_r" ; then CC=${CC}_r fi AC_MSG_RESULT([Using $CC for compiling with threads]) fi LIBS="$LIBS -lc" SHLIB_CFLAGS="" # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" LD_LIBRARY_PATH_VAR="LIBPATH" # Check to enable 64-bit flags for compiler/linker on AIX 4+ if test "$do64bit" = "yes" -a "`uname -v`" -gt "3" ; then if test "$GCC" = "yes" ; then AC_MSG_WARN([64bit mode not supported with GCC on $system]) else do64bit_ok=yes CFLAGS="$CFLAGS -q64" LDFLAGS_ARCH="-q64" RANLIB="${RANLIB} -X64" AR="${AR} -X64" SHLIB_LD_FLAGS="-b64" |
︙ | ︙ | |||
976 977 978 979 980 981 982 | if test "$GCC" = "yes" ; then CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' else CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' else | > > > | > > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | if test "$GCC" = "yes" ; then CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' else CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' else if test "$GCC" = "yes" ; then SHLIB_LD="gcc -shared" else SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" fi SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix ${SHLIB_LD} ${SHLIB_LD_FLAGS}" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}.exp' fi # AIX v<=4.1 has some different flags than 4.2+ if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then AC_LIBOBJ([tclLoadAix]) DL_LIBS="-lld" fi # On AIX <=v4 systems, libbsd.a has to be linked in to support # non-blocking file IO. This library has to be linked in after # the MATH_LIBS or it breaks the pow() function. The way to # insure proper sequencing, is to add it to the tail of MATH_LIBS. # This library also supplies gettimeofday. # # AIX does not have a timezone field in struct tm. When the AIX |
︙ | ︙ | |||
1111 1112 1113 1114 1115 1116 1117 | CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi if test "$GCC" = "yes" ; then SHLIB_LD="gcc -shared" SHLIB_LD_LIBS='${LIBS}' | | < | | | 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 | CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi if test "$GCC" = "yes" ; then SHLIB_LD="gcc -shared" SHLIB_LD_LIBS='${LIBS}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc #CFLAGS="$CFLAGS +DAportable" # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" ; then if test "$GCC" = "yes" ; then hpux_arch=`gcc -dumpmachine` case $hpux_arch in hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD="gcc -shared" SHLIB_LD_LIBS='${LIBS}' CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) AC_MSG_WARN("64bit mode not supported with GCC on $system") ;; esac else do64bit_ok=yes |
︙ | ︙ | |||
1157 1158 1159 1160 1161 1162 1163 | DL_LIBS="-ldld" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi ;; | < < < < < < < < < < < < | 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 | DL_LIBS="-ldld" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi ;; IRIX-5.*) SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" |
︙ | ︙ | |||
1318 1319 1320 1321 1322 1323 1324 | DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,-Bexport" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; NetBSD-*|FreeBSD-[[1-2]].*) | < < | | | | | | | | | | | | | | | | | < < < < < < < < < < < | | > > > > > > > | | | | > | | | | | | 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 | DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,-Bexport" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; NetBSD-*|FreeBSD-[[1-2]].*) # 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="" 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}.so', AC_MSG_RESULT(no) SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' ) # Ancient FreeBSD doesn't handle version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; OpenBSD-*) # OpenBSD/SPARC[64] needs -fPIC, -fpic will not do. case `machine` in sparc|sparc64) SHLIB_CFLAGS="-fPIC";; *) SHLIB_CFLAGS="-fpic";; esac SHLIB_LD="${CC} -shared ${SHLIB_CFLAGS}" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' AC_MSG_CHECKING(for ELF) AC_EGREP_CPP(yes, [ #ifdef __ELF__ yes #endif ], AC_MSG_RESULT(yes) [ LDFLAGS=-Wl,-export-dynamic ], AC_MSG_RESULT(no) LDFLAGS="" ) # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.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}' |
︙ | ︙ | |||
1401 1402 1403 1404 1405 1406 1407 | LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" fi case $system in FreeBSD-3.*) # FreeBSD-3 doesn't handle version numbers with dots. | | | | > < | > > > > > > > < | > > > > > > > > < > > > > > > > > > > > > > > > > > > | | > > > > > < > > > > > > > > > | 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 | LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" fi case $system in FreeBSD-3.*) # FreeBSD-3 doesn't handle version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' TCL_LIB_VERSIONS_OK=nodots ;; esac ;; Darwin-*) CFLAGS_OPTIMIZE="-Os" SHLIB_CFLAGS="-fno-common" SHLIB_LD="cc -dynamiclib \${LDFLAGS}" AC_CACHE_CHECK([if ld accepts -single_module flag], tcl_cv_ld_single_module, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module" AC_TRY_LINK(, [int i;], tcl_cv_ld_single_module=yes, tcl_cv_ld_single_module=no) LDFLAGS=$hold_ldflags]) if test $tcl_cv_ld_single_module = yes; then SHLIB_LD="${SHLIB_LD} -Wl,-single_module" fi SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".dylib" DL_OBJS="tclLoadDyld.o" DL_LIBS="" LDFLAGS="$LDFLAGS -prebind -headerpad_max_install_names" AC_CACHE_CHECK([if ld accepts -search_paths_first flag], tcl_cv_ld_search_paths_first, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-search_paths_first" AC_TRY_LINK(, [int i;], tcl_cv_ld_search_paths_first=yes, tcl_cv_ld_search_paths_first=no) LDFLAGS=$hold_ldflags]) if test $tcl_cv_ld_search_paths_first = yes; then LDFLAGS="$LDFLAGS -Wl,-search_paths_first" fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" PLAT_OBJS='${MAC_OSX_OBJS}' PLAT_SRCS='${MAC_OSX_SRCS}' AC_MSG_CHECKING([whether to use CoreFoundation]) AC_ARG_ENABLE(corefoundation, AC_HELP_STRING([--enable-corefoundation], [use CoreFoundation API on MacOSX (default: yes)]), [tcl_corefoundation=$enableval], [tcl_corefoundation=yes]) AC_MSG_RESULT([$tcl_corefoundation]) if test $tcl_corefoundation = yes; then AC_CACHE_CHECK([for CoreFoundation.framework], tcl_cv_lib_corefoundation, [ hold_libs=$LIBS LIBS="$LIBS -framework CoreFoundation" AC_TRY_LINK([#include <CoreFoundation/CoreFoundation.h>], [CFBundleRef b = CFBundleGetMainBundle();], tcl_cv_lib_corefoundation=yes, tcl_cv_lib_corefoundation=no) LIBS=$hold_libs]) if test $tcl_cv_lib_corefoundation = yes; then LIBS="$LIBS -framework CoreFoundation" AC_DEFINE(HAVE_COREFOUNDATION, 1, [Do we have access to Darwin CoreFoundation.framework ?]) fi fi AC_CHECK_HEADERS(libkern/OSAtomic.h) AC_CHECK_FUNCS(OSSpinLockLock) AC_DEFINE(MAC_OSX_TCL, 1, [Is this a Mac I see before me?]) AC_DEFINE(USE_VFORK, 1, [Should we use vfork() instead of fork()?]) AC_DEFINE(TCL_DEFAULT_ENCODING,"utf-8", [Are we to override what our default encoding is?]) AC_DEFINE(MODULE_SCOPE, __private_extern__, [Linker support for module scope symbols]) AC_DEFINE(TCL_LOAD_FROM_MEMORY, 1, [Can this platform load code from memory?]) # prior to Darwin 7, realpath is not threadsafe, so don't # use it when threads are enabled, c.f. bug # 711232: AC_CHECK_FUNC(realpath) if test "$ac_cv_func_realpath" = yes -a "${TCL_THREADS}" = 1 \ -a `uname -r | awk -F. '{print [$]1}'` -lt 7 ; then ac_cv_func_realpath=no fi ;; NEXTSTEP-*) SHLIB_CFLAGS="" SHLIB_LD="cc -nostdlib -r" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadNext.o" |
︙ | ︙ | |||
1517 1518 1519 1520 1521 1522 1523 | SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" # dlopen is in -lc on QNX DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; | < < < < < < < < < < < | 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 | SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" # dlopen is in -lc on QNX DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SCO_SV-3.2*) # Note, dlopen is available only on SCO 3.2.5 and greater. However, # this test works, since "uname -s" was non-standard in 3.2.4 and # below. if test "$GCC" = "yes" ; then SHLIB_CFLAGS="-fPIC -melf" LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" |
︙ | ︙ | |||
1572 1573 1574 1575 1576 1577 1578 | 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 | | | | > | 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 | 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}.so.1.0' UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; SunOS-5.[[0-6]]) # Careful to not let 5.10+ fall into this case # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) |
︙ | ︙ | |||
1605 1606 1607 1608 1609 1610 1611 | 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*) | < | > | > > > > > > > > > | > > > > > | > > > > > > > > > < < < < < < < < < < < < < < | 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 | 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, 1, [Do we want the reentrant OS API?]) AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) SHLIB_CFLAGS="-KPIC" # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" ; then arch=`isainfo` if test "$arch" = "sparcv9 sparc" ; then if test "$GCC" = "yes" ; then if test "`gcc -dumpversion | awk -F. '{print [$]1}'`" -lt "3" ; then AC_MSG_WARN([64bit mode not supported with GCC < 3.2 on $system]) else do64bit_ok=yes CFLAGS="$CFLAGS -m64 -mcpu=v9" LDFLAGS="$LDFLAGS -m64 -mcpu=v9" SHLIB_CFLAGS="-fPIC" fi else do64bit_ok=yes if test "$do64bitVIS" = "yes" ; then CFLAGS="$CFLAGS -xarch=v9a" LDFLAGS_ARCH="-xarch=v9a" else CFLAGS="$CFLAGS -xarch=v9" LDFLAGS_ARCH="-xarch=v9" fi fi elif test "$arch" = "amd64 i386" ; then if test "$GCC" = "yes" ; then AC_MSG_WARN([64bit mode not supported with GCC on $system]) else do64bit_ok=yes CFLAGS="$CFLAGS -xarch=amd64" LDFLAGS="$LDFLAGS -xarch=amd64" fi else AC_MSG_WARN([64bit mode not supported for $arch]) fi fi # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" if test "$GCC" = "yes" ; then SHLIB_LD="$CC -shared" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} if test "$do64bit_ok" = "yes" ; then # We need to specify -static-libgcc or we need to # add the path to the sparv9 libgcc. SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" # for finding sparcv9 libgcc, get the regular libgcc # path, remove so name and append 'sparcv9' #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" fi else SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' fi ;; UNIX_SV* | UnixWare-5*) SHLIB_CFLAGS="-KPIC" SHLIB_LD="cc -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" |
︙ | ︙ | |||
1688 1689 1690 1691 1692 1693 1694 | AC_MSG_RESULT($found) CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; esac if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > | | 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 | AC_MSG_RESULT($found) 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 if test "$do64bit" = "yes" -a "$do64bit_ok" = "yes" ; then AC_DEFINE(TCL_CFG_DO64BIT, 1, [Is this a 64-bit build?]) fi # Step 4: disable dynamic loading if requested via a command-line switch. AC_ARG_ENABLE(load, AC_HELP_STRING([--disable-load], [disallow dynamic loading and "load" command (default: enabled)]), [tcl_ok=$enableval], [tcl_ok=yes]) if test "$tcl_ok" = "no"; then DL_OBJS="" fi if test "x$DL_OBJS" != "x" ; then BUILD_DLTEST="\$(DLTEST_TARGETS)" |
︙ | ︙ | |||
1815 1816 1817 1818 1819 1820 1821 | ;; BSD/OS*) ;; IRIX*) ;; NetBSD-*|FreeBSD-*) ;; | | | | | | 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 | ;; BSD/OS*) ;; IRIX*) ;; NetBSD-*|FreeBSD-*) ;; Darwin-*) ;; RISCos-*) ;; SCO_SV-3.2*) ;; ULTRIX-4.*) ;; *) SHLIB_CFLAGS="-fPIC" ;; esac fi fi if test "$SHARED_LIB_SUFFIX" = "" ; then SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' fi if test "$UNSHARED_LIB_SUFFIX" = "" ; then UNSHARED_LIB_SUFFIX='${VERSION}.a' fi if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then LIB_SUFFIX=${SHARED_LIB_SUFFIX} MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)' else LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} if test "$RANLIB" = "" ; then MAKE_LIB='$(STLIB_LD) [$]@ ${OBJS}' INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)' |
︙ | ︙ | |||
1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 | # FIXME: This subst was left in only because the TCL_DL_LIBS # entry in tclConfig.sh uses it. It is not clear why someone # would use TCL_DL_LIBS instead of TCL_LIBS. 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(LDFLAGS) AC_SUBST(LDFLAGS_DEBUG) AC_SUBST(LDFLAGS_OPTIMIZE) AC_SUBST(CC_SEARCH_FLAGS) AC_SUBST(LD_SEARCH_FLAGS) AC_SUBST(STLIB_LD) AC_SUBST(SHLIB_LD) AC_SUBST(TCL_SHLIB_LD_EXTRAS) AC_SUBST(TK_SHLIB_LD_EXTRAS) | > < | 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 | # FIXME: This subst was left in only because the TCL_DL_LIBS # entry in tclConfig.sh uses it. It is not clear why someone # would use TCL_DL_LIBS instead of TCL_LIBS. AC_SUBST(DL_LIBS) AC_SUBST(DL_OBJS) AC_SUBST(PLAT_OBJS) AC_SUBST(PLAT_SRCS) AC_SUBST(CFLAGS) AC_SUBST(CFLAGS_DEBUG) AC_SUBST(CFLAGS_OPTIMIZE) AC_SUBST(CFLAGS_WARNING) AC_SUBST(LDFLAGS) AC_SUBST(LDFLAGS_DEBUG) AC_SUBST(LDFLAGS_OPTIMIZE) AC_SUBST(CC_SEARCH_FLAGS) AC_SUBST(LD_SEARCH_FLAGS) AC_SUBST(STLIB_LD) AC_SUBST(SHLIB_LD) AC_SUBST(TCL_SHLIB_LD_EXTRAS) AC_SUBST(TK_SHLIB_LD_EXTRAS) AC_SUBST(SHLIB_LD_LIBS) AC_SUBST(SHLIB_CFLAGS) AC_SUBST(SHLIB_SUFFIX) AC_DEFINE_UNQUOTED(TCL_SHLIB_EXT,"${SHLIB_SUFFIX}", [What is the default extension for shared libraries?]) AC_SUBST(MAKE_LIB) |
︙ | ︙ | |||
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 | # # HAVE_STRING_H ? # #-------------------------------------------------------------------- AC_DEFUN(SC_MISSING_POSIX_HEADERS, [ AC_MSG_CHECKING(dirent.h) AC_TRY_LINK([#include <sys/types.h> #include <dirent.h>], [ #ifndef _POSIX_SOURCE # ifdef __Lynx__ /* * Generate compilation error to make the test fail: Lynx headers * are only valid if really in the POSIX environment. */ missing_procedure(); # endif #endif DIR *d; struct dirent *entryPtr; char *p; d = opendir("foobar"); entryPtr = readdir(d); p = entryPtr->d_name; closedir(d); | > | | | 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 | # # HAVE_STRING_H ? # #-------------------------------------------------------------------- AC_DEFUN(SC_MISSING_POSIX_HEADERS, [ AC_MSG_CHECKING(dirent.h) AC_CACHE_VAL(tcl_cv_dirent_h, AC_TRY_LINK([#include <sys/types.h> #include <dirent.h>], [ #ifndef _POSIX_SOURCE # ifdef __Lynx__ /* * Generate compilation error to make the test fail: Lynx headers * are only valid if really in the POSIX environment. */ missing_procedure(); # endif #endif DIR *d; struct dirent *entryPtr; char *p; d = opendir("foobar"); entryPtr = readdir(d); p = entryPtr->d_name; closedir(d); ], tcl_cv_dirent_h=yes, tcl_cv_dirent_h=no)) if test $tcl_cv_dirent_h = no; then AC_DEFINE(NO_DIRENT_H, 1, [Do we have <dirent.h>?]) fi AC_MSG_RESULT($tcl_ok) AC_CHECK_HEADER(errno.h, , [AC_DEFINE(NO_ERRNO_H, 1, [Do we have <errno.h>?])]) AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have <float.h>?])]) AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have <values.h>?])]) |
︙ | ︙ | |||
2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 | AC_CHECK_LIB(Xwindow, XCreateWindow, XLIBSW=-lXwindow) fi if test "$XLIBSW" = nope ; then AC_MSG_RESULT(couldn't find any! Using -lX11.) XLIBSW=-lX11 fi ]) #-------------------------------------------------------------------- # SC_BLOCKING_STYLE # # The statements below check for systems where POSIX-style # non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. # On these systems (mostly older ones), use the old BSD-style # FIONBIO approach instead. | > | 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 | AC_CHECK_LIB(Xwindow, XCreateWindow, XLIBSW=-lXwindow) fi if test "$XLIBSW" = nope ; then AC_MSG_RESULT(couldn't find any! Using -lX11.) XLIBSW=-lX11 fi ]) #-------------------------------------------------------------------- # SC_BLOCKING_STYLE # # The statements below check for systems where POSIX-style # non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. # On these systems (mostly older ones), use the old BSD-style # FIONBIO approach instead. |
︙ | ︙ | |||
2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 | AC_DEFUN(SC_TCL_EARLY_FLAGS,[ AC_MSG_CHECKING([for required early compiler flags]) tcl_flags="" SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include <stdlib.h>], [char *p = (char *)strtoll; char *q = (char *)strtoull;]) SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include <sys/stat.h>], [struct stat64 buf; int i = stat64("/", &buf);]) if test "x${tcl_flags}" = "x" ; then AC_MSG_RESULT(none) else AC_MSG_RESULT(${tcl_flags}) fi]) #-------------------------------------------------------------------- | > > | 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 | AC_DEFUN(SC_TCL_EARLY_FLAGS,[ AC_MSG_CHECKING([for required early compiler flags]) tcl_flags="" SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include <stdlib.h>], [char *p = (char *)strtoll; char *q = (char *)strtoull;]) SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include <sys/stat.h>], [struct stat64 buf; int i = stat64("/", &buf);]) SC_TCL_EARLY_FLAG(_LARGEFILE_SOURCE64,[#include <sys/stat.h>], [char *p = (char *)open64;]) if test "x${tcl_flags}" = "x" ; then AC_MSG_RESULT(none) else AC_MSG_RESULT(${tcl_flags}) fi]) #-------------------------------------------------------------------- |
︙ | ︙ | |||
2628 2629 2630 2631 2632 2633 2634 | # # Will define the following vars: # TCL_CFGVAL_ENCODING # #-------------------------------------------------------------------- AC_DEFUN(SC_TCL_CFG_ENCODING, [ | | > > > | 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 | # # Will define the following vars: # TCL_CFGVAL_ENCODING # #-------------------------------------------------------------------- AC_DEFUN(SC_TCL_CFG_ENCODING, [ AC_ARG_WITH(encoding, AC_HELP_STRING([--with-encoding], [encoding for configuration values (default: iso8859-1)]), with_tcencoding=${withval}) if test x"${with_tcencoding}" != x ; then AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}", [What encoding should be used for embedded configuration info?]) else AC_DEFINE(TCL_CFGVAL_ENCODING,"iso8859-1", [What encoding should be used for embedded configuration info?]) |
︙ | ︙ |
Changes to unix/tcl.spec.
|
| | | | 1 2 3 4 5 6 7 8 9 10 11 | # $Id: tcl.spec,v 1.20.2.2 2005/07/12 20:37:29 kennykb Exp $ # This file is the basis for a binary Tcl RPM for Linux. %define version 8.5a4 %define directory /usr/local Summary: Tcl scripting language development environment Name: tcl Version: %{version} Release: 1 Copyright: BSD |
︙ | ︙ |
Changes to unix/tclAppInit.c.
|
| | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit * function for Tcl applications (without Tk). * * Copyright (c) 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: tclAppInit.c,v 1.15.2.1 2005/08/02 18:16:54 dgp Exp $ */ #include "tcl.h" #ifdef TCL_TEST #include "tclInt.h" |
︙ | ︙ | |||
36 37 38 39 40 41 42 | *---------------------------------------------------------------------- * * main -- * * This is the main program for the application. * * Results: | | | | | < | > | | 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 | *---------------------------------------------------------------------- * * main -- * * This is the main program for the application. * * Results: * None: Tcl_Main never returns here, so this function never returns * either. * * Side effects: * Whatever the application does. * *---------------------------------------------------------------------- */ int main(argc, argv) int argc; /* Number of command-line arguments. */ char **argv; /* Values of command-line arguments. */ { /* * The following #if block allows you to change the AppInit function by * using a #define of TCL_LOCAL_APPINIT instead of rewriting this entire * file. The #if checks for that #define and uses Tcl_AppInit if it does * not exist. */ #ifndef TCL_LOCAL_APPINIT #define TCL_LOCAL_APPINIT Tcl_AppInit #endif extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp)); /* * The following #if block allows you to change how Tcl finds the startup * script, prime the library or encoding paths, fiddle with the argv, * etc., without needing to rewrite Tcl_Main() |
︙ | ︙ | |||
90 91 92 93 94 95 96 | } /* *---------------------------------------------------------------------- * * Tcl_AppInit -- * | | | | | | | | | | | | | | > | | | | | | > > > > > > > > > | 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 | } /* *---------------------------------------------------------------------- * * Tcl_AppInit -- * * This function performs application-specific initialization. Most * applications, especially those that incorporate additional packages, * will have their own version of this function. * * Results: * Returns a standard Tcl completion code, and leaves an error message in * the interp's result if an error occurs. * * Side effects: * Depends on the startup script. * *---------------------------------------------------------------------- */ int Tcl_AppInit(interp) Tcl_Interp *interp; /* Interpreter for application. */ { if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } #ifdef TCL_TEST #ifdef TCL_XT_TEST if (Tclxttest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } #endif if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, (Tcl_PackageInitProc *) NULL); if (TclObjTest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (Procbodytest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init, Procbodytest_SafeInit); #endif /* TCL_TEST */ /* * Call the init functions for included packages. Each call should look * like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * where "Mod" is the name of the module. (Dynamically-loadable packages * should have the same entry-point name.) */ /* * Call Tcl_CreateCommand for application-specific commands, if they * weren't already created by the init functions called above. */ /* * Specify a user-specific startup file to invoke if the application is * run interactively. Typically the startup file is "~/.apprc" where "app" * is the name of the application. If this line is deleted then no user- * specific startup file will be run under any conditions. */ #ifdef DJGPP Tcl_SetVar(interp, "tcl_rcFileName", "~/tclsh.rc", TCL_GLOBAL_ONLY); #else Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); #endif return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclConfig.h.in.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* tclConfig.h.in. Generated from configure.in by autoheader. */ /* Is pthread_attr_get_np() declared in <pthread.h>? */ #undef ATTRGETNP_NOT_DECLARED /* Is pthread_getattr_np declared in <pthread.h>? */ #undef GETATTRNP_NOT_DECLARED /* Is gettimeofday() actually declared in <sys/time.h>? */ #undef GETTOD_NOT_DECLARED /* Do we have BSDgettimeofday()? */ #undef HAVE_BSDGETTIMEOFDAY | > > > | | | | > > > > > > > > > > > > < < < < < < | 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 | /* tclConfig.h.in. Generated from configure.in by autoheader. */ #ifndef _TCLCONFIG #define _TCLCONFIG /* Is pthread_attr_get_np() declared in <pthread.h>? */ #undef ATTRGETNP_NOT_DECLARED /* Is pthread_getattr_np declared in <pthread.h>? */ #undef GETATTRNP_NOT_DECLARED /* Is gettimeofday() actually declared in <sys/time.h>? */ #undef GETTOD_NOT_DECLARED /* Do we have BSDgettimeofday()? */ #undef HAVE_BSDGETTIMEOFDAY /* Define to 1 if you have the `chflags' function. */ #undef HAVE_CHFLAGS /* Do we have access to Darwin CoreFoundation.framework ? */ #undef HAVE_COREFOUNDATION /* Define to 1 if you have the `getattrlist' function. */ #undef HAVE_GETATTRLIST /* Define to 1 if you have the `getcwd' function. */ #undef HAVE_GETCWD /* Define to 1 if you have the `gmtime_r' function. */ #undef HAVE_GMTIME_R /* Define to 1 if you have the <inttypes.h> header file. */ #undef HAVE_INTTYPES_H /* Do we have nl_langinfo()? */ #undef HAVE_LANGINFO /* Define to 1 if you have the <libkern/OSAtomic.h> header file. */ #undef HAVE_LIBKERN_OSATOMIC_H /* Do we have <limits.h>? */ #undef HAVE_LIMITS_H /* Define to 1 if you have the `localtime_r' function. */ #undef HAVE_LOCALTIME_R /* Define to 1 if you have the `lseek64' function. */ #undef HAVE_LSEEK64 /* Define to 1 if you have the <memory.h> header file. */ #undef HAVE_MEMORY_H /* Define to 1 if you have the `mktime' function. */ #undef HAVE_MKTIME /* Do we have <net/errno.h>? */ #undef HAVE_NET_ERRNO_H /* Define to 1 if you have the `open64' function. */ #undef HAVE_OPEN64 /* Define to 1 if you have the `opendir' function. */ #undef HAVE_OPENDIR /* Define to 1 if you have the `OSSpinLockLock' function. */ #undef HAVE_OSSPINLOCKLOCK /* Do we want a BSD-like thread-attribute interface? */ #undef HAVE_PTHREAD_ATTR_GET_NP /* Define to 1 if you have the `pthread_attr_setstacksize' function. */ #undef HAVE_PTHREAD_ATTR_SETSTACKSIZE /* Do we want a Linux-like thread-attribute interface? */ #undef HAVE_PTHREAD_GETATTR_NP /* Does putenv() copy strings or incorporate them by reference? */ #undef HAVE_PUTENV_THAT_COPIES /* Are characters signed? */ #undef HAVE_SIGNED_CHAR /* Define to 1 if you have the <stdint.h> header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the <stdlib.h> header file. */ #undef HAVE_STDLIB_H /* Define to 1 if you have the <strings.h> header file. */ #undef HAVE_STRINGS_H /* Define to 1 if you have the <string.h> header file. */ #undef HAVE_STRING_H /* Define to 1 if you have the `strtol' function. */ #undef HAVE_STRTOL /* Define to 1 if you have the `strtoll' function. */ #undef HAVE_STRTOLL /* Define to 1 if you have the `strtoull' function. */ |
︙ | ︙ | |||
158 159 160 161 162 163 164 | /* Define to 1 if you have the <unistd.h> header file. */ #undef HAVE_UNISTD_H /* Define to 1 if you have the `waitpid' function. */ #undef HAVE_WAITPID | | > > > | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 | /* Define to 1 if you have the <unistd.h> header file. */ #undef HAVE_UNISTD_H /* Define to 1 if you have the `waitpid' function. */ #undef HAVE_WAITPID /* Is this a Mac I see before me? */ #undef MAC_OSX_TCL /* Linker support for module scope symbols */ #undef MODULE_SCOPE /* Do we have <dirent.h>? */ #undef NO_DIRENT_H /* Do we have <dlfcn.h>? */ #undef NO_DLFCN_H |
︙ | ︙ | |||
260 261 262 263 264 265 266 | /* Is bytecode debugging enabled? */ #undef TCL_COMPILE_DEBUG /* Are bytecode statistics enabled? */ #undef TCL_COMPILE_STATS | < < < > > > | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 | /* Is bytecode debugging enabled? */ #undef TCL_COMPILE_DEBUG /* Are bytecode statistics enabled? */ #undef TCL_COMPILE_STATS /* Are we to override what our default encoding is? */ #undef TCL_DEFAULT_ENCODING /* Is Tcl built as a framework? */ #undef TCL_FRAMEWORK /* Can this platform load code from memory? */ #undef TCL_LOAD_FROM_MEMORY /* Is memory debugging enabled? */ #undef TCL_MEM_DEBUG /* What is the default extension for shared libraries? */ #undef TCL_SHLIB_EXT |
︙ | ︙ | |||
296 297 298 299 300 301 302 | /* Define to 1 if your <sys/time.h> declares `struct tm'. */ #undef TM_IN_SYS_TIME /* Is getcwd Posix-compliant? */ #undef USEGETWD | < < < < < < < < < < < < | 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 | /* Define to 1 if your <sys/time.h> declares `struct tm'. */ #undef TM_IN_SYS_TIME /* Is getcwd Posix-compliant? */ #undef USEGETWD /* Do we need a special AIX hack for timezones? */ #undef USE_DELTA_FOR_TZ /* May we include <dirent2.h>? */ #undef USE_DIRENT2_H /* Should we use FIONBIO? */ #undef USE_FIONBIO /* Use the sgtty API for serial lines */ #undef USE_SGTTY /* Use the termio API for serial lines */ #undef USE_TERMIO /* Use the termios API for serial lines */ #undef USE_TERMIOS /* Do we want to use the threaded memory allocator? */ #undef USE_THREAD_ALLOC /* Should we use vfork() instead of fork()? */ #undef USE_VFORK /* Define to 1 if your processor stores words with the most significant byte first (like Motorola and SPARC, unlike Intel and VAX). */ #undef WORDS_BIGENDIAN |
︙ | ︙ | |||
385 386 387 388 389 390 391 | #undef socklen_t /* Do we want to use the strtod() in compat? */ #undef strtod /* Define to `int' if <sys/types.h> doesn't define. */ #undef uid_t | > > | 385 386 387 388 389 390 391 392 393 | #undef socklen_t /* Do we want to use the strtod() in compat? */ #undef strtod /* Define to `int' if <sys/types.h> doesn't define. */ #undef uid_t #endif /* _TCLCONFIG */ |
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 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | # 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.19.2.1 2005/01/20 14:53:40 kennykb 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@' # C compiler to use for compilation. TCL_CC='@CC@' # -D flags for use with the C compiler. TCL_DEFS='@DEFS@' # TCL_DBGX used to be used to distinguish debug vs. non-debug builds. # This was a righteous pain so the core doesn't do that any more. TCL_DBGX= # Default flags used in an optimized and debuggable build, respectively. TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@' TCL_CFLAGS_OPTIMIZE='@CFLAGS_OPTIMIZE@' # Default linker flags used in an optimized and debuggable build, respectively. TCL_LDFLAGS_DEBUG='@LDFLAGS_DEBUG@' |
︙ | ︙ |
Changes to unix/tclLoadAix.c.
1 2 3 | /* * tclLoadAix.c -- * | | | | | | | | | | | | | < | | | | > | | > | | | | | | | | | | > | | > | > | | | | | | | | > | | > | > | | > | | | > | | | | | > > | > | | | | | > | | > | | | | > | > | | | | | | > | | | < | > | | > | | | < | | | > | | > | | > | | | > | > | | | | | | > | | | | > | | > | | < < | < < | > > | | | > > > > > > > > > > > > > | | < < < < < < < < | | | > | | | | | | | > > | | | | > | > | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | > | | | > > > | | | | | > | | | | | | | > | | | | | | > > | | > > | | | | | > > | | | | | > | | | | | | > > | | > | | | | | | | | > > | | | | | > | | | | > > > | | | | | | | | > > > > | > | | | > | | < < < | > | | < | | > > > | < | < | | > | > > > > | < | | < < < | | < < < < < < | | | | < | > | | | | | | | | | | | > > | > | | < < < | | > | < | < < < | > | | | | | < < < < | < > > | > | < | < < < | > | | | | < < < < < | > > | | > | > > > < < < < | < < | < < | < < < > | > | | > | | | > | | | > | | > | > > > > < < < < < | < < | | | | > | | | | | > | | > > | | | | | | | | > | | | | | | | | | | | | > > > | > > > > > > > > > > > > > > > | | | | > | > | | | | | | < | | < | > | | | | > > > > > > > > > > > > > > > > > > > > > | | | | | | < < < < < < < | > | < > > | | < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 | /* * tclLoadAix.c -- * * This file implements the dlopen and dlsym APIs under the AIX operating * system, to enable the Tcl "load" command to work. This code was * provided by Jens-Uwe Mager. * * This file is subject to the following copyright notice, which is * different from the notice used elsewhere in Tcl. The file has been * modified to incorporate the file dlfcn.h in-line. * * Copyright (c) 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH * Not derived from licensed software. * * Permission is granted to freely use, copy, modify, and redistribute * this software, provided that the author is not construed to be liable * for any results of using the software, alterations are clearly marked * as such, and this notice is not modified. * * RCS: @(#) $Id: tclLoadAix.c,v 1.3.38.1 2005/08/02 18:16:54 dgp Exp $ * * Note: this file has been altered from the original in a few ways in order * to work properly with Tcl. */ /* * @(#)dlfcn.c 1.7 revision of 95/08/14 19:08:38 * This is an unpublished work copyright (c) 1992 HELIOS Software GmbH * 30159 Hannover, Germany */ #include <stdio.h> #include <errno.h> #include <string.h> #include <stdlib.h> #include <sys/types.h> #include <sys/ldr.h> #include <a.out.h> #include <ldfcn.h> #include "../compat/dlfcn.h" /* * We simulate dlopen() et al. through a call to load. Because AIX has no call * to find an exported symbol we read the loader section of the loaded module * and build a list of exported symbols and their virtual address. */ typedef struct { char *name; /* The symbols's name. */ void *addr; /* Its relocated virtual address. */ } Export, *ExportPtr; /* * xlC uses the following structure to list its constructors and destructors. * This is gleaned from the output of munch. */ typedef struct { void (*init)(void); /* call static constructors */ void (*term)(void); /* call static destructors */ } Cdtor, *CdtorPtr; /* * The void * handle returned from dlopen is actually a ModulePtr. */ typedef struct Module { struct Module *next; char *name; /* module name for refcounting */ int refCnt; /* the number of references */ void *entry; /* entry point from load */ struct dl_info *info; /* optional init/terminate functions */ CdtorPtr cdtors; /* optional C++ constructors */ int nExports; /* the number of exports found */ ExportPtr exports; /* the array of exports */ } Module, *ModulePtr; /* * We keep a list of all loaded modules to be able to call the fini handlers * and destructors at atexit() time. */ static ModulePtr modList; /* * The last error from one of the dl* routines is kept in static variables * here. Each error is returned only once to the caller. */ static char errbuf[BUFSIZ]; static int errvalid; static void caterr(char *); static int readExports(ModulePtr); static void terminate(void); static void *findMain(void); VOID * dlopen(const char *path, int mode) { register ModulePtr mp; static void *mainModule; /* * Upon the first call register a terminate handler that will close all * libraries. Also get a reference to the main module for use with * loadbind. */ if (!mainModule) { mainModule = findMain(); if (mainModule == NULL) { return NULL; } atexit(terminate); } /* * Scan the list of modules if we have the module already loaded. */ for (mp = modList; mp; mp = mp->next) { if (strcmp(mp->name, path) == 0) { mp->refCnt++; return (VOID *) mp; } } mp = (ModulePtr) calloc(1, sizeof(*mp)); if (mp == NULL) { errvalid++; strcpy(errbuf, "calloc: "); strcat(errbuf, strerror(errno)); return (VOID *) NULL; } mp->name = malloc((unsigned) (strlen(path) + 1)); strcpy(mp->name, path); /* * load should be declared load(const char *...). Thus we cast the path to * a normal char *. Ugly. */ mp->entry = (void *) load((char *)path, L_NOAUTODEFER, NULL); if (mp->entry == NULL) { free(mp->name); free(mp); errvalid++; strcpy(errbuf, "dlopen: "); strcat(errbuf, path); strcat(errbuf, ": "); /* * If AIX says the file is not executable, the error can be further * described by querying the loader about the last error. */ if (errno == ENOEXEC) { char *tmp[BUFSIZ/sizeof(char *)], **p; if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) { strcpy(errbuf, strerror(errno)); } else { for (p=tmp ; *p ; p++) { caterr(*p); } } } else { strcat(errbuf, strerror(errno)); } return (VOID *) NULL; } mp->refCnt = 1; mp->next = modList; modList = mp; if (loadbind(0, mainModule, mp->entry) == -1) { loadbindFailure: dlclose(mp); errvalid++; strcpy(errbuf, "loadbind: "); strcat(errbuf, strerror(errno)); return (VOID *) NULL; } /* * If the user wants global binding, loadbind against all other loaded * modules. */ if (mode & RTLD_GLOBAL) { register ModulePtr mp1; for (mp1 = mp->next; mp1; mp1 = mp1->next) { if (loadbind(0, mp1->entry, mp->entry) == -1) { goto loadbindFailure; } } } if (readExports(mp) == -1) { dlclose(mp); return (VOID *) NULL; } /* * If there is a dl_info structure, call the init function. */ if (mp->info = (struct dl_info *)dlsym(mp, "dl_info")) { if (mp->info->init) { (*mp->info->init)(); } } else { errvalid = 0; } /* * If the shared object was compiled using xlC we will need to call static * constructors (and later on dlclose destructors). */ if (mp->cdtors = (CdtorPtr) dlsym(mp, "__cdtors")) { while (mp->cdtors->init) { (*mp->cdtors->init)(); mp->cdtors++; } } else { errvalid = 0; } return (VOID *) mp; } /* * Attempt to decipher an AIX loader error message and append it to our static * error message buffer. */ static void caterr(char *s) { register char *p = s; while (*p >= '0' && *p <= '9') { p++; } switch (atoi(s)) { /* INTL: "C", UTF safe. */ case L_ERROR_TOOMANY: strcat(errbuf, "to many errors"); break; case L_ERROR_NOLIB: strcat(errbuf, "can't load library"); strcat(errbuf, p); break; case L_ERROR_UNDEF: strcat(errbuf, "can't find symbol"); strcat(errbuf, p); break; case L_ERROR_RLDBAD: strcat(errbuf, "bad RLD"); strcat(errbuf, p); break; case L_ERROR_FORMAT: strcat(errbuf, "bad exec format in"); strcat(errbuf, p); break; case L_ERROR_ERRNO: strcat(errbuf, strerror(atoi(++p))); /* INTL: "C", UTF safe. */ break; default: strcat(errbuf, s); break; } } VOID * dlsym(void *handle, const char *symbol) { register ModulePtr mp = (ModulePtr)handle; register ExportPtr ep; register int i; /* * Could speed up the search, but I assume that one assigns the result to * function pointers anyways. */ for (ep = mp->exports, i = mp->nExports; i; i--, ep++) { if (strcmp(ep->name, symbol) == 0) { return ep->addr; } } errvalid++; strcpy(errbuf, "dlsym: undefined symbol "); strcat(errbuf, symbol); return NULL; } char * dlerror(void) { if (errvalid) { errvalid = 0; return errbuf; } return NULL; } int dlclose(void *handle) { register ModulePtr mp = (ModulePtr)handle; int result; register ModulePtr mp1; if (--mp->refCnt > 0) { return 0; } if (mp->info && mp->info->fini) { (*mp->info->fini)(); } if (mp->cdtors) { while (mp->cdtors->term) { (*mp->cdtors->term)(); mp->cdtors++; } } result = unload(mp->entry); if (result == -1) { errvalid++; strcpy(errbuf, strerror(errno)); } if (mp->exports) { register ExportPtr ep; register int i; for (ep = mp->exports, i = mp->nExports; i; i--, ep++) { if (ep->name) { free(ep->name); } } free(mp->exports); } if (mp == modList) { modList = mp->next; } else { for (mp1 = modList; mp1; mp1 = mp1->next) { if (mp1->next == mp) { mp1->next = mp->next; break; } } } free(mp->name); free(mp); return result; } static void terminate(void) { while (modList) { dlclose(modList); } } /* * Build the export table from the XCOFF .loader section. */ static int readExports(ModulePtr mp) { LDFILE *ldp = NULL; SCNHDR sh, shdata; LDHDR *lhp; char *ldbuf; LDSYM *ls; int i; ExportPtr ep; const char *errMsg; #define Error(msg) do{errMsg=(msg);goto error;}while(0) #define SysErr() Error(strerror(errno)) ldp = ldopen(mp->name, ldp); if (ldp == NULL) { struct ld_info *lp; char *buf; int size = 0; if (errno != ENOENT) { SysErr(); } /* * The module might be loaded due to the LIBPATH environment variable. * Search for the loaded module using L_GETINFO. */ while (1) { size += 4 * 1024; buf = malloc(size); if (buf == NULL) { SysErr(); } i = loadquery(L_GETINFO, buf, size); if (i != -1) { break; } free(buf); if (errno != ENOMEM) { SysErr(); } } /* * Traverse the list of loaded modules. The entry point returned by * load() does actually point to the data segment origin. */ lp = (struct ld_info *) buf; while (lp) { if (lp->ldinfo_dataorg == mp->entry) { ldp = ldopen(lp->ldinfo_filename, ldp); break; } if (lp->ldinfo_next == 0) { lp = NULL; } else { lp = (struct ld_info *)((char *)lp + lp->ldinfo_next); } } free(buf); if (!ldp) { SysErr(); } } if (TYPE(ldp) != U802TOCMAGIC) { Error("bad magic"); } /* * Get the padding for the data section. This is needed for AIX 4.1 * compilers. This is used when building the final function pointer to the * exported symbol. */ if (ldnshread(ldp, _DATA, &shdata) != SUCCESS) { Error("cannot read data section header"); } if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) { Error("cannot read loader section header"); } /* * We read the complete loader section in one chunk, this makes finding * long symbol names residing in the string table easier. */ ldbuf = (char *) malloc(sh.s_size); if (ldbuf == NULL) { SysErr(); } if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) { free(ldbuf); Error("cannot seek to loader section"); } if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { free(ldbuf); Error("cannot read loader section"); } lhp = (LDHDR *) ldbuf; ls = (LDSYM *)(ldbuf + LDHDRSZ); /* * Count the number of exports to include in our export table. */ for (i = lhp->l_nsyms; i; i--, ls++) { if (!LDR_EXPORT(*ls)) { continue; } mp->nExports++; } mp->exports = (ExportPtr) calloc(mp->nExports, sizeof(*mp->exports)); if (mp->exports == NULL) { free(ldbuf); SysErr(); } /* * Fill in the export table. All entries are relative to the entry point * we got from load. */ ep = mp->exports; ls = (LDSYM *)(ldbuf + LDHDRSZ); for (i=lhp->l_nsyms ; i!=0 ; i--,ls++) { char *symname; char tmpsym[SYMNMLEN+1]; if (!LDR_EXPORT(*ls)) { continue; } if (ls->l_zeroes == 0) { symname = ls->l_offset + lhp->l_stoff + ldbuf; } else { /* * The l_name member is not zero terminated, we must copy the * first SYMNMLEN chars and make sure we have a zero byte at the * end. */ strncpy(tmpsym, ls->l_name, SYMNMLEN); tmpsym[SYMNMLEN] = '\0'; symname = tmpsym; } ep->name = malloc((unsigned) (strlen(symname) + 1)); strcpy(ep->name, symname); ep->addr = (void *)((unsigned long) mp->entry + ls->l_value - shdata.s_vaddr); ep++; } free(ldbuf); while (ldclose(ldp) == FAILURE) { /* Empty body */ } return 0; /* * This is a factoring out of the error-handling code to make the rest of * the function much simpler to read. */ error: errvalid++; strcpy(errbuf, "readExports: "); strcat(errbuf, errMsg); if (ldp != NULL) { while (ldclose(ldp) == FAILURE) { /* Empty body */ } } return -1; } /* * Find the main modules entry point. This is used as export pointer for * loadbind() to be able to resolve references to the main part. */ static void * findMain(void) { struct ld_info *lp; char *buf; int size = 4*1024; int i; void *ret; buf = malloc(size); if (buf == NULL) { goto error; } while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { free(buf); size += 4*1024; buf = malloc(size); if (buf == NULL) { goto error; } } if (i == -1) { free(buf); goto error; } /* * The first entry is the main module. The entry point returned by load() * does actually point to the data segment origin. */ lp = (struct ld_info *) buf; ret = lp->ldinfo_dataorg; free(buf); return ret; error: errvalid++; strcpy(errbuf, "findMain: "); strcat(errbuf, strerror(errno)); return NULL; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Deleted unix/tclLoadAout.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to unix/tclLoadDl.c.
|
| | | | < | | | | | | | | | | | | | | | | | | | > | | | | > > | | | < | | | | | > | | | | > | | | | | | | | | | < | | | | | | | | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 | /* * tclLoadDl.c -- * * This procedure provides a version of the TclLoadFile that works with * the "dlopen" and "dlsym" library procedures for dynamic loading. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclLoadDl.c,v 1.13.6.1 2005/08/02 18:16:54 dgp Exp $ */ #include "tclInt.h" #ifdef NO_DLFCN_H # include "../compat/dlfcn.h" #else # include <dlfcn.h> #endif /* * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined and this * argument to dlopen must always be 1. The RTLD_GLOBAL flag is needed on some * systems (e.g. SCO and UnixWare) but doesn't exist on others; if it doesn't * exist, set it to 0 so it has no effect. */ #ifndef RTLD_NOW # define RTLD_NOW 1 #endif #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; /* * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a * relative path. */ native = Tcl_FSGetNativePath(pathPtr); handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL); if (handle == NULL) { /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; char *fileName = Tcl_GetString(pathPtr); native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL); Tcl_DStringFree(&ds); } if (handle == NULL) { Tcl_AppendResult(interp, "couldn't load file \"", 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; /* Place to put error messages. */ Tcl_LoadHandle loadHandle; /* Value from TcpDlopen(). */ CONST char *symbol; /* Symbol to look up. */ { 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 -- * * 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. */ { VOID *handle; handle = (VOID *) loadHandle; dlclose(handle); } /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package name, * this procedure is invoked to try to figure it out. * * Results: * Always returns 0 to indicate that we couldn't figure out a package * name; generic code will then try to guess the package from the file * name. A return value of 1 would have meant that we figured out the * package name and put it in bufPtr. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclGuessPackageName(fileName, bufPtr) CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ Tcl_DString *bufPtr; /* Initialized empty dstring. Append package * name to this if possible. */ { return 0; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclLoadDld.c.
|
| | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | /* * tclLoadDld.c -- * * This procedure provides a version of the TclLoadFile that works with * the "dld_link" and "dld_get_func" library procedures for dynamic * loading. It has been tested on Linux 1.1.95 and dld-3.2.7. This file * probably isn't needed anymore, since it 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.12.6.1 2005/08/02 18:16:54 dgp 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; CONST char *native; /* * 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); |
︙ | ︙ | |||
83 84 85 86 87 88 89 | return TCL_ERROR; } firstTime = 0; } fileName = Tcl_GetString(pathPtr); | | | | | > | | < | | | | | | > | | | | | | | < | | | | | | | | > > > > > > > > | 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 | return TCL_ERROR; } firstTime = 0; } fileName = Tcl_GetString(pathPtr); /* * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a * relative path. */ native = Tcl_FSGetNativePath(pathPtr); returnCode = dld_link(native); if (returnCode != 0) { Tcl_DString ds; native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); returnCode = dld_link(native); Tcl_DStringFree(&ds); } if (returnCode != 0) { Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", dld_strerror(returnCode), (char *) NULL); return TCL_ERROR; } *loadHandle = (Tcl_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); } /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package name, * this procedure is invoked to try to figure it out. * * Results: * Always returns 0 to indicate that we couldn't figure out a package * name; generic code will then try to guess the package from the file * name. A return value of 1 would have meant that we figured out the * package name and put it in bufPtr. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclGuessPackageName(fileName, bufPtr) CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ Tcl_DString *bufPtr; /* Initialized empty dstring. Append package * name to this if possible. */ { return 0; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclLoadDyld.c.
|
| | | | > | < > | | | > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | > > | | | | > < | | | | > > > > > > > | | | | | > | | > | | | | | > > | > > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > | > | > | | | | | > > > > > > | | | | | | | | | > | | | | | > | > > | | | | > > > > > > > | | > > > > > > > | | | | | | > > | | > | > | | > > > > > > > | | | | | | | | > | | | | < | > > | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > | > > > | > > > | > > > > > > | > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 | /* * tclLoadDyld.c -- * * This procedure provides a version of the TclLoadFile that works with * Apple's dyld dynamic loading. * Original version of his file (now superseded long ago) provided by * Wilfredo Sanchez ([email protected]). * * Copyright (c) 1995 Apple Computer, Inc. * Copyright (c) 2005 Daniel A. Steffen <[email protected]> * * 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.15.2.3 2005/08/02 18:16:54 dgp Exp $ */ #include "tclInt.h" #include <mach-o/dyld.h> #include <mach/mach.h> typedef struct Tcl_DyldModuleHandle { struct Tcl_DyldModuleHandle *nextPtr; NSModule module; } Tcl_DyldModuleHandle; typedef struct Tcl_DyldLoadHandle { CONST struct mach_header *dyldLibHeader; Tcl_DyldModuleHandle *modulePtr; } Tcl_DyldLoadHandle; #ifdef TCL_LOAD_FROM_MEMORY typedef struct ThreadSpecificData { int haveLoadMemory; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #endif /* *---------------------------------------------------------------------- * * DyldOFIErrorMsg -- * * Converts a numerical NSObjectFileImage error into an error message * string. * * Results: * Error message string. * * Side effects: * None. * *---------------------------------------------------------------------- */ static CONST char* DyldOFIErrorMsg(int err) { switch(err) { case NSObjectFileImageSuccess: return NULL; case NSObjectFileImageFailure: return "object file setup failure"; case NSObjectFileImageInappropriateFile: return "not a Mach-O MH_BUNDLE file"; case NSObjectFileImageArch: return "no object for this architecture"; case NSObjectFileImageFormat: return "bad object file format"; case NSObjectFileImageAccess: return "can't read object file"; default: return "unknown error"; } } /* *---------------------------------------------------------------------- * * TclpDlopen -- * * Dynamically loads a binary code file into memory and returns a handle * to the new code. * * Results: * A standard Tcl completion code. If an error occurs, an error message * is left in the interpreter's result. * * Side effects: * New code suddenly appears in memory. * *---------------------------------------------------------------------- */ MODULE_SCOPE int TclpDlopen(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 *dyldLibHeader; NSObjectFileImage dyldObjFileImage = NULL; Tcl_DyldModuleHandle *modulePtr = NULL; CONST char *native; /* * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a * relative path. */ native = Tcl_FSGetNativePath(pathPtr); dyldLibHeader = NSAddImage(native, NSADDIMAGE_OPTION_WITH_SEARCHING | NSADDIMAGE_OPTION_RETURN_ON_ERROR); if (!dyldLibHeader) { NSLinkEditErrors editError; int errorNumber; CONST char *name, *msg, *objFileImageErrMsg = NULL; NSLinkEditError(&editError, &errorNumber, &name, &msg); if (editError == NSLinkEditFileAccessError) { /* * The requested file was not found. Let the OS loader examine the * binary search path for whatever string the user gave us which * hopefully refers to a file on the binary path. */ Tcl_DString ds; char *fileName = Tcl_GetString(pathPtr); CONST char *native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); dyldLibHeader = NSAddImage(native, NSADDIMAGE_OPTION_WITH_SEARCHING | NSADDIMAGE_OPTION_RETURN_ON_ERROR); Tcl_DStringFree(&ds); if (!dyldLibHeader) { NSLinkEditError(&editError, &errorNumber, &name, &msg); } } else if ((editError==NSLinkEditFileFormatError && errorNumber==EBADMACHO) || editError == NSLinkEditOtherError){ /* * The requested file was found but was not of type MH_DYLIB, * attempt to load it as a MH_BUNDLE. */ NSObjectFileImageReturnCode err = NSCreateObjectFileImageFromFile(native, &dyldObjFileImage); objFileImageErrMsg = DyldOFIErrorMsg(err); } if (!dyldLibHeader && !dyldObjFileImage) { Tcl_AppendResult(interp, msg, (char *) NULL); if (msg && *msg) { Tcl_AppendResult(interp, "\n", (char *) NULL); } if (objFileImageErrMsg) { Tcl_AppendResult(interp, "NSCreateObjectFileImageFromFile() error: ", objFileImageErrMsg, (char *) NULL); } return TCL_ERROR; } } if (dyldObjFileImage) { NSModule module; module = NSLinkModule(dyldObjFileImage, native, NSLINKMODULE_OPTION_BINDNOW | NSLINKMODULE_OPTION_RETURN_ON_ERROR); NSDestroyObjectFileImage(dyldObjFileImage); if (!module) { NSLinkEditErrors editError; int errorNumber; CONST char *name, *msg; NSLinkEditError(&editError, &errorNumber, &name, &msg); Tcl_AppendResult(interp, msg, (char *) NULL); return TCL_ERROR; } modulePtr = (Tcl_DyldModuleHandle *) ckalloc(sizeof(Tcl_DyldModuleHandle)); modulePtr->module = module; modulePtr->nextPtr = NULL; } dyldLoadHandle = (Tcl_DyldLoadHandle *) ckalloc(sizeof(Tcl_DyldLoadHandle)); dyldLoadHandle->dyldLibHeader = dyldLibHeader; dyldLoadHandle->modulePtr = modulePtr; *loadHandle = (Tcl_LoadHandle) dyldLoadHandle; *unloadProcPtr = &TclpUnloadFile; return TCL_OK; } /* *---------------------------------------------------------------------- * * TclpFindSymbol -- * * Looks up a symbol, by name, through a handle associated with a * previously loaded piece of code (shared library). * * Results: * Returns a pointer to the function associated with 'symbol' if it is * found. Otherwise returns NULL and may leave an error message in the * interp's result. * *---------------------------------------------------------------------- */ MODULE_SCOPE Tcl_PackageInitProc* TclpFindSymbol(interp, loadHandle, symbol) Tcl_Interp *interp; /* For error reporting. */ Tcl_LoadHandle loadHandle; /* Handle from TclpDlopen. */ CONST char *symbol; /* Symbol name to look up. */ { NSSymbol nsSymbol; CONST char *native; Tcl_DString newName, ds; Tcl_PackageInitProc* proc = NULL; Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle; /* * dyld adds an underscore to the beginning of symbol names. */ native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds); Tcl_DStringInit(&newName); Tcl_DStringAppend(&newName, "_", 1); native = Tcl_DStringAppend(&newName, native, -1); if (dyldLoadHandle->dyldLibHeader) { nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyldLibHeader, native, NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW | NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR); if (nsSymbol) { /* * Until dyld supports unloading of MY_DYLIB binaries, the * following is not needed. */ #ifdef DYLD_SUPPORTS_DYLIB_UNLOADING NSModule module = NSModuleForSymbol(nsSymbol); Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr; while (modulePtr != NULL) { if (module == modulePtr->module) { break; } modulePtr = modulePtr->nextPtr; } if (modulePtr == NULL) { modulePtr = (Tcl_DyldModuleHandle *) ckalloc(sizeof(Tcl_DyldModuleHandle)); modulePtr->module = module; modulePtr->nextPtr = dyldLoadHandle->modulePtr; dyldLoadHandle->modulePtr = modulePtr; } #endif /* DYLD_SUPPORTS_DYLIB_UNLOADING */ } else { NSLinkEditErrors editError; int errorNumber; CONST char *name, *msg; NSLinkEditError(&editError, &errorNumber, &name, &msg); Tcl_AppendResult(interp, msg, (char *) NULL); } } else { nsSymbol = NSLookupSymbolInModule(dyldLoadHandle->modulePtr->module, native); } if (nsSymbol) { proc = NSAddressOfSymbol(nsSymbol); } Tcl_DStringFree(&newName); Tcl_DStringFree(&ds); return proc; } /* *---------------------------------------------------------------------- * * TclpUnloadFile -- * * Unloads a dynamically loaded binary code file from memory. Code * pointers in the formerly loaded file are no longer valid after calling * this function. * * Results: * None. * * Side effects: * Code dissapears from memory. Note that dyld currently only supports * unloading of binaries of type MH_BUNDLE loaded with NSLinkModule() in * TclpDlopen() above. * *---------------------------------------------------------------------- */ MODULE_SCOPE void TclpUnloadFile(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 *modulePtr = dyldLoadHandle->modulePtr; while (modulePtr != NULL) { void *ptr; NSUnLinkModule(modulePtr->module, NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES); ptr = modulePtr; modulePtr = modulePtr->nextPtr; ckfree(ptr); } ckfree((char*) dyldLoadHandle); } /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package name, * this procedure is invoked to try to figure it out. * * Results: * Always returns 0 to indicate that we couldn't figure out a package * name; generic code will then try to guess the package from the file * name. A return value of 1 would have meant that we figured out the * package name and put it in bufPtr. * * Side effects: * None. * *---------------------------------------------------------------------- */ MODULE_SCOPE int TclGuessPackageName(fileName, bufPtr) CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ Tcl_DString *bufPtr; /* Initialized empty dstring. Append package * name to this if possible. */ { return 0; } #ifdef TCL_LOAD_FROM_MEMORY /* *---------------------------------------------------------------------- * * TclpLoadMemoryGetBuffer -- * * Allocate a buffer that can be used with TclpLoadMemory() below. * * Results: * Pointer to allocated buffer or NULL if an error occurs. * * Side effects: * Buffer is allocated. * *---------------------------------------------------------------------- */ MODULE_SCOPE void* TclpLoadMemoryGetBuffer(interp, size) Tcl_Interp *interp; /* Used for error reporting. */ int size; /* Size of desired buffer. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); void *buffer = NULL; if (!tsdPtr->haveLoadMemory) { /* * NSCreateObjectFileImageFromMemory is available but always fails * prior to Darwin 7. */ struct utsname name; if (!uname(&name)) { long release = strtol(name.release, NULL, 10); tsdPtr->haveLoadMemory = (release >= 7) ? 1 : -1; } } if (tsdPtr->haveLoadMemory > 0) { /* * We must allocate the buffer using vm_allocate, because * NSCreateObjectFileImageFromMemory will dispose of it using * vm_deallocate. */ if (vm_allocate(mach_task_self(), (vm_address_t *) &buffer, size, 1)) { buffer = NULL; } } return buffer; } /* *---------------------------------------------------------------------- * * TclpLoadMemory -- * * Dynamically loads binary code file from memory and returns a handle to * the new code. * * Results: * A standard Tcl completion code. If an error occurs, an error message * is left in the interpreter's result. * * Side effects: * New code is loaded from memory. * *---------------------------------------------------------------------- */ MODULE_SCOPE int TclpLoadMemory(interp, buffer, size, codeSize, loadHandle, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ void *buffer; /* Buffer containing the desired code * (allocated with TclpLoadMemoryGetBuffer). */ int size; /* Allocation size of buffer. */ int codeSize; /* Size of code data read into buffer or -1 if * an error occurred and the buffer should * just be freed. */ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ Tcl_FSUnloadFileProc **unloadProcPtr; /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ { Tcl_DyldLoadHandle *dyldLoadHandle; NSObjectFileImage dyldObjFileImage = NULL; Tcl_DyldModuleHandle *modulePtr; NSModule module; CONST char *objFileImageErrMsg = NULL; /* * Try to create an object file image that we can load from. */ if (codeSize >= 0) { NSObjectFileImageReturnCode err = NSObjectFileImageSuccess; #ifndef __LP64__ struct mach_header *mh = buffer; if (codeSize < sizeof(struct mach_header) || mh->magic != MH_MAGIC #else struct mach_header_64 *mh = buffer; if (codeSize < sizeof(struct mach_header_64) || mh->magic != MH_MAGIC_64 #endif || mh->filetype != MH_BUNDLE) { err = NSObjectFileImageInappropriateFile; } if (err == NSObjectFileImageSuccess) { err = NSCreateObjectFileImageFromMemory(buffer, codeSize, &dyldObjFileImage); } objFileImageErrMsg = DyldOFIErrorMsg(err); } /* * If it went wrong (or we were asked to just deallocate), get rid of the * memory block and create an error message. */ if (dyldObjFileImage == NULL) { vm_deallocate(mach_task_self(), (vm_address_t) buffer, size); if (objFileImageErrMsg != NULL) { Tcl_AppendResult(interp, "NSCreateObjectFileImageFromFile() error: ", objFileImageErrMsg, (char *) NULL); } return TCL_ERROR; } /* * Extract the module we want from the image of the object file. */ module = NSLinkModule(dyldObjFileImage, "[Memory Based Bundle]", NSLINKMODULE_OPTION_BINDNOW | NSLINKMODULE_OPTION_RETURN_ON_ERROR); NSDestroyObjectFileImage(dyldObjFileImage); if (!module) { NSLinkEditErrors editError; int errorNumber; CONST char *name, *msg; NSLinkEditError(&editError, &errorNumber, &name, &msg); Tcl_AppendResult(interp, msg, (char *) NULL); return TCL_ERROR; } /* * Stash the module reference within the load handle we create and return. */ modulePtr = (Tcl_DyldModuleHandle *) ckalloc(sizeof(Tcl_DyldModuleHandle)); modulePtr->module = module; modulePtr->nextPtr = NULL; dyldLoadHandle = (Tcl_DyldLoadHandle *) ckalloc(sizeof(Tcl_DyldLoadHandle)); dyldLoadHandle->dyldLibHeader = NULL; dyldLoadHandle->modulePtr = modulePtr; *loadHandle = (Tcl_LoadHandle) dyldLoadHandle; *unloadProcPtr = &TclpUnloadFile; return TCL_OK; } #endif /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclLoadNext.c.
|
| | | | < | | | | | | | | | | | | | | | | > | | | | | > > | > | | | | | | | | | > | | > > > | | | | | | | | < | | | | | | | | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | /* * 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.11.6.1 2005/08/02 18:16:55 dgp 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. */ { struct mach_header *header; char *fileName; char *files[2]; CONST char *native; int result = 1; NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE); fileName = Tcl_GetString(pathPtr); /* * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a * relative path. */ native = Tcl_FSGetNativePath(pathPtr); files = {native,NULL}; result = rld_load(errorStream, &header, files, NULL); if (!result) { /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path */ Tcl_DString ds; native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); files = {native,NULL}; result = rld_load(errorStream, &header, files, NULL); Tcl_DStringFree(&ds); } if (!result) { char *data; int len, maxlen; 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. */ { } /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package name, * this procedure is invoked to try to figure it out. * * Results: * Always returns 0 to indicate that we couldn't figure out a package * name; generic code will then try to guess the package from the file * name. A return value of 1 would have meant that we figured out the * package name and put it in bufPtr. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclGuessPackageName(fileName, bufPtr) CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ Tcl_DString *bufPtr; /* Initialized empty dstring. Append package * name to this if possible. */ { return 0; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclLoadOSF.c.
|
| | | | | | | | | | | | | | | | | | | | | | > | | | | > > | | | | | > | | | | | | | | | | | | < | | | | | | | | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 | /* * tclLoadOSF.c -- * * This procedure provides a version of the TclLoadFile that works under * OSF/1 1.0/1.1/1.2 and related systems, utilizing the old OSF/1 * /sbin/loader and /usr/include/loader.h. OSF/1 versions from 1.3 and * on use ELF, rtld, and dlopen()[/usr/include/ldfcn.h]. * * This is useful for: * OSF/1 1.0, 1.1, 1.2 (from OSF) * includes: MK4 and AD1 (from OSF RI) * OSF/1 1.3 (from OSF) using ROSE * HP OSF/1 1.0 ("Acorn") using COFF * * This is likely to be useful for: * Paragon OSF/1 (from Intel) * HI-OSF/1 (from Hitachi) * * This is NOT to be used on: * Digitial Alpha OSF/1 systems * OSF/1 1.3 or later (from OSF) using ELF * includes: MK6, MK7, AD2, AD3 (from OSF RI) * * This approach to things was utter @&^#; thankfully, OSF/1 eventually * supported dlopen(). * * John Robert LoVerso <[email protected]> * * 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.11.6.1 2005/08/02 18:16:55 dgp 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. */ { ldr_module_t lm; char *pkg; char *fileName = Tcl_GetString(pathPtr); CONST char *native; /* * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a * relative path. */ native = Tcl_FSGetNativePath(pathPtr); lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS); if (lm == LDR_NULL_MODULE) { /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path */ Tcl_DString ds; native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS); Tcl_DStringFree(&ds); } if (lm == LDR_NULL_MODULE) { Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ", Tcl_PosixError (interp), (char *) NULL); return TCL_ERROR; } *clientDataPtr = NULL; /* * 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. */ { } /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package name, * this procedure is invoked to try to figure it out. * * Results: * Always returns 0 to indicate that we couldn't figure out a package * name; generic code will then try to guess the package from the file * name. A return value of 1 would have meant that we figured out the * package name and put it in bufPtr. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclGuessPackageName(fileName, bufPtr) CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ Tcl_DString *bufPtr; /* Initialized empty dstring. Append package * name to this if possible. */ { return 0; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclLoadShl.c.
|
| | | | | | | | | | | | | | | | | | | | | | < < | | | > | < | | | | | > > | < | | | | | | | | > | | < | | | | | | | | < | | | | | | | | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 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 | /* * tclLoadShl.c -- * * This procedure provides a version of the TclLoadFile that works with * the "shl_load" and "shl_findsym" library procedures for dynamic * loading (e.g. for HP machines). * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclLoadShl.c,v 1.13.6.2 2005/10/08 13:45:04 dgp 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; CONST char *native; char *fileName = Tcl_GetString(pathPtr); /* * The flags below used to be BIND_IMMEDIATE; they were changed at the * suggestion of Wolfgang Kechel ([email protected]): "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." */ /* * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a * relative path. */ native = Tcl_FSGetNativePath(pathPtr); handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE, 0L); if (handle == NULL) { /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L); Tcl_DStringFree(&ds); } 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 -- * * 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. */ { shl_t handle; handle = (shl_t) loadHandle; shl_unload(handle); } /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package name, * this procedure is invoked to try to figure it out. * * Results: * Always returns 0 to indicate that we couldn't figure out a package * name; generic code will then try to guess the package from the file * name. A return value of 1 would have meant that we figured out the * package name and put it in bufPtr. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclGuessPackageName(fileName, bufPtr) CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ Tcl_DString *bufPtr; /* Initialized empty dstring. Append package * name to this if possible. */ { return 0; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclUnixChan.c.
|
| | | | | | | | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | /* * 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.53.2.6 2005/09/09 18:48:40 dgp Exp $ */ #include "tclInt.h" /* Internal definitions for Tcl. */ #include "tclIO.h" /* To get Channel type declaration. */ /* * sys/ioctl.h has already been included by tclPort.h. Including termios.h or * termio.h causes a bunch of warning messages because some duplicate (but not * contradictory) #defines exist in termios.h and/or termio.h */ #undef NL0 #undef NL1 #undef CR0 #undef CR1 #undef CR2 #undef CR3 #undef TAB0 |
︙ | ︙ | |||
39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | #undef NOFLSH #undef TOSTOP #undef FLUSHO #undef PENDIN #define SUPPORTS_TTY #ifdef USE_TERMIOS # include <termios.h> # ifdef HAVE_SYS_IOCTL_H # include <sys/ioctl.h> # endif /* HAVE_SYS_IOCTL_H */ # ifdef HAVE_SYS_MODEM_H # include <sys/modem.h> # endif /* HAVE_SYS_MODEM_H */ # define IOSTATE struct termios # define GETIOSTATE(fd, statePtr) tcgetattr((fd), (statePtr)) # define SETIOSTATE(fd, statePtr) tcsetattr((fd), TCSADRAIN, (statePtr)) # define GETCONTROL(fd, intPtr) ioctl((fd), TIOCMGET, (intPtr)) # define SETCONTROL(fd, intPtr) ioctl((fd), TIOCMSET, (intPtr)) /* * TIP #35 introduced a different on exit flush/close behavior that | > > > > > > > > | | | | | | < > > | | > | 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 | #undef NOFLSH #undef TOSTOP #undef FLUSHO #undef PENDIN #define SUPPORTS_TTY #undef DIRECT_BAUD #ifdef B4800 # if (B4800 == 4800) # define DIRECT_BAUD # endif /* B4800 == 4800 */ #endif /* B4800 */ #ifdef USE_TERMIOS # include <termios.h> # ifdef HAVE_SYS_IOCTL_H # include <sys/ioctl.h> # endif /* HAVE_SYS_IOCTL_H */ # ifdef HAVE_SYS_MODEM_H # include <sys/modem.h> # endif /* HAVE_SYS_MODEM_H */ # define IOSTATE struct termios # define GETIOSTATE(fd, statePtr) tcgetattr((fd), (statePtr)) # define SETIOSTATE(fd, statePtr) tcsetattr((fd), TCSADRAIN, (statePtr)) # define GETCONTROL(fd, intPtr) ioctl((fd), TIOCMGET, (intPtr)) # define SETCONTROL(fd, intPtr) ioctl((fd), TIOCMSET, (intPtr)) /* * TIP #35 introduced a different on exit flush/close behavior that * doesn't work correctly with standard channels on all systems. The * problem is tcflush throws away waiting channel data. This may be * necessary for true serial channels that may block, but isn't correct in * the standard case. This might be replaced with tcdrain instead, but * that can block. For now, we revert to making this do nothing, and * TtyOutputProc being the same old FileOutputProc. - hobbs [Bug #525783] */ # define BAD_TIP35_FLUSH 0 # if BAD_TIP35_FLUSH # define TTYFLUSH(fd) tcflush((fd), TCIOFLUSH); # else # define TTYFLUSH(fd) # endif /* BAD_TIP35_FLUSH */ # ifdef FIONREAD # define GETREADQUEUE(fd, int) ioctl((fd), FIONREAD, &(int)) # elif defined(FIORDCHK) # define GETREADQUEUE(fd, int) int = ioctl((fd), FIORDCHK, NULL) # endif /* FIONREAD */ # ifdef TIOCOUTQ # define GETWRITEQUEUE(fd, int) ioctl((fd), TIOCOUTQ, &(int)) # endif /* TIOCOUTQ */ # if defined(TIOCSBRK) && defined(TIOCCBRK) /* * Can't use ?: operator below because that messes up types on either Linux or * Solaris (the two are mutually exclusive!) */ # define SETBREAK(fd, flag) \ if (flag) { \ ioctl((fd), TIOCSBRK, NULL); \ } else { \ ioctl((fd), TIOCCBRK, NULL); \ } # endif /* TIOCSBRK&TIOCCBRK */ |
︙ | ︙ | |||
132 133 134 135 136 137 138 | /* * The following structure describes per-instance state of a tty-based * channel. */ typedef struct TtyState { | | | | | | | | | | | | | | | | | | | | | 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 | /* * The following structure describes per-instance state of a tty-based * channel. */ typedef struct TtyState { FileState fs; /* Per-instance state of the file descriptor. * Must be the first field. */ int stateUpdated; /* Flag to say if the state has been modified * and needs resetting. */ IOSTATE savedState; /* Initial state of device. Used to reset * state when device closed. */ } TtyState; /* * The following structure is used to set or get the serial port attributes in * a platform-independant manner. */ typedef struct TtyAttrs { int baud; int parity; int data; int stop; } TtyAttrs; #endif /* !SUPPORTS_TTY */ #define UNSUPPORTED_OPTION(detail) \ if (interp) { \ Tcl_AppendResult(interp, (detail), \ " not supported for this platform", (char *) NULL); \ } /* * This structure describes per-instance state of a tcp based channel. */ typedef struct TcpState { Tcl_Channel channel; /* Channel associated with this file. */ int fd; /* The socket itself. */ int flags; /* ORed combination of the bitfields defined * below. */ Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ ClientData acceptProcData; /* The data for the accept proc. */ } TcpState; /* * These bits may be ORed together into the "flags" field of a TcpState * structure. */ #define TCP_ASYNC_SOCKET (1<<0) /* Asynchronous socket. */ #define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ /* * The following defines the maximum length of the listen queue. This is the * number of outstanding yet-to-be-serviced requests for a connection on a * server socket, more than this number of outstanding requests and the * connection request will fail. */ #ifndef SOMAXCONN # define SOMAXCONN 100 #endif /* SOMAXCONN */ #if (SOMAXCONN < 100) # undef SOMAXCONN # define SOMAXCONN 100 #endif /* SOMAXCONN < 100 */ /* * The following defines how much buffer space the kernel should maintain for * a socket. */ #define SOCKET_BUFSIZE 4096 /* * Static routines for this file: */ |
︙ | ︙ | |||
228 229 230 231 232 233 234 235 236 237 238 239 240 241 | static int FileInputProc _ANSI_ARGS_((ClientData instanceData, char *buf, int toRead, int *errorCode)); static int FileOutputProc _ANSI_ARGS_(( ClientData instanceData, CONST char *buf, int toWrite, int *errorCode)); static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, long offset, int mode, int *errorCode)); static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode)); static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); static void TcpAccept _ANSI_ARGS_((ClientData data, int mask)); static int TcpBlockModeProc _ANSI_ARGS_((ClientData data, int mode)); | > > > > > > | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 | static int FileInputProc _ANSI_ARGS_((ClientData instanceData, char *buf, int toRead, int *errorCode)); static int FileOutputProc _ANSI_ARGS_(( ClientData instanceData, CONST char *buf, int toWrite, int *errorCode)); static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, long offset, int mode, int *errorCode)); #ifdef DEPRECATED static void FileThreadActionProc _ANSI_ARGS_ (( ClientData instanceData, int action)); #endif static int FileTruncateProc _ANSI_ARGS_ ((ClientData instanceData, Tcl_WideInt length)); static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode)); static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); static void TcpAccept _ANSI_ARGS_((ClientData data, int mask)); static int TcpBlockModeProc _ANSI_ARGS_((ClientData data, int mode)); |
︙ | ︙ | |||
253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 | static void TcpWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); #ifdef SUPPORTS_TTY static int TtyCloseProc _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp)); static void TtyGetAttributes _ANSI_ARGS_((int fd, TtyAttrs *ttyPtr)); static int TtyGetBaud _ANSI_ARGS_((unsigned long speed)); static int TtyGetOptionProc _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp, CONST char *optionName, Tcl_DString *dsPtr)); static unsigned long TtyGetSpeed _ANSI_ARGS_((int baud)); static FileState * TtyInit _ANSI_ARGS_((int fd, int initialize)); static void TtyModemStatusStr _ANSI_ARGS_((int status, Tcl_DString *dsPtr)); #if BAD_TIP35_FLUSH static int TtyOutputProc _ANSI_ARGS_((ClientData instanceData, CONST char *buf, int toWrite, int *errorCode)); #endif /* BAD_TIP35_FLUSH */ static int TtyParseMode _ANSI_ARGS_((Tcl_Interp *interp, CONST char *mode, int *speedPtr, int *parityPtr, int *dataPtr, int *stopPtr)); static void TtySetAttributes _ANSI_ARGS_((int fd, TtyAttrs *ttyPtr)); static int TtySetOptionProc _ANSI_ARGS_((ClientData instanceData, | > > > > | | > > > > > > | > > > | > > > < | | | | | | | 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 | static void TcpWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); #ifdef SUPPORTS_TTY static int TtyCloseProc _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp)); static void TtyGetAttributes _ANSI_ARGS_((int fd, TtyAttrs *ttyPtr)); #ifndef DIRECT_BAUD static int TtyGetBaud _ANSI_ARGS_((unsigned long speed)); #endif static int TtyGetOptionProc _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp, CONST char *optionName, Tcl_DString *dsPtr)); #ifndef DIRECT_BAUD static unsigned long TtyGetSpeed _ANSI_ARGS_((int baud)); #endif static FileState * TtyInit _ANSI_ARGS_((int fd, int initialize)); static void TtyModemStatusStr _ANSI_ARGS_((int status, Tcl_DString *dsPtr)); #if BAD_TIP35_FLUSH static int TtyOutputProc _ANSI_ARGS_((ClientData instanceData, CONST char *buf, int toWrite, int *errorCode)); #endif /* BAD_TIP35_FLUSH */ static int TtyParseMode _ANSI_ARGS_((Tcl_Interp *interp, CONST char *mode, int *speedPtr, int *parityPtr, int *dataPtr, int *stopPtr)); static void TtySetAttributes _ANSI_ARGS_((int fd, TtyAttrs *ttyPtr)); static int TtySetOptionProc _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp, CONST char *optionName, CONST char *value)); #endif /* SUPPORTS_TTY */ static int WaitForConnect _ANSI_ARGS_((TcpState *statePtr, int *errorCodePtr)); static Tcl_Channel MakeTcpClientChannelMode _ANSI_ARGS_( (ClientData tcpSocket, int mode)); /* * This structure describes the channel type structure for file based IO: */ static Tcl_ChannelType fileChannelType = { "file", /* Type name. */ TCL_CHANNEL_VERSION_4, /* v4 channel */ FileCloseProc, /* Close proc. */ FileInputProc, /* Input proc. */ FileOutputProc, /* Output proc. */ FileSeekProc, /* Seek proc. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ FileWatchProc, /* Initialize notifier. */ FileGetHandleProc, /* Get OS handles out of channel. */ NULL, /* close2proc. */ FileBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ FileWideSeekProc, /* wide seek proc. */ #ifdef DEPRECATED FileThreadActionProc, /* thread actions */ #else NULL, #endif FileTruncateProc, /* truncate proc. */ }; #ifdef SUPPORTS_TTY /* * This structure describes the channel type structure for serial IO. * Note that this type is a subclass of the "file" type. */ static Tcl_ChannelType ttyChannelType = { "tty", /* Type name. */ TCL_CHANNEL_VERSION_4, /* v4 channel */ TtyCloseProc, /* Close proc. */ FileInputProc, /* Input proc. */ #if BAD_TIP35_FLUSH TtyOutputProc, /* Output proc. */ #else /* !BAD_TIP35_FLUSH */ FileOutputProc, /* Output proc. */ #endif /* BAD_TIP35_FLUSH */ NULL, /* Seek proc. */ TtySetOptionProc, /* Set option proc. */ TtyGetOptionProc, /* Get option proc. */ FileWatchProc, /* Initialize notifier. */ FileGetHandleProc, /* Get OS handles out of channel. */ NULL, /* close2proc. */ FileBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc. */ NULL, /* thread action proc. */ NULL, /* truncate proc. */ }; #endif /* SUPPORTS_TTY */ /* * This structure describes the channel type structure for TCP socket * based IO: */ static Tcl_ChannelType tcpChannelType = { "tcp", /* Type name. */ TCL_CHANNEL_VERSION_4, /* v4 channel */ TcpCloseProc, /* Close proc. */ TcpInputProc, /* Input proc. */ TcpOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ TcpGetOptionProc, /* Get option proc. */ TcpWatchProc, /* Initialize notifier. */ TcpGetHandleProc, /* Get OS handles out of channel. */ NULL, /* close2proc. */ TcpBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc. */ NULL, /* thread action proc. */ NULL, /* truncate proc. */ }; /* *---------------------------------------------------------------------- * * FileBlockModeProc -- * * Helper function to set blocking and nonblocking modes on a file based * channel. Invoked by generic IO level code. * * Results: * 0 if successful, errno when failed. * * Side effects: * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int FileBlockModeProc(instanceData, mode) ClientData instanceData; /* File state. */ int mode; /* The mode to set. Can be one of * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { FileState *fsPtr = (FileState *) instanceData; int curStatus; #ifndef USE_FIONBIO curStatus = fcntl(fsPtr->fd, F_GETFL); if (mode == TCL_MODE_BLOCKING) { |
︙ | ︙ | |||
411 412 413 414 415 416 417 | } /* *---------------------------------------------------------------------- * * FileInputProc -- * | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * FileInputProc -- * * This function is invoked from the generic IO level to read input from * a file based channel. * * Results: * The number of bytes read is returned or -1 on error. An output * argument contains a POSIX error code if an error occurs, or zero. * * Side effects: * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int FileInputProc(instanceData, buf, toRead, errorCodePtr) ClientData instanceData; /* File state. */ char *buf; /* Where to store data read. */ int toRead; /* How much space is available in the * buffer? */ int *errorCodePtr; /* Where to store error code. */ { FileState *fsPtr = (FileState *) instanceData; int bytesRead; /* How many bytes were actually read from the * input device? */ *errorCodePtr = 0; /* * Assume there is always enough input available. This will block * appropriately, and read will unblock as soon as a short read is * possible, if the channel is in blocking mode. If the channel is |
︙ | ︙ | |||
458 459 460 461 462 463 464 | } /* *---------------------------------------------------------------------- * * FileOutputProc-- * | | | | | < | | | | < | | | | 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 | } /* *---------------------------------------------------------------------- * * FileOutputProc-- * * This function is invoked from the generic IO level to write output to * a file channel. * * Results: * The number of bytes written is returned or -1 on error. An output * argument contains a POSIX error code if an error occurred, or zero. * * Side effects: * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int FileOutputProc(instanceData, buf, toWrite, errorCodePtr) ClientData instanceData; /* File state. */ CONST char *buf; /* The data buffer. */ int toWrite; /* How many bytes to write? */ int *errorCodePtr; /* Where to store error code. */ { FileState *fsPtr = (FileState *) instanceData; int written; *errorCodePtr = 0; if (toWrite == 0) { /* * SF Tcl Bug 465765. Do not try to write nothing into a file. STREAM * based implementations will considers this as EOF (if there is a * pipe behind the file). */ return 0; } written = write(fsPtr->fd, buf, (size_t) toWrite); if (written > -1) { return written; } *errorCodePtr = errno; return -1; } /* *---------------------------------------------------------------------- * * FileCloseProc -- * * This function is called from the generic IO level to perform * channel-type-specific cleanup when a file based channel is closed. * * Results: * 0 if successful, errno if failed. * * Side effects: * Closes the device of the channel. |
︙ | ︙ | |||
548 549 550 551 552 553 554 | } /* *---------------------------------------------------------------------- * * FileSeekProc -- * | | | | 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 | } /* *---------------------------------------------------------------------- * * FileSeekProc -- * * This function is called by the generic IO level to move the access * point in a file based channel. * * Results: * -1 if failed, the new position if successful. An output * argument contains the POSIX error code if an error occurred, * or zero. * * Side effects: |
︙ | ︙ | |||
577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 | { 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; } | > > | | > | | | | 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 | { 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); } /* *---------------------------------------------------------------------- * * FileWideSeekProc -- * * This function is called by the generic IO level to move the access * point in a file based channel, with offsets expressed as wide * integers. * * Results: * -1 if failed, the new position if successful. An output * argument contains the POSIX error code if an error occurred, * or zero. * * Side effects: |
︙ | ︙ | |||
686 687 688 689 690 691 692 | } /* *---------------------------------------------------------------------- * * FileGetHandleProc -- * | | | | | | 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 | } /* *---------------------------------------------------------------------- * * FileGetHandleProc -- * * Called from Tcl_GetChannelHandle to retrieve OS handles from a file * based channel. * * Results: * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
715 716 717 718 719 720 721 | *handlePtr = (ClientData) fsPtr->fd; return TCL_OK; } else { return TCL_ERROR; } } | | | > > | < | | | | > | | | | < | | | | | | | | > | > | 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 | *handlePtr = (ClientData) fsPtr->fd; return TCL_OK; } else { return TCL_ERROR; } } #ifdef SUPPORTS_TTY /* *---------------------------------------------------------------------- * * TtyCloseProc -- * * This function is called from the generic IO level to perform * channel-type-specific cleanup when a tty based channel is closed. * * Results: * 0 if successful, errno if failed. * * Side effects: * Closes the device of the channel. * *---------------------------------------------------------------------- */ static int TtyCloseProc(instanceData, interp) ClientData instanceData; /* Tty state. */ Tcl_Interp *interp; /* For error reporting - unused. */ { #if BAD_TIP35_FLUSH TtyState *ttyPtr = (TtyState *) instanceData; #endif /* BAD_TIP35_FLUSH */ #ifdef TTYFLUSH TTYFLUSH(ttyPtr->fs.fd); #endif /* TTYFLUSH */ #if 0 /* * TIP#35 agreed to remove the unsave so that TCL could be used as a * simple stty. It would be cleaner to remove all the stuff related to * TtyState.stateUpdated * TtyState.savedState * Then the structure TtyState would be the same as FileState. IMO this * cleanup could better be done for the final 8.4 release after nobody * complained about the missing unsave. - schroedter */ if (ttyPtr->stateUpdated) { SETIOSTATE(ttyPtr->fs.fd, &ttyPtr->savedState); } #endif return FileCloseProc(instanceData, interp); } /* *---------------------------------------------------------------------- * * TtyOutputProc-- * * This function is invoked from the generic IO level to write output to * a TTY channel. * * Results: * The number of bytes written is returned or -1 on error. An output * argument contains a POSIX error code if an error occurred, or zero. * * Side effects: * Writes output on the output device of the channel if the channel is * not designated to be closed. * *---------------------------------------------------------------------- */ #if BAD_TIP35_FLUSH static int TtyOutputProc(instanceData, buf, toWrite, errorCodePtr) ClientData instanceData; /* File state. */ CONST char *buf; /* The data buffer. */ int toWrite; /* How many bytes to write? */ int *errorCodePtr; /* Where to store error code. */ { if (TclInExit()) { /* * Do not write data during Tcl exit. Serial port may block * preventing Tcl from exit. */ return toWrite; } else { return FileOutputProc(instanceData, buf, toWrite, errorCodePtr); } } #endif /* BAD_TIP35_FLUSH */ #ifdef USE_TERMIOS /* *---------------------------------------------------------------------- * * TtyModemStatusStr -- * * Converts a RS232 modem status list of readable flags * *---------------------------------------------------------------------- */ static void TtyModemStatusStr(status, dsPtr) int status; /* RS232 modem status */ Tcl_DString *dsPtr; /* Where to store string */ { #ifdef TIOCM_CTS Tcl_DStringAppendElement(dsPtr, "CTS"); |
︙ | ︙ | |||
848 849 850 851 852 853 854 | * Sets an option on a channel. * * Results: * A standard Tcl result. Also sets the interp's result on error if * interp is not NULL. * * Side effects: | | | | | 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 | * Sets an option on a channel. * * Results: * A standard Tcl result. Also sets the interp's result on error if * interp is not NULL. * * Side effects: * May modify an option on a device. Sets Error message if needed (by * calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtySetOptionProc(instanceData, interp, optionName, value) ClientData instanceData; /* File state. */ Tcl_Interp *interp; /* For error reporting - can be NULL. */ CONST char *optionName; /* Which option to set? */ CONST char *value; /* New value for option. */ { FileState *fsPtr = (FileState *) instanceData; |
︙ | ︙ | |||
881 882 883 884 885 886 887 888 | * Option -mode baud,parity,databits,stopbits */ if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { if (TtyParseMode(interp, value, &tty.baud, &tty.parity, &tty.data, &tty.stop) != TCL_OK) { return TCL_ERROR; } /* | > | > | < > | 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 | * Option -mode baud,parity,databits,stopbits */ if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { if (TtyParseMode(interp, value, &tty.baud, &tty.parity, &tty.data, &tty.stop) != TCL_OK) { return TCL_ERROR; } /* * system calls results should be checked there. - dl */ TtySetAttributes(fsPtr->fd, &tty); ((TtyState *) fsPtr)->stateUpdated = 1; return TCL_OK; } #ifdef USE_TERMIOS /* * Option -handshake none|xonxoff|rtscts|dtrdsr */ if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) { /* * Reset all handshake options. DTR and RTS are ON by default. */ GETIOSTATE(fsPtr->fd, &iostate); iostate.c_iflag &= ~(IXON | IXOFF | IXANY); #ifdef CRTSCTS iostate.c_cflag &= ~CRTSCTS; #endif /* CRTSCTS */ if (strncasecmp(value, "NONE", vlen) == 0) { /* leave all handshake options disabled */ |
︙ | ︙ | |||
934 935 936 937 938 939 940 941 942 943 944 945 946 947 | SETIOSTATE(fsPtr->fd, &iostate); return TCL_OK; } /* * Option -xchar {\x11 \x13} */ if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { GETIOSTATE(fsPtr->fd, &iostate); if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } if (argc == 2) { iostate.c_cc[VSTART] = argv[0][0]; | > | 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 | SETIOSTATE(fsPtr->fd, &iostate); return TCL_OK; } /* * Option -xchar {\x11 \x13} */ if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { GETIOSTATE(fsPtr->fd, &iostate); if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } if (argc == 2) { iostate.c_cc[VSTART] = argv[0][0]; |
︙ | ︙ | |||
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 | ckfree((char *) argv); return TCL_OK; } /* * Option -timeout msec */ if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) { int msec; GETIOSTATE(fsPtr->fd, &iostate); if (Tcl_GetInt(interp, value, &msec) != TCL_OK) { return TCL_ERROR; } iostate.c_cc[VMIN] = 0; iostate.c_cc[VTIME] = (msec == 0) ? 0 : (msec < 100) ? 1 : (msec+50)/100; SETIOSTATE(fsPtr->fd, &iostate); return TCL_OK; } /* * Option -ttycontrol {DTR 1 RTS 0 BREAK 0} */ if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { int i; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } if ((argc % 2) == 1) { if (interp) { | > > | 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 | ckfree((char *) argv); return TCL_OK; } /* * Option -timeout msec */ if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) { int msec; GETIOSTATE(fsPtr->fd, &iostate); if (Tcl_GetInt(interp, value, &msec) != TCL_OK) { return TCL_ERROR; } iostate.c_cc[VMIN] = 0; iostate.c_cc[VTIME] = (msec == 0) ? 0 : (msec < 100) ? 1 : (msec+50)/100; SETIOSTATE(fsPtr->fd, &iostate); return TCL_OK; } /* * Option -ttycontrol {DTR 1 RTS 0 BREAK 0} */ if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { int i; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } if ((argc % 2) == 1) { if (interp) { |
︙ | ︙ | |||
1057 1058 1059 1060 1061 1062 1063 | } /* *---------------------------------------------------------------------- * * TtyGetOptionProc -- * | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TtyGetOptionProc -- * * Gets a mode associated with an IO channel. If the optionName arg is * non NULL, retrieves the value of that option. If the optionName arg is * NULL, retrieves a list of alternating option names and values for the * given channel. * * Results: * A standard Tcl result. Also sets the supplied DString to the string * value of the option(s) returned. * * Side effects: * The string returned by this function is in static storage and may be * reused at any time subsequent to the call. Sets Error message if * needed (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtyGetOptionProc(instanceData, interp, optionName, dsPtr) ClientData instanceData; /* File state. */ Tcl_Interp *interp; /* For error reporting - can be NULL. */ CONST char *optionName; /* Option to get. */ Tcl_DString *dsPtr; /* Where to store value(s). */ { FileState *fsPtr = (FileState *) instanceData; |
︙ | ︙ | |||
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 | Tcl_DStringAppendElement(dsPtr, buf); } #ifdef USE_TERMIOS /* * get option -xchar */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-xchar"); Tcl_DStringStartSublist(dsPtr); } if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) { IOSTATE iostate; valid = 1; GETIOSTATE(fsPtr->fd, &iostate); sprintf(buf, "%c", iostate.c_cc[VSTART]); Tcl_DStringAppendElement(dsPtr, buf); sprintf(buf, "%c", iostate.c_cc[VSTOP]); Tcl_DStringAppendElement(dsPtr, buf); } if (len == 0) { Tcl_DStringEndSublist(dsPtr); } /* * get option -queue | > | | > | 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 | Tcl_DStringAppendElement(dsPtr, buf); } #ifdef USE_TERMIOS /* * get option -xchar */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-xchar"); Tcl_DStringStartSublist(dsPtr); } if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) { IOSTATE iostate; valid = 1; GETIOSTATE(fsPtr->fd, &iostate); sprintf(buf, "%c", iostate.c_cc[VSTART]); Tcl_DStringAppendElement(dsPtr, buf); sprintf(buf, "%c", iostate.c_cc[VSTOP]); Tcl_DStringAppendElement(dsPtr, buf); } if (len == 0) { Tcl_DStringEndSublist(dsPtr); } /* * get option -queue * option is readonly and returned by [fconfigure chan -queue] but not * returned by unnamed [fconfigure chan] */ if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) { int inQueue=0, outQueue=0; int inBuffered, outBuffered; valid = 1; #ifdef GETREADQUEUE GETREADQUEUE(fsPtr->fd, inQueue); #endif /* GETREADQUEUE */ |
︙ | ︙ | |||
1150 1151 1152 1153 1154 1155 1156 | Tcl_DStringAppendElement(dsPtr, buf); sprintf(buf, "%d", outBuffered+outQueue); Tcl_DStringAppendElement(dsPtr, buf); } /* * get option -ttystatus | | | | 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 | Tcl_DStringAppendElement(dsPtr, buf); sprintf(buf, "%d", outBuffered+outQueue); Tcl_DStringAppendElement(dsPtr, buf); } /* * get option -ttystatus * option is readonly and returned by [fconfigure chan -ttystatus] but not * returned by unnamed [fconfigure chan] */ if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) { int status; valid = 1; GETCONTROL(fsPtr->fd, &status); TtyModemStatusStr(status, dsPtr); } |
︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 | "mode queue ttystatus xchar"); #else /* !USE_TERMIOS */ "mode"); #endif /* USE_TERMIOS */ } } | < < < < < < < | 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 | "mode queue ttystatus xchar"); #else /* !USE_TERMIOS */ "mode"); #endif /* USE_TERMIOS */ } } #ifdef DIRECT_BAUD # define TtyGetSpeed(baud) ((unsigned) (baud)) # define TtyGetBaud(speed) ((int) (speed)) #else /* !DIRECT_BAUD */ static struct {int baud; unsigned long speed;} speeds[] = { #ifdef B0 |
︙ | ︙ | |||
1281 1282 1283 1284 1285 1286 1287 | }; /* *--------------------------------------------------------------------------- * * TtyGetSpeed -- * | | | | | 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 | }; /* *--------------------------------------------------------------------------- * * TtyGetSpeed -- * * Given a baud rate, get the mask value that should be stored in the * termios, termio, or sgttyb structure in order to select that baud * rate. * * Results: * As above. * * Side effects: * None. * |
︙ | ︙ | |||
1305 1306 1307 1308 1309 1310 1311 | int bestIdx, bestDiff, i, diff; bestIdx = 0; bestDiff = 1000000; /* * If the baud rate does not correspond to one of the known mask values, | | | | | | 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 | int bestIdx, bestDiff, i, diff; bestIdx = 0; bestDiff = 1000000; /* * If the baud rate does not correspond to one of the known mask values, * choose the mask value whose baud rate is closest to the specified baud * rate. */ for (i = 0; speeds[i].baud >= 0; i++) { diff = speeds[i].baud - baud; if (diff < 0) { diff = -diff; } if (diff < bestDiff) { bestIdx = i; bestDiff = diff; } } return speeds[bestIdx].speed; } /* *--------------------------------------------------------------------------- * * TtyGetBaud -- * * Given a speed mask value from a termios, termio, or sgttyb structure, * get the baus rate that corresponds to that mask value. * * Results: * As above. If the mask value was not recognized, 0 is returned. * * Side effects: * None. * |
︙ | ︙ | |||
1374 1375 1376 1377 1378 1379 1380 | * None. * *--------------------------------------------------------------------------- */ static void TtyGetAttributes(fd, ttyPtr) | | | | | | | | | | | | | | 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 | * None. * *--------------------------------------------------------------------------- */ static void TtyGetAttributes(fd, ttyPtr) int fd; /* Open file descriptor for serial port to be * queried. */ TtyAttrs *ttyPtr; /* Buffer filled with serial port * attributes. */ { IOSTATE iostate; int baud, parity, data, stop; GETIOSTATE(fd, &iostate); #ifdef USE_TERMIOS baud = TtyGetBaud(cfgetospeed(&iostate)); parity = 'n'; #ifdef PAREXT switch ((int) (iostate.c_cflag & (PARENB | PARODD | PAREXT))) { case PARENB : parity = 'e'; break; case PARENB | PARODD : parity = 'o'; break; case PARENB | PAREXT : parity = 's'; break; case PARENB | PARODD | PAREXT : parity = 'm'; break; } #else /* !PAREXT */ switch ((int) (iostate.c_cflag & (PARENB | PARODD))) { case PARENB : parity = 'e'; break; case PARENB | PARODD : parity = 'o'; break; } #endif /* !PAREXT */ data = iostate.c_cflag & CSIZE; data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8; stop = (iostate.c_cflag & CSTOPB) ? 2 : 1; #endif /* USE_TERMIOS */ #ifdef USE_TERMIO baud = TtyGetBaud(iostate.c_cflag & CBAUD); parity = 'n'; switch (iostate.c_cflag & (PARENB | PARODD | PAREXT)) { case PARENB : parity = 'e'; break; case PARENB | PARODD : parity = 'o'; break; case PARENB | PAREXT : parity = 's'; break; case PARENB | PARODD | PAREXT : parity = 'm'; break; } data = iostate.c_cflag & CSIZE; data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8; stop = (iostate.c_cflag & CSTOPB) ? 2 : 1; #endif /* USE_TERMIO */ |
︙ | ︙ | |||
1451 1452 1453 1454 1455 1456 1457 | } /* *--------------------------------------------------------------------------- * * TtySetAttributes -- * | | | | | | | 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 | } /* *--------------------------------------------------------------------------- * * TtySetAttributes -- * * Set the current attributes of the specified serial device. * * Results: * None. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static void TtySetAttributes(fd, ttyPtr) int fd; /* Open file descriptor for serial port to be * modified. */ TtyAttrs *ttyPtr; /* Buffer containing new attributes for serial * port. */ { IOSTATE iostate; #ifdef USE_TERMIOS int parity, data, flag; GETIOSTATE(fd, &iostate); |
︙ | ︙ | |||
1557 1558 1559 1560 1561 1562 1563 | } /* *--------------------------------------------------------------------------- * * TtyParseMode -- * | | | | | | | 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 | } /* *--------------------------------------------------------------------------- * * TtyParseMode -- * * Parse the "-mode" argument to the fconfigure command. The argument is * of the form baud,parity,data,stop. * * Results: * The return value is TCL_OK if the argument was successfully parsed, * TCL_ERROR otherwise. If TCL_ERROR is returned, an error message is * left in the interp's result (if interp is non-NULL). * * Side effects: * None. * *--------------------------------------------------------------------------- */ |
︙ | ︙ | |||
1593 1594 1595 1596 1597 1598 1599 1600 | if ((i != 4) || (mode[end] != '\0')) { if (interp != NULL) { Tcl_AppendResult(interp, bad, ": should be baud,parity,data,stop", NULL); } return TCL_ERROR; } /* | > | | < > | 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 | if ((i != 4) || (mode[end] != '\0')) { if (interp != NULL) { Tcl_AppendResult(interp, bad, ": should be baud,parity,data,stop", NULL); } return TCL_ERROR; } /* * Only allow setting mark/space parity on platforms that support it Make * sure to allow for the case where strchr is a macro. [Bug: 5089] */ if ( #if defined(PAREXT) || defined(USE_TERMIO) strchr("noems", parity) == NULL #else strchr("noe", parity) == NULL #endif /* PAREXT|USE_TERMIO */ ) { |
︙ | ︙ | |||
1638 1639 1640 1641 1642 1643 1644 | } /* *--------------------------------------------------------------------------- * * TtyInit -- * | | | < | | | | | | | | | | | 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 | } /* *--------------------------------------------------------------------------- * * TtyInit -- * * Given file descriptor that refers to a serial port, initialize the * serial port to a set of sane values so that Tcl can talk to a device * located on the serial port. Note that no initialization happens if * the initialize flag is not set; this is necessary for the correct * handling of UNIX console TTYs at startup. * * Results: * A pointer to a FileState suitable for use with Tcl_CreateChannel and * the ttyChannelType structure. * * Side effects: * Serial device initialized to non-blocking raw mode, similar to sockets * (if initialize flag is non-zero.) All other modes can be simulated on * top of this in Tcl. * *--------------------------------------------------------------------------- */ static FileState * TtyInit(fd, initialize) int fd; /* Open file descriptor for serial port to be * initialized. */ int initialize; { TtyState *ttyPtr; ttyPtr = (TtyState *) ckalloc((unsigned) sizeof(TtyState)); GETIOSTATE(fd, &ttyPtr->savedState); ttyPtr->stateUpdated = 0; |
︙ | ︙ | |||
1698 1699 1700 1701 1702 1703 1704 | ttyPtr->stateUpdated = 1; } iostate.sg_flags &= (EVENP | ODDP); iostate.sg_flags |= RAW; #endif /* USE_SGTTY */ /* | | < > | | | | | | 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 | ttyPtr->stateUpdated = 1; } iostate.sg_flags &= (EVENP | ODDP); iostate.sg_flags |= RAW; #endif /* USE_SGTTY */ /* * Only update if we're changing anything to avoid possible blocking. */ if (ttyPtr->stateUpdated) { SETIOSTATE(fd, &iostate); } } return &ttyPtr->fs; } #endif /* SUPPORTS_TTY */ /* *---------------------------------------------------------------------- * * TclpOpenFileChannel -- * * Open an file based channel on Unix systems. * * Results: * The new channel or NULL. If NULL, the output argument errorCodePtr is * set to a POSIX error and an error message is left in the interp's * result if interp is not NULL. * * Side effects: * 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; |
︙ | ︙ | |||
1749 1750 1751 1752 1753 1754 1755 | char channelName[16 + TCL_INTEGER_SPACE]; Tcl_ChannelType *channelTypePtr; #ifdef SUPPORTS_TTY int ctl_tty; #endif /* SUPPORTS_TTY */ switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { | | | | | | | | | | | | | | > | | > | | > > | | | | | | | > > > > > > > > > > > > | | | | | | 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 | char channelName[16 + TCL_INTEGER_SPACE]; Tcl_ChannelType *channelTypePtr; #ifdef SUPPORTS_TTY int ctl_tty; #endif /* SUPPORTS_TTY */ switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { case O_RDONLY: channelPermissions = TCL_READABLE; break; case O_WRONLY: channelPermissions = TCL_WRITABLE; break; case O_RDWR: channelPermissions = (TCL_READABLE | TCL_WRITABLE); break; default: /* * This may occurr if modeString was "", for example. */ Tcl_Panic("TclpOpenFileChannel: invalid mode value"); return NULL; } native = Tcl_FSGetNativePath(pathPtr); if (native == NULL) { return NULL; } #ifdef DJGPP mode |= O_BINARY; #endif 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 \"", Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); } return NULL; } /* * Set close-on-exec flag on the fd so that child processes will not * inherit this fd. */ fcntl(fd, F_SETFD, FD_CLOEXEC); sprintf(channelName, "file%d", fd); #ifdef SUPPORTS_TTY if (!ctl_tty && isatty(fd)) { /* * Initialize the serial port to a set of sane parameters. Especially * important if the remote device is set to echo and the serial port * driver was also set to echo -- as soon as a char were sent to the * serial port, the remote device would echo it, then the serial * driver would echo it back to the device, etc. */ translation = "auto crlf"; channelTypePtr = &ttyChannelType; fsPtr = TtyInit(fd, 1); } else #endif /* SUPPORTS_TTY */ { translation = NULL; channelTypePtr = &fileChannelType; fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); } #ifdef DEPRECATED if (channelTypePtr == &fileChannelType) { /* * TIP #218. Removed the code inserting the new structure into the * global list. This is now handled in the thread action callbacks, * and only there. */ fsPtr->nextPtr = NULL; } #endif /* DEPRECATED */ fsPtr->validMask = channelPermissions | TCL_EXCEPTION; fsPtr->fd = fd; fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, (ClientData) fsPtr, channelPermissions); 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. */ if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation", translation) != TCL_OK) { Tcl_Close(NULL, fsPtr->channel); return NULL; } |
︙ | ︙ | |||
1885 1886 1887 1888 1889 1890 1891 | if (isatty(fd)) { fsPtr = TtyInit(fd, 0); channelTypePtr = &ttyChannelType; sprintf(channelName, "serial%d", fd); } else #endif /* SUPPORTS_TTY */ if (getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0 | | | | | | | | | | 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 | if (isatty(fd)) { fsPtr = TtyInit(fd, 0); channelTypePtr = &ttyChannelType; sprintf(channelName, "serial%d", fd); } else #endif /* SUPPORTS_TTY */ if (getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0 && sockaddrLen > 0 && sockaddr.sa_family == AF_INET) { return MakeTcpClientChannelMode((ClientData) fd, mode); } else { channelTypePtr = &fileChannelType; fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState)); sprintf(channelName, "file%d", fd); } fsPtr->fd = fd; fsPtr->validMask = mode | TCL_EXCEPTION; fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, (ClientData) fsPtr, mode); return fsPtr->channel; } /* *---------------------------------------------------------------------- * * TcpBlockModeProc -- * * This function is invoked by the generic IO level to set blocking and * nonblocking mode on a TCP socket based channel. * * Results: * 0 if successful, errno when failed. * * Side effects: * Sets the device into blocking or nonblocking mode. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TcpBlockModeProc(instanceData, mode) ClientData instanceData; /* Socket state. */ int mode; /* The mode to set. Can be one of * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { TcpState *statePtr = (TcpState *) instanceData; int setting; #ifndef USE_FIONBIO setting = fcntl(statePtr->fd, F_GETFL); if (mode == TCL_MODE_BLOCKING) { |
︙ | ︙ | |||
1966 1967 1968 1969 1970 1971 1972 | } /* *---------------------------------------------------------------------- * * WaitForConnect -- * | | | | | | 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 | } /* *---------------------------------------------------------------------- * * WaitForConnect -- * * Waits for a connection on an asynchronously opened socket to be * completed. * * Results: * None. * * Side effects: * The socket is connected after this function returns. * *---------------------------------------------------------------------- */ static int WaitForConnect(statePtr, errorCodePtr) TcpState *statePtr; /* State of the socket. */ int *errorCodePtr; /* Where to store errors? */ { int timeOut; /* How long to wait. */ int state; /* Of calling TclWaitForFile. */ int flags; /* fcntl flags for the socket. */ /* * If an asynchronous connect is in progress, attempt to wait for it to * complete before reading. */ if (statePtr->flags & TCP_ASYNC_CONNECT) { if (statePtr->flags & TCP_ASYNC_SOCKET) { timeOut = 0; } else { timeOut = -1; |
︙ | ︙ | |||
2029 2030 2031 2032 2033 2034 2035 | } /* *---------------------------------------------------------------------- * * TcpInputProc -- * | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TcpInputProc -- * * This function is invoked by the generic IO level to read input from a * TCP socket based channel. * * NOTE: We cannot share code with FilePipeInputProc because here we must * use recv to obtain the input from the channel, not read. * * Results: * The number of bytes read is returned or -1 on error. An output * argument contains the POSIX error code on error, or zero if no error * occurred. * * Side effects: * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TcpInputProc(instanceData, buf, bufSize, errorCodePtr) ClientData instanceData; /* Socket state. */ char *buf; /* Where to store data read. */ int bufSize; /* How much space is available in the * buffer? */ int *errorCodePtr; /* Where to store error code. */ { TcpState *statePtr = (TcpState *) instanceData; int bytesRead, state; *errorCodePtr = 0; state = WaitForConnect(statePtr, errorCodePtr); |
︙ | ︙ | |||
2083 2084 2085 2086 2087 2088 2089 | } /* *---------------------------------------------------------------------- * * TcpOutputProc -- * | | | | | | | | 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 | } /* *---------------------------------------------------------------------- * * TcpOutputProc -- * * This function is invoked by the generic IO level to write output to a * TCP socket based channel. * * NOTE: We cannot share code with FilePipeOutputProc because here we * must use send, not write, to get reliable error reporting. * * Results: * The number of bytes written is returned. An output argument is set to * a POSIX error code if an error occurred, or zero. * * Side effects: * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2128 2129 2130 2131 2132 2133 2134 | } /* *---------------------------------------------------------------------- * * TcpCloseProc -- * | | | | | | | | | < | | | | | | < | | | | | 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 | } /* *---------------------------------------------------------------------- * * TcpCloseProc -- * * This function is invoked by the generic IO level to perform * channel-type-specific cleanup when a TCP socket based channel is * closed. * * Results: * 0 if successful, the value of errno if failed. * * Side effects: * Closes the socket of the channel. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TcpCloseProc(instanceData, interp) ClientData instanceData; /* The socket to close. */ Tcl_Interp *interp; /* For error reporting - unused. */ { TcpState *statePtr = (TcpState *) instanceData; int errorCode = 0; /* * Delete a file handler that may be active for this socket if this is a * server socket - the file handler was created automatically by Tcl as * part of the mechanism to accept new client connections. Channel * handlers are already deleted in the generic IO channel closing code * that called this function, so we do not have to delete them here. */ Tcl_DeleteFileHandler(statePtr->fd); if (close(statePtr->fd) < 0) { errorCode = errno; } ckfree((char *) statePtr); return errorCode; } /* *---------------------------------------------------------------------- * * TcpGetOptionProc -- * * Computes an option value for a TCP socket based channel, or a list of * all options and their values. * * Note: This code is based on code contributed by John Haxby. * * Results: * A standard Tcl result. The value of the specified option or a list of * all options and their values is returned in the supplied DString. Sets * Error message if needed. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TcpGetOptionProc(instanceData, interp, optionName, dsPtr) ClientData instanceData; /* Socket state. */ Tcl_Interp *interp; /* For error reporting - can be NULL. */ CONST char *optionName; /* Name of the option to retrieve the value * for, or NULL to get all options and their * values. */ 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; |
︙ | ︙ | |||
2261 2262 2263 2264 2265 2266 2267 | Tcl_DStringEndSublist(dsPtr); } else { return TCL_OK; } } else { /* * getpeername failed - but if we were asked for all the options | | | | | 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 | Tcl_DStringEndSublist(dsPtr); } else { return TCL_OK; } } else { /* * getpeername failed - but if we were asked for all the options * (len==0), don't flag an error at that point because it could be * an fconfigure request on a server socket (which have no peer). * Same must be done on win&mac. */ if (len) { if (interp) { Tcl_AppendResult(interp, "can't get peername: ", Tcl_PosixError(interp), (char *) NULL); } |
︙ | ︙ | |||
2332 2333 2334 2335 2336 2337 2338 | * * Initialize the notifier to watch the fd from this channel. * * Results: * None. * * Side effects: | | | | 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 | * * Initialize the notifier to watch the fd from this channel. * * Results: * None. * * Side effects: * Sets up the notifier so that a future event on the channel will be * seen by Tcl. * *---------------------------------------------------------------------- */ static void TcpWatchProc(instanceData, mask) ClientData instanceData; /* The socket state. */ |
︙ | ︙ | |||
2369 2370 2371 2372 2373 2374 2375 | } /* *---------------------------------------------------------------------- * * TcpGetHandleProc -- * | | | | | | 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 | } /* *---------------------------------------------------------------------- * * TcpGetHandleProc -- * * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a * TCP socket based channel. * * Results: * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2400 2401 2402 2403 2404 2405 2406 | } /* *---------------------------------------------------------------------- * * CreateSocket -- * | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * CreateSocket -- * * This function opens a new socket in client or server mode and * initializes the TcpState structure. * * Results: * Returns a new TcpState, or NULL with an error in the interp's result, * if interp is not NULL. * * Side effects: * Opens a socket. * *---------------------------------------------------------------------- */ static TcpState * CreateSocket(interp, port, host, server, myaddr, myport, async) Tcl_Interp *interp; /* For error reporting; can be NULL. */ int port; /* Port number to open. */ CONST char *host; /* Name of host on which to open port. NULL * implies INADDR_ANY */ int server; /* 1 if socket should be a server socket, else * 0 for a client socket. */ CONST char *myaddr; /* Optional client-side address */ int myport; /* Optional client-side port */ int async; /* If nonzero and creating a client socket, * attempt to do an async connect. Otherwise * do a synchronous connect or bind. */ { int status, sock, asyncConnect, curState, origState; |
︙ | ︙ | |||
2448 2449 2450 2451 2452 2453 2454 | sock = socket(AF_INET, SOCK_STREAM, 0); if (sock < 0) { goto addressError; } /* | | | | 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 | sock = socket(AF_INET, SOCK_STREAM, 0); if (sock < 0) { goto addressError; } /* * Set the close-on-exec flag so that the socket will not get inherited by * child processes. */ fcntl(sock, F_SETFD, FD_CLOEXEC); /* * Set kernel space buffering */ |
︙ | ︙ | |||
2475 2476 2477 2478 2479 2480 2481 | status = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status, sizeof(status)); status = bind(sock, (struct sockaddr *) &sockaddr, sizeof(struct sockaddr)); if (status != -1) { status = listen(sock, SOMAXCONN); | | | | | | | 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 | status = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status, sizeof(status)); status = bind(sock, (struct sockaddr *) &sockaddr, sizeof(struct sockaddr)); if (status != -1) { status = listen(sock, SOMAXCONN); } } else { if (myaddr != NULL || myport != 0) { curState = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &curState, sizeof(curState)); status = bind(sock, (struct sockaddr *) &mysockaddr, sizeof(struct sockaddr)); if (status < 0) { goto bindError; } } /* * Attempt to connect. The connect may fail at present with an * EINPROGRESS but at a later time it will complete. The caller will * set up a file handler on the socket if she is interested in being * informed when the connect completes. */ if (async) { #ifndef USE_FIONBIO origState = fcntl(sock, F_GETFL); curState = origState | O_NONBLOCK; status = fcntl(sock, F_SETFL, curState); |
︙ | ︙ | |||
2519 2520 2521 2522 2523 2524 2525 | asyncConnect = 1; status = 0; } } else { /* * Here we are if the connect succeeds. In case of an * asynchronous connect we have to reset the channel to | | | | > | | 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 | asyncConnect = 1; status = 0; } } else { /* * Here we are if the connect succeeds. In case of an * asynchronous connect we have to reset the channel to * blocking mode. This appears to happen not very often, but * e.g. on a HP 9000/800 under HP-UX B.11.00 we enter this * stage. [Bug: 4388] */ if (async) { #ifndef USE_FIONBIO origState = fcntl(sock, F_GETFL); curState = origState & ~(O_NONBLOCK); status = fcntl(sock, F_SETFL, curState); #else /* USE_FIONBIO */ curState = 0; status = ioctl(sock, FIONBIO, &curState); #endif /* !USE_FIONBIO */ } } } } bindError: if (status < 0) { if (interp != NULL) { Tcl_AppendResult(interp, "couldn't open socket: ", Tcl_PosixError(interp), (char *) NULL); } if (sock != -1) { close(sock); |
︙ | ︙ | |||
2562 2563 2564 2565 2566 2567 2568 | if (asyncConnect) { statePtr->flags = TCP_ASYNC_CONNECT; } statePtr->fd = sock; return statePtr; | | | | | 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 | if (asyncConnect) { statePtr->flags = TCP_ASYNC_CONNECT; } statePtr->fd = sock; return statePtr; addressError: if (sock != -1) { close(sock); } if (interp != NULL) { Tcl_AppendResult(interp, "couldn't open socket: ", Tcl_PosixError(interp), (char *) NULL); } return NULL; } /* *---------------------------------------------------------------------- * * CreateSocketAddress -- * * This function initializes a sockaddr structure for a host and port. * * Results: * 1 if the host was valid, 0 if the host could not be converted to an IP * address. * * Side effects: * Fills in the *sockaddrPtr structure. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2644 2645 2646 2647 2648 2649 2650 | } if (native != NULL) { Tcl_DStringFree(&ds); } } /* | | | | | | | | 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 | } if (native != NULL) { Tcl_DStringFree(&ds); } } /* * NOTE: On 64 bit machines the assignment below is rumored to not do the * right thing. Please report errors related to this if you observe * incorrect behavior on 64 bit machines such as DEC Alphas. Should we * modify this code to do an explicit memcpy? */ sockaddrPtr->sin_addr.s_addr = addr.s_addr; return 1; /* Success. */ } /* *---------------------------------------------------------------------- * * Tcl_OpenTcpClient -- * * Opens a TCP client socket and creates a channel around it. * * Results: * The channel or NULL if failed. An error message is returned in the * interpreter on failure. * * Side effects: * Opens a client socket and creates a new channel. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2784 2785 2786 2787 2788 2789 2790 | *---------------------------------------------------------------------- * * Tcl_OpenTcpServer -- * * Opens a TCP server socket and creates a channel around it. * * Results: | | | < | 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 | *---------------------------------------------------------------------- * * Tcl_OpenTcpServer -- * * Opens a TCP server socket and creates a channel around it. * * Results: * The channel or NULL if failed. If an error occurred, an error message * is left in the interp's result if interp is not NULL. * * Side effects: * Opens a server socket and creates a new channel. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2820 2821 2822 2823 2824 2825 2826 | return NULL; } statePtr->acceptProc = acceptProc; statePtr->acceptProcData = acceptProcData; /* | | | | | | | | | 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 | return NULL; } statePtr->acceptProc = acceptProc; statePtr->acceptProcData = acceptProcData; /* * Set up the callback mechanism for accepting connections from new * clients. */ Tcl_CreateFileHandler(statePtr->fd, TCL_READABLE, TcpAccept, (ClientData) statePtr); sprintf(channelName, "sock%d", statePtr->fd); statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, (ClientData) statePtr, 0); return statePtr->channel; } /* *---------------------------------------------------------------------- * * TcpAccept -- * Accept a TCP socket connection. This is called by the event loop. * * Results: * None. * * Side effects: * Creates a new connection socket. Calls the registered callback for the * connection acceptance mechanism. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void TcpAccept(data, mask) 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) { return; } /* * Set close-on-exec flag to prevent the newly accepted socket from being * inherited by child processes. */ (void) fcntl(newsock, F_SETFD, FD_CLOEXEC); newSockState = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); newSockState->flags = 0; |
︙ | ︙ | |||
2902 2903 2904 2905 2906 2907 2908 | } /* *---------------------------------------------------------------------- * * TclpGetDefaultStdChannel -- * | | | | < > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TclpGetDefaultStdChannel -- * * Creates channels for standard input, standard output or standard error * output if they do not already exist. * * Results: * Returns the specified default standard channel, or NULL. * * Side effects: * May cause the creation of a standard channel and the underlying file. * *---------------------------------------------------------------------- */ Tcl_Channel TclpGetDefaultStdChannel(type) 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: Tcl_Panic("TclGetDefaultStdChannel: Unexpected channel type"); break; } #undef ZERO_OFFSET #undef ERROR_OFFSET channel = Tcl_MakeFileChannel((ClientData) fd, mode); if (channel == NULL) { |
︙ | ︙ | |||
2989 2990 2991 2992 2993 2994 2995 | } /* *---------------------------------------------------------------------- * * Tcl_GetOpenFile -- * | | | | | | | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_GetOpenFile -- * * Given a name of a channel registered in the given interpreter, returns * a FILE * for it. * * Results: * A standard Tcl result. If the channel is registered in the given * interpreter and it is managed by the "file" channel driver, and it is * open for the requested mode, then the output parameter filePtr is set * to a FILE * for the underlying file. On error, the filePtr is not set, * TCL_ERROR is returned and an error message is left in the interp's * result. * * Side effects: * May invoke fdopen to create the FILE * for the requested file. * *---------------------------------------------------------------------- */ int Tcl_GetOpenFile(interp, chanID, forWriting, checkUsage, filePtr) Tcl_Interp *interp; /* Interpreter in which to find file. */ CONST char *chanID; /* String that identifies file. */ int forWriting; /* 1 means the file is going to be used for * writing, 0 means for reading. */ int checkUsage; /* 1 means verify that the file was opened in * a mode that allows the access specified by * "forWriting". Ignored, we always check that * the channel is open for the requested * mode. */ ClientData *filePtr; /* Store pointer to FILE structure here. */ { Tcl_Channel chan; int chanMode; Tcl_ChannelType *chanTypePtr; ClientData data; int fd; FILE *f; chan = Tcl_GetChannel(interp, chanID, &chanMode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) { Tcl_AppendResult(interp, "\"", chanID, "\" wasn't opened for writing", (char *) NULL); return TCL_ERROR; } else if ((!(forWriting)) && ((chanMode & TCL_READABLE) == 0)) { Tcl_AppendResult(interp, "\"", chanID, "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } /* * We allow creating a FILE * out of file based, pipe based and socket * based channels. We currently do not allow any other channel types, * because it is likely that stdio will not know what to do with them. |
︙ | ︙ | |||
3060 3061 3062 3063 3064 3065 3066 | if (Tcl_GetChannelHandle(chan, (forWriting ? TCL_WRITABLE : TCL_READABLE), (ClientData*) &data) == TCL_OK) { fd = (int) data; /* * The call to fdopen below is probably dangerous, since it will | | | | | | | | | | | | < | | | | | | | | | 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 | if (Tcl_GetChannelHandle(chan, (forWriting ? TCL_WRITABLE : TCL_READABLE), (ClientData*) &data) == TCL_OK) { fd = (int) data; /* * The call to fdopen below is probably dangerous, since it will * truncate an existing file if the file is being opened for * writing.... */ f = fdopen(fd, (forWriting ? "w" : "r")); if (f == NULL) { Tcl_AppendResult(interp, "cannot get a FILE * for \"", chanID, "\"", (char *) NULL); return TCL_ERROR; } *filePtr = (ClientData) f; return TCL_OK; } } Tcl_AppendResult(interp, "\"", chanID, "\" cannot be used to get a FILE *", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclUnixWaitForFile -- * * This function waits synchronously for a file to become readable or * writable, with an optional timeout. * * Results: * The return value is an OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions that are * present on file at the time of the return. This function will not * return until either "timeout" milliseconds have elapsed or at least * one of the conditions given by mask has occurred for file (a return * value of 0 means that a timeout occurred). No normal events will be * serviced during the execution of this function. * * Side effects: * Time passes. * *---------------------------------------------------------------------- */ int TclUnixWaitForFile(fd, mask, timeout) int fd; /* Handle for file on which to wait. */ int mask; /* What to wait for: OR'ed combination of * TCL_READABLE, TCL_WRITABLE, and * TCL_EXCEPTION. */ int timeout; /* Maximum amount of time to wait for one of * the conditions in mask to occur, in * milliseconds. A value of 0 means don't * wait at all, and a value of -1 means wait * forever. */ { Tcl_Time abortTime, now; struct timeval blockTime, *timeoutPtr; int index, bit, numFound, result = 0; fd_mask readyMasks[3*MASK_SIZE]; fd_mask *maskp[3]; /* This array reflects the readable/writable * conditions that were found to exist by the * last call to select. */ /* * If there is a non-zero finite timeout, compute the time when we give * up. */ if (timeout > 0) { Tcl_GetTime(&now); abortTime.sec = now.sec + timeout/1000; abortTime.usec = now.usec + (timeout%1000)*1000; if (abortTime.usec >= 1000000) { |
︙ | ︙ | |||
3159 3160 3161 3162 3163 3164 3165 | Tcl_Panic("TclWaitForFile can't handle file id %d", fd); } memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); index = fd/(NBBY*sizeof(fd_mask)); bit = 1 << (fd%(NBBY*sizeof(fd_mask))); /* | | | | 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 | Tcl_Panic("TclWaitForFile can't handle file id %d", fd); } memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); index = fd/(NBBY*sizeof(fd_mask)); bit = 1 << (fd%(NBBY*sizeof(fd_mask))); /* * Loop in a mini-event loop of our own, waiting for either the file to * become ready or a timeout to occur. */ while (1) { if (timeout > 0) { blockTime.tv_sec = abortTime.sec - now.sec; blockTime.tv_usec = abortTime.usec - now.usec; if (blockTime.tv_usec < 0) { |
︙ | ︙ | |||
3195 3196 3197 3198 3199 3200 3201 | (readyMasks+2*(MASK_SIZE))[index] |= bit; } /* * Wait for the event or a timeout. */ | > | > > | 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 | (readyMasks+2*(MASK_SIZE))[index] |= bit; } /* * Wait for the event or a timeout. */ /* * This is needed to satisfy GCC 3.3's strict aliasing rules. */ maskp[0] = &readyMasks[0]; maskp[1] = &readyMasks[MASK_SIZE]; maskp[2] = &readyMasks[2*MASK_SIZE]; numFound = select(fd+1, (SELECT_MASK *) maskp[0], (SELECT_MASK *) maskp[1], (SELECT_MASK *) maskp[2], timeoutPtr); if (numFound == 1) { |
︙ | ︙ | |||
3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 | && (abortTime.usec <= now.usec))) { break; } } return result; } /* *---------------------------------------------------------------------- * | > | | < | > > > > > > | > > > > > | | > > > > > > > > | > > > > > | > > | > > > | | < > | | > > | | > | > > | | > > > > | > > > > > > | > > > > > > > > > > | 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 | && (abortTime.usec <= now.usec))) { break; } } return result; } #ifdef DEPRECATED /* *---------------------------------------------------------------------- * * FileThreadActionProc -- * * Insert or remove any thread local refs to this channel. * * Results: * None. * * Side effects: * None. This is a no-op under unix. * *---------------------------------------------------------------------- */ static void FileThreadActionProc (instanceData, action) ClientData instanceData; int action; { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileState *fsPtr = (FileState *) instanceData; if (action == TCL_CHANNEL_THREAD_INSERT) { fsPtr->nextPtr = tsdPtr->firstFilePtr; tsdPtr->firstFilePtr = fsPtr; } else { FileState **nextPtrPtr; int removed = 0; for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL; nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { if ((*nextPtrPtr) == fsPtr) { (*nextPtrPtr) = fsPtr->nextPtr; removed = 1; break; } } /* * This could happen if the channel was created in one thread and then * moved to another without updating the thread local data in each * thread. */ if (!removed) { Tcl_Panic("file info ptr not on thread channel list"); } } } #endif /* *---------------------------------------------------------------------- * * FileTruncateProc -- * * Truncates a file to a given length. * * Results: * 0 if the operation succeeded, and -1 if it failed (in which case * *errorCodePtr will be set to errno). * * Side effects: * The underlying file is potentially truncated. This can have a wide * variety of side effects, including moving file pointers that point at * places later in the file than the truncate point. * *---------------------------------------------------------------------- */ static int FileTruncateProc(instanceData, length) ClientData instanceData; Tcl_WideInt length; { FileState *fsPtr = (FileState *) instanceData; int result; #ifdef HAVE_TYPE_OFF64_T /* * We assume this goes with the type for now... */ result = ftruncate64(fsPtr->fd, (off64_t) length); #else result = ftruncate(fsPtr->fd, (off_t) length); #endif if (result) { return errno; } return 0; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclUnixEvent.c.
1 2 3 4 5 6 7 | /* * tclUnixEvent.c -- * * This file implements Unix specific event related routines. * * Copyright (c) 1997 by Sun Microsystems, Inc. * | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclUnixEvent.c -- * * This file implements Unix specific event related routines. * * 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: tclUnixEvent.c,v 1.5.2.2 2005/08/02 18:16:56 dgp Exp $ */ #include "tclInt.h" /* *---------------------------------------------------------------------- * * Tcl_Sleep -- * * Delay execution for the specified number of milliseconds. |
︙ | ︙ | |||
30 31 32 33 34 35 36 | */ void Tcl_Sleep(ms) int ms; /* Number of milliseconds to sleep. */ { struct timeval delay; | | | | | < > > > | > | > | | | > > > > > > > | | > > > > > > > > | 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 | */ void Tcl_Sleep(ms) int ms; /* Number of milliseconds to sleep. */ { struct timeval delay; Tcl_Time before, after, vdelay; /* * The only trick here is that select appears to return early under some * conditions, so we have to check to make sure that the right amount of * time really has elapsed. If it's too early, go back to sleep again. */ Tcl_GetTime(&before); after = before; after.sec += ms/1000; after.usec += (ms%1000)*1000; if (after.usec > 1000000) { after.usec -= 1000000; after.sec += 1; } while (1) { /* * TIP #233: Scale from virtual time to real-time for select. */ vdelay.sec = after.sec - before.sec; vdelay.usec = after.usec - before.usec; if (vdelay.usec < 0) { vdelay.usec += 1000000; vdelay.sec -= 1; } if ((vdelay.sec != 0) || (vdelay.usec != 0)) { (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData); } delay.tv_sec = vdelay.sec; delay.tv_usec = vdelay.usec; /* * Special note: must convert delay.tv_sec to int before comparing to * zero, since delay.tv_usec is unsigned on some platforms. */ if ((((int) delay.tv_sec) < 0) || ((delay.tv_usec == 0) && (delay.tv_sec == 0))) { break; } (void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0, (SELECT_MASK *) 0, &delay); Tcl_GetTime(&before); } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclUnixFCmd.c.
1 2 3 | /* * tclUnixFCmd.c * | | | | | | | | | < | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | /* * 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.40.2.5 2005/10/08 13:45:04 dgp 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. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: * 1. Redistributions of source code must retain the above copyright notice, * this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * 3. All advertising materials mentioning features or use of this software * must display the following acknowledgement: * This product includes software developed by the University of * California, Berkeley and its contributors. * 4. Neither the name of the University nor the names of its contributors may * be used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE * DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * DAMAGE. */ #include "tclInt.h" #include <utime.h> #include <grp.h> #ifndef HAVE_ST_BLKSIZE #ifndef NO_FSTATFS #include <sys/statfs.h> #endif #endif /* * The following constants specify the type of callback when * TraverseUnixTree() calls the traverseProc() */ #define DOTREE_PRED 1 /* pre-order directory */ #define DOTREE_POSTD 2 /* post-order directory */ #define DOTREE_F 3 /* regular file */ /* * Callbacks for file attributes code. */ static int GetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, |
︙ | ︙ | |||
105 106 107 108 109 110 111 | typedef int (TraversalProc) _ANSI_ARGS_((Tcl_DString *srcPtr, Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, int type, Tcl_DString *errorPtr)); /* * Constants and variables necessary for file attributes subcommand. | | | | | > | > > | < < | < < > | < < | < < < | | | | > > > > > > > > > > > > > > > > | 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 | typedef int (TraversalProc) _ANSI_ARGS_((Tcl_DString *srcPtr, Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, int type, Tcl_DString *errorPtr)); /* * Constants and variables necessary for file attributes subcommand. * * IMPORTANT: The permissions attribute is assumed to be the third item (i.e. * to be indexed with '2' in arrays) in code in tclIOUtil.c and possibly * elsewhere in Tcl's core. */ #ifdef DJGPP /* * See contrib/djgpp/tclDjgppFCmd.c for definition. */ extern TclFileAttrProcs tclpFileAttrProcs[]; extern char *tclpFileAttrStrings[]; #else enum { UNIX_GROUP_ATTRIBUTE, UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE, #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) UNIX_READONLY_ATTRIBUTE, #endif #ifdef MAC_OSX_TCL MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE, MACOSX_RSRCLENGTH_ATTRIBUTE, #endif UNIX_INVALID_ATTRIBUTE /* lint - last enum value needs no trailing , */ }; CONST char *tclpFileAttrStrings[] = { "-group", "-owner", "-permissions", #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) "-readonly", #endif #ifdef MAC_OSX_TCL "-creator", "-type", "-hidden", "-rsrclength", #endif (char *) NULL }; CONST TclFileAttrProcs tclpFileAttrProcs[] = { {GetGroupAttribute, SetGroupAttribute}, {GetOwnerAttribute, SetOwnerAttribute}, {GetPermissionsAttribute, SetPermissionsAttribute}, #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) {GetReadOnlyAttribute, SetReadOnlyAttribute}, #endif #ifdef MAC_OSX_TCL {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, #endif }; #endif /* * This is the maximum number of consecutive readdir/unlink calls that can be * made (with no intervening rewinddir or closedir/opendir) before triggering * a bug that makes readdir return NULL even though some directory entries * have not been processed. The bug afflicts SunOS's readdir when applied to * ufs file systems and Darwin 6.5's (and OSX v.10.3.8's) HFS+. JH found the * Darwin readdir to reset at 172, so 150 is chosen to be conservative. We * can't do a general rewind on failure as NFS can create special files that * recreate themselves when you try and delete them. 8.4.8 added a solution * that was affected by a single such NFS file, this solution should not be * affected by less than THRESHOLD such files. [Bug 1034337] */ #define MAX_READDIR_UNLINK_THRESHOLD 150 /* * Declarations for local procedures defined in this file: */ static int CopyFileAtts _ANSI_ARGS_((CONST char *src, CONST char *dst, CONST Tcl_StatBuf *statBufPtr)); static int DoCopyFile _ANSI_ARGS_((CONST char *srcPtr, |
︙ | ︙ | |||
190 191 192 193 194 195 196 | static int TraverseUnixTree _ANSI_ARGS_(( TraversalProc *traversalProc, Tcl_DString *sourcePtr, Tcl_DString *destPtr, Tcl_DString *errorPtr, int doRewind)); #ifdef PURIFY /* | | | > < | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | 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 | static int TraverseUnixTree _ANSI_ARGS_(( TraversalProc *traversalProc, Tcl_DString *sourcePtr, Tcl_DString *destPtr, Tcl_DString *errorPtr, int doRewind)); #ifdef PURIFY /* * realpath and purify don't mix happily. It has been noted that realpath * should not be used with purify because of bogus warnings, but just * memset'ing the resolved path will squelch those. This assumes we are * passing the standard MAXPATHLEN size resolved arg. */ static char * Realpath _ANSI_ARGS_((CONST char *path, char *resolved)); char * Realpath(path, resolved) CONST char *path; char *resolved; { memset(resolved, 0, MAXPATHLEN); return realpath(path, resolved); } #else #define Realpath realpath #endif /* *--------------------------------------------------------------------------- * * TclpObjRenameFile, DoRenameFile -- * * Changes the name of an existing file or directory, from src to dst. * If src and dst refer to the same file or directory, does nothing and * returns success. Otherwise if dst already exists, it will be deleted * and replaced by src subject to the following conditions: * If src is a directory, dst may be an empty directory. * If src is a file, dst may be a file. * In any other situation where dst already exists, the rename will fail. * * Results: * If the directory was successfully created, returns TCL_OK. Otherwise * the return value is TCL_ERROR and errno is set to indicate the error. * Some possible values for errno are: * * EACCES: src or dst parent directory can't be read and/or written. * EEXIST: dst is a non-empty directory. * EINVAL: src is a root directory or dst is a subdirectory of src. * EISDIR: dst is a directory, but src is not. * ENOENT: src doesn't exist, or src or dst is "". * ENOTDIR: src is a directory, but dst is not. * EXDEV: src and dst are on different filesystems. * * Side effects: * The implementation of rename may allow cross-filesystem renames, but * the caller should be prepared to emulate it with copy and delete if * errno is EXDEV. * *--------------------------------------------------------------------------- */ int TclpObjRenameFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), Tcl_FSGetNativePath(destPathPtr)); } static int DoRenameFile(src, dst) CONST char *src; /* Pathname of file or dir to be renamed * (native). */ CONST char *dst; /* New pathname of file or directory * (native). */ { if (rename(src, dst) == 0) { /* INTL: Native. */ return TCL_OK; } if (errno == ENOTEMPTY) { errno = EEXIST; } /* * IRIX returns EIO when you attept to move a directory into itself. We * just map EIO to EINVAL get the right message on SGI. Most platforms * don't return EIO except in really strange cases. */ if (errno == EIO) { errno = EINVAL; } #ifndef NO_REALPATH /* * SunOS 4.1.4 reports overwriting a non-empty directory with a directory * as EINVAL instead of EEXIST (first rule out the correct EINVAL result * code for moving a directory into itself). Must be conditionally * compiled because realpath() not defined on all systems. */ if (errno == EINVAL) { char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN]; DIR *dirPtr; Tcl_DirEntry *dirEntPtr; if ((Realpath((char *) src, srcPath) != NULL) /* INTL: Native. */ && (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native */ && (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) { 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); |
︙ | ︙ | |||
321 322 323 324 325 326 327 | #endif /* !NO_REALPATH */ if (strcmp(src, "/") == 0) { /* * Alpha reports renaming / as EBUSY and Linux reports it as EACCES, * instead of EINVAL. */ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | < | | < | | | | | | | | < | | | | | > > > > > > > | | | | < | | | | | | | | | | | | | | | | | | | | 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 | #endif /* !NO_REALPATH */ if (strcmp(src, "/") == 0) { /* * Alpha reports renaming / as EBUSY and Linux reports it as EACCES, * instead of EINVAL. */ errno = EINVAL; } /* * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a file * across filesystems and the parent directory of that file is not * writable. Most other systems return EXDEV. Does nothing to correct this * behavior. */ return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * TclpObjCopyFile, DoCopyFile -- * * Copy a single file (not a directory). If dst already exists and is not * a directory, it is removed. * * Results: * If the file was successfully copied, returns TCL_OK. Otherwise the * return value is TCL_ERROR and errno is set to indicate the error. * Some possible values for errno are: * * EACCES: src or dst parent directory can't be read and/or written. * EISDIR: src or dst is a directory. * ENOENT: src doesn't exist. src or dst is "". * * Side effects: * This procedure will also copy symbolic links, block, and character * devices, and fifos. For symbolic links, the links themselves will be * copied and not what they point to. For the other special file types, * the directory entry will be copied and not the contents of the device * that it refers to. * *--------------------------------------------------------------------------- */ int TclpObjCopyFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), Tcl_FSGetNativePath(destPathPtr)); } static int DoCopyFile(src, dst) CONST char *src; /* Pathname of file to be copied (native). */ CONST char *dst; /* Pathname of file to copy to (native). */ { 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) { return TCL_ERROR; } } switch ((int) (srcStatBuf.st_mode & S_IFMT)) { #ifndef DJGPP case S_IFLNK: { char link[MAXPATHLEN]; int length; length = readlink(src, link, sizeof(link)); /* INTL: Native. */ if (length == -1) { return TCL_ERROR; } link[length] = '\0'; if (symlink(link, dst) < 0) { /* INTL: Native. */ return TCL_ERROR; } break; } #endif case S_IFBLK: case S_IFCHR: if (mknod(dst, srcStatBuf.st_mode, /* INTL: Native. */ srcStatBuf.st_rdev) < 0) { return TCL_ERROR; } return CopyFileAtts(src, dst, &srcStatBuf); case S_IFIFO: if (mkfifo(dst, srcStatBuf.st_mode) < 0) { /* INTL: Native. */ return TCL_ERROR; } return CopyFileAtts(src, dst, &srcStatBuf); default: return TclUnixCopyFile(src, dst, &srcStatBuf, 0); } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclUnixCopyFile - * * Helper function for TclpCopyFile. Copies one regular file, using * read() and write(). * * Results: * A standard Tcl result. * * Side effects: * A file is copied. Dst will be overwritten if it exists. * *---------------------------------------------------------------------- */ int TclUnixCopyFile(src, dst, statBufPtr, dontCopyAtts) CONST char *src; /* Pathname of file to copy (native). */ CONST char *dst; /* Pathname of file to create/overwrite * (native). */ CONST Tcl_StatBuf *statBufPtr; /* Used to determine mode and blocksize. */ int dontCopyAtts; /* If flag set, don't copy attributes. */ { int srcFd, dstFd; unsigned blockSize; /* Optimal I/O blocksize for filesystem */ char *buffer; /* Data buffer for copy */ size_t nread; #ifdef DJGPP #define BINMODE |O_BINARY #else #define BINMODE #endif if ((srcFd = TclOSopen(src, O_RDONLY BINMODE, 0)) < 0) { /* INTL: Native */ return TCL_ERROR; } dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY BINMODE, /* INTL: Native */ statBufPtr->st_mode); if (dstFd < 0) { close(srcFd); return TCL_ERROR; } /* * Try to work out the best size of buffer to use for copying. If we * can't, it's no big deal as we can just use a (32-bit) page, since * that's likely to be fairly efficient anyway. */ #ifdef HAVE_ST_BLKSIZE blockSize = statBufPtr->st_blksize; #else #ifndef NO_FSTATFS { struct statfs fs; if (fstatfs(srcFd, &fs, sizeof(fs), 0) == 0) { blockSize = fs.f_bsize; } else { blockSize = 4096; } } #else blockSize = 4096; #endif #endif buffer = ckalloc(blockSize); while (1) { nread = read(srcFd, buffer, blockSize); if ((nread == -1) || (nread == 0)) { break; } if (write(dstFd, buffer, nread) != nread) { nread = (size_t) -1; break; } } ckfree(buffer); close(srcFd); if ((close(dstFd) != 0) || (nread == -1)) { unlink(dst); /* INTL: Native. */ return TCL_ERROR; } if (!dontCopyAtts && CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) { /* * The copy succeeded, but setting the permissions failed, so be in a * consistent state, we remove the file that was created by the copy. */ unlink(dst); /* INTL: Native. */ return TCL_ERROR; } return TCL_OK; } /* *--------------------------------------------------------------------------- * * TclpObjDeleteFile, TclpDeleteFile -- * * Removes a single file (not a directory). * * Results: * If the file was successfully deleted, returns TCL_OK. Otherwise the * return value is TCL_ERROR and errno is set to indicate the error. * Some possible values for errno are: * * EACCES: a parent directory can't be read and/or written. * EISDIR: path is a directory. * ENOENT: path doesn't exist or is "". * * Side effects: * The file is deleted, even if it is read-only. * *--------------------------------------------------------------------------- */ int TclpObjDeleteFile(pathPtr) Tcl_Obj *pathPtr; { return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr)); } int TclpDeleteFile(path) CONST char *path; /* Pathname of file to be removed (native). */ { if (unlink(path) != 0) { /* INTL: Native. */ return TCL_ERROR; } return TCL_OK; } /* *--------------------------------------------------------------------------- * * TclpCreateDirectory, DoCreateDirectory -- * * Creates the specified directory. All parent directories of the * specified directory must already exist. The directory is automatically * created with permissions so that user can access the new directory and * create new files or subdirectories in it. * * Results: * If the directory was successfully created, returns TCL_OK. Otherwise * the return value is TCL_ERROR and errno is set to indicate the error. * Some possible values for errno are: * * EACCES: a parent directory can't be read and/or written. * EEXIST: path already exists. * ENOENT: a parent directory doesn't exist. * * Side effects: * A directory is created with the current umask, except that permission * for u+rwx will always be added. * *--------------------------------------------------------------------------- */ int TclpObjCreateDirectory(pathPtr) Tcl_Obj *pathPtr; { return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr)); } static int |
︙ | ︙ | |||
640 641 642 643 644 645 646 | } /* *--------------------------------------------------------------------------- * * TclpObjCopyDirectory -- * | | | | < | | | | | | | | < | | | | | | | | | 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 | } /* *--------------------------------------------------------------------------- * * TclpObjCopyDirectory -- * * Recursively copies a directory. The target directory dst must not * already exist. Note that this function does not merge two directory * hierarchies, even if the target directory is an an empty directory. * * Results: * If the directory was successfully copied, returns TCL_OK. Otherwise * the return value is TCL_ERROR, errno is set to indicate the error, and * the pathname of the file that caused the error is stored in errorPtr. * See TclpObjCreateDirectory and TclpObjCopyFile for a description of * possible values for errno. * * Side effects: * An exact copy of the directory hierarchy src will be created with the * name dst. If an error occurs, the error will be returned immediately, * and remaining files will not be processed. * *--------------------------------------------------------------------------- */ int TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; Tcl_Obj **errorPtr; { Tcl_DString ds; Tcl_DString srcString, dstString; int ret; Tcl_Obj *transPtr; transPtr = Tcl_FSGetTranslatedPath(NULL,srcPathPtr); Tcl_UtfToExternalDString(NULL, (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), -1, &srcString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr); Tcl_UtfToExternalDString(NULL, (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), -1, &dstString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds, 0); Tcl_DStringFree(&srcString); |
︙ | ︙ | |||
709 710 711 712 713 714 715 | *--------------------------------------------------------------------------- * * TclpRemoveDirectory, DoRemoveDirectory -- * * Removes directory (and its contents, if the recursive flag is set). * * Results: | | | | | | | | | | | | | | | | | | | | > | > > | | | | | | > | > > | | | | | | | | | | | | | | | | > | | 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 | *--------------------------------------------------------------------------- * * TclpRemoveDirectory, DoRemoveDirectory -- * * Removes directory (and its contents, if the recursive flag is set). * * Results: * If the directory was successfully removed, returns TCL_OK. Otherwise * the return value is TCL_ERROR, errno is set to indicate the error, and * the pathname of the file that caused the error is stored in errorPtr. * Some possible values for errno are: * * EACCES: path directory can't be read and/or written. * EEXIST: path is a non-empty directory. * EINVAL: path is a root directory. * ENOENT: path doesn't exist or is "". * ENOTDIR: path is not a directory. * * Side effects: * Directory removed. If an error occurs, the error will be returned * immediately, and remaining files will not be deleted. * *--------------------------------------------------------------------------- */ int TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_Obj *pathPtr; int recursive; Tcl_Obj **errorPtr; { Tcl_DString ds; Tcl_DString pathString; int ret; Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); Tcl_UtfToExternalDString(NULL, (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), -1, &pathString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } ret = DoRemoveDirectory(&pathString, recursive, &ds); Tcl_DStringFree(&pathString); if (ret != TCL_OK) { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); } return ret; } static int DoRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_DString *pathPtr; /* Pathname of directory to be removed * (native). */ int recursive; /* If non-zero, removes directories that are * nonempty. Otherwise, will only remove empty * directories. */ Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free DString * filled with UTF-8 name of file causing * error. */ { CONST char *path; mode_t oldPerm = 0; int result; 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); } if (rmdir(path) == 0) { /* INTL: Native. */ return TCL_OK; } if (errno == ENOTEMPTY) { errno = EEXIST; } result = TCL_OK; if ((errno != EEXIST) || (recursive == 0)) { if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr); } result = TCL_ERROR; } /* * The directory is nonempty, but the recursive flag has been specified, * so we recursively remove all the files in the directory. */ if (result == TCL_OK) { result = TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr, 1); } if ((result != TCL_OK) && (recursive != 0)) { /* * Try to restore permissions. */ chmod(path, oldPerm); } return result; } /* *--------------------------------------------------------------------------- * * TraverseUnixTree -- * * Traverse directory tree specified by sourcePtr, calling the function * traverseProc for each file and directory encountered. If destPtr is * non-null, each of name in the sourcePtr directory is appended to the * directory specified by destPtr and passed as the second argument to * traverseProc(). * * Results: * Standard Tcl result. * * Side effects: * None caused by TraverseUnixTree, however the user specified * traverseProc() may change state. If an error occurs, the error will be * returned immediately, and remaining files will not be processed. * *--------------------------------------------------------------------------- */ static int TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind) TraversalProc *traverseProc;/* Function to call for every file and * directory in source hierarchy. */ Tcl_DString *sourcePtr; /* Pathname of source directory to be * traversed (native). */ Tcl_DString *targetPtr; /* Pathname of directory to traverse in * parallel with source directory (native). */ Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free DString * filled with UTF-8 name of file causing * error. */ int doRewind; /* Flag indicating that to ensure complete * traversal of source hierarchy, the readdir * loop should be rewound whenever * traverseProc has returned TCL_OK; this is * required when traverseProc modifies the * source hierarchy, e.g. by deleting * files. */ { Tcl_StatBuf statBuf; CONST char *source, *errfile; int result, sourceLen; int targetLen; int numProcessed = 0; Tcl_DirEntry *dirEntPtr; DIR *dirPtr; errfile = NULL; result = TCL_OK; targetLen = 0; /* lint. */ |
︙ | ︙ | |||
883 884 885 886 887 888 889 | */ return (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_F, errorPtr); } dirPtr = opendir(source); /* INTL: Native. */ if (dirPtr == NULL) { | | | | < < | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | < | > > > > > > < > | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | < | | < | | | | | < | | | | < | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | < | | < < | > > | | | | | | | | | | 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 | */ return (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_F, errorPtr); } dirPtr = opendir(source); /* INTL: Native. */ if (dirPtr == NULL) { /* * Can't read directory */ errfile = source; goto end; } result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_PRED, errorPtr); if (result != TCL_OK) { closedir(dirPtr); return result; } Tcl_DStringAppend(sourcePtr, "/", 1); sourceLen = Tcl_DStringLength(sourcePtr); if (targetPtr != NULL) { Tcl_DStringAppend(targetPtr, "/", 1); targetLen = Tcl_DStringLength(targetPtr); } while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */ if ((dirEntPtr->d_name[0] == '.') && ((dirEntPtr->d_name[1] == '\0') || (strcmp(dirEntPtr->d_name, "..") == 0))) { continue; } /* * Append name after slash, and recurse on the file. */ Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1); if (targetPtr != NULL) { Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1); } result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind); if (result != TCL_OK) { break; } else { numProcessed++; } /* * Remove name after slash. */ Tcl_DStringSetLength(sourcePtr, sourceLen); if (targetPtr != NULL) { Tcl_DStringSetLength(targetPtr, targetLen); } if (doRewind && (numProcessed > MAX_READDIR_UNLINK_THRESHOLD)) { /* * Call rewinddir if we've called unlink or rmdir so many times * (since the opendir or the previous rewinddir), to avoid * a NULL-return that may a symptom of a buggy readdir. */ rewinddir(dirPtr); numProcessed = 0; } } closedir(dirPtr); /* * Strip off the trailing slash we added */ Tcl_DStringSetLength(sourcePtr, sourceLen - 1); if (targetPtr != NULL) { Tcl_DStringSetLength(targetPtr, targetLen - 1); } if (result == TCL_OK) { /* * Call traverseProc() on a directory after visiting all the files in * that directory. */ result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_POSTD, errorPtr); } end: if (errfile != NULL) { if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr); } result = TCL_ERROR; } return result; } /* *---------------------------------------------------------------------- * * 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. * *---------------------------------------------------------------------- */ static int TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr) Tcl_DString *srcPtr; /* Source pathname to copy (native). */ Tcl_DString *dstPtr; /* Destination pathname of copy (native). */ CONST Tcl_StatBuf *statBufPtr; /* Stat info for file specified by srcPtr. */ int type; /* Reason for call - see TraverseUnixTree(). */ Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free DString * filled with UTF-8 name of file causing * error. */ { switch (type) { case DOTREE_F: if (DoCopyFile(Tcl_DStringValue(srcPtr), Tcl_DStringValue(dstPtr)) == TCL_OK) { return TCL_OK; } break; case DOTREE_PRED: if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) { return TCL_OK; } break; case DOTREE_POSTD: if (CopyFileAtts(Tcl_DStringValue(srcPtr), Tcl_DStringValue(dstPtr), statBufPtr) == TCL_OK) { return TCL_OK; } break; } /* * There shouldn't be a problem with src, because we already checked it to * get here. */ if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(dstPtr), Tcl_DStringLength(dstPtr), errorPtr); } return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * TraversalDelete -- * * Called by procedure TraverseUnixTree for every file and directory that * it encounters in a directory hierarchy. This procedure unlinks files, * and removes directories after all the containing files have been * processed. * * Results: * Standard Tcl result. * * Side effects: * Files or directory specified by src will be deleted. * *---------------------------------------------------------------------- */ static int TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr) Tcl_DString *srcPtr; /* Source pathname (native). */ Tcl_DString *ignore; /* Destination pathname (not used). */ CONST Tcl_StatBuf *statBufPtr; /* Stat info for file specified by srcPtr. */ int type; /* Reason for call - see TraverseUnixTree(). */ Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free DString * filled with UTF-8 name of file causing * error. */ { switch (type) { case DOTREE_F: if (TclpDeleteFile(Tcl_DStringValue(srcPtr)) == 0) { return TCL_OK; } break; case DOTREE_PRED: return TCL_OK; case DOTREE_POSTD: if (DoRemoveDirectory(srcPtr, 0, NULL) == 0) { return TCL_OK; } break; } if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(srcPtr), Tcl_DStringLength(srcPtr), errorPtr); } return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * CopyFileAtts -- * * Copy the file attributes such as owner, group, permissions, and * modification date from one file to another. * * Results: * Standard Tcl result. * * Side effects: * User id, group id, permission bits, last modification time, and last * access time are updated in the new file to reflect the old file. * *--------------------------------------------------------------------------- */ static int CopyFileAtts(src, dst, statBufPtr) CONST char *src; /* Path name of source file (native). */ CONST char *dst; /* Path name of target file (native). */ CONST Tcl_StatBuf *statBufPtr; /* Stat info for source file */ { struct utimbuf tval; mode_t newMode; newMode = statBufPtr->st_mode & (S_ISUID | S_ISGID | S_IRWXU | S_IRWXG | S_IRWXO); /* * Note that if you copy a setuid file that is owned by someone else, and * you are not root, then the copy will be setuid to you. The most correct * implementation would probably be to have the copy not setuid to anyone * if the original file was owned by someone else, but this corner case * isn't currently handled. It would require another lstat(), or getuid(). */ if (chmod(dst, newMode)) { /* INTL: Native. */ newMode &= ~(S_ISUID | S_ISGID); if (chmod(dst, newMode)) { /* INTL: Native. */ return TCL_ERROR; } } tval.actime = statBufPtr->st_atime; tval.modtime = statBufPtr->st_mtime; if (utime(dst, &tval)) { /* INTL: Native. */ return TCL_ERROR; } #ifdef MAC_OSX_TCL TclMacOSXCopyFileAttributes(src, dst, statBufPtr); #endif return TCL_OK; } /* *---------------------------------------------------------------------- * * GetGroupAttribute * * Gets the group attribute of a file. * * Results: * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there * is no error. * * Side effects: * A new object is allocated. * *---------------------------------------------------------------------- */ static int GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { Tcl_StatBuf statBuf; struct group *groupPtr; int result; result = TclpObjStat(fileName, &statBuf); if (result != 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } groupPtr = getgrgid(statBuf.st_gid); /* INTL: Native. */ if (groupPtr == NULL) { *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_gid); } else { Tcl_DString ds; CONST char *utf; utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); *attributePtrPtr = Tcl_NewStringObj(utf, -1); Tcl_DStringFree(&ds); } endgrent(); return TCL_OK; } /* *---------------------------------------------------------------------- * * GetOwnerAttribute * * Gets the owner attribute of a file. * * Results: * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there * is no error. * * Side effects: * A new object is allocated. * *---------------------------------------------------------------------- */ static int GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { Tcl_StatBuf statBuf; struct passwd *pwPtr; int result; result = TclpObjStat(fileName, &statBuf); if (result != 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } pwPtr = getpwuid(statBuf.st_uid); /* INTL: Native. */ if (pwPtr == NULL) { *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid); } else { Tcl_DString ds; CONST char *utf; utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); *attributePtrPtr = Tcl_NewStringObj(utf, Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); } endpwent(); return TCL_OK; } /* *---------------------------------------------------------------------- * * GetPermissionsAttribute * * Gets the group attribute of a file. * * Results: * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there * is no error. The object will have ref count 0. * * Side effects: * A new object is allocated. * *---------------------------------------------------------------------- */ static int GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { Tcl_StatBuf statBuf; int result; result = TclpObjStat(fileName, &statBuf); if (result != 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } *attributePtrPtr = Tcl_NewObj(); TclObjPrintf(NULL, *attributePtrPtr, "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF)); return TCL_OK; } /* *--------------------------------------------------------------------------- * * SetGroupAttribute -- * * Sets the group of the file to the specified group. * * Results: * Standard TCL result. * * Side effects: * As above. * *--------------------------------------------------------------------------- */ static int SetGroupAttribute(interp, objIndex, fileName, attributePtr) Tcl_Interp *interp; /* The interp for error reporting. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr; /* New group for file. */ { long gid; int result; CONST char *native; if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) { Tcl_DString ds; |
︙ | ︙ | |||
1351 1352 1353 1354 1355 1356 1357 | groupPtr = getgrnam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); if (groupPtr == NULL) { endgrent(); if (interp != NULL) { Tcl_AppendResult(interp, "could not set group for file \"", | | | | | | | | | | | | | 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 | groupPtr = getgrnam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); if (groupPtr == NULL) { endgrent(); if (interp != NULL) { Tcl_AppendResult(interp, "could not set group for file \"", Tcl_GetString(fileName), "\": group \"", string, "\" does not exist", (char *) NULL); } return TCL_ERROR; } gid = groupPtr->gr_gid; } native = Tcl_FSGetNativePath(fileName); result = chown(native, (uid_t) -1, (gid_t) gid); /* INTL: Native. */ endgrent(); if (result != 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not set group for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } return TCL_OK; } /* *--------------------------------------------------------------------------- * * SetOwnerAttribute -- * * Sets the owner of the file to the specified owner. * * Results: * Standard TCL result. * * Side effects: * As above. * *--------------------------------------------------------------------------- */ static int SetOwnerAttribute(interp, objIndex, fileName, attributePtr) Tcl_Interp *interp; /* The interp for error reporting. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr; /* New owner for file. */ { long uid; int result; CONST char *native; if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) { Tcl_DString ds; |
︙ | ︙ | |||
1430 1431 1432 1433 1434 1435 1436 | } native = Tcl_FSGetNativePath(fileName); result = chown(native, (uid_t) uid, (gid_t) -1); /* INTL: Native. */ if (result != 0) { if (interp != NULL) { | | | | | | | | | | > | | | > | | | 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 | } native = Tcl_FSGetNativePath(fileName); result = chown(native, (uid_t) uid, (gid_t) -1); /* INTL: Native. */ if (result != 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not set owner for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } return TCL_OK; } /* *--------------------------------------------------------------------------- * * SetPermissionsAttribute * * Sets the file to the given permission. * * Results: * Standard TCL result. * * Side effects: * The permission of the file is changed. * *--------------------------------------------------------------------------- */ static int SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr; /* The attribute to set. */ { long mode; mode_t newMode; int result; CONST char *native; /* * First try if the string is a number */ if (Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) { newMode = (mode_t) (mode & 0x00007FFF); } else { Tcl_StatBuf buf; char *modeStringPtr = Tcl_GetString(attributePtr); /* * Try the forms "rwxrwxrwx" and "ugo=rwx" * * We get the current mode of the file, in order to allow for ug+-=rwx * style chmod strings. */ result = TclpObjStat(fileName, &buf); if (result != 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } newMode = (mode_t) (buf.st_mode & 0x00007FFF); if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) { if (interp != NULL) { Tcl_AppendResult(interp, "unknown permission string format \"", modeStringPtr, "\"", (char *) NULL); } return TCL_ERROR; } } native = Tcl_FSGetNativePath(fileName); result = chmod(native, newMode); /* INTL: Native. */ if (result != 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not set permissions for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } return TCL_OK; } |
︙ | ︙ | |||
1547 1548 1549 1550 1551 1552 1553 | #endif /* *---------------------------------------------------------------------- * * GetModeFromPermString -- * | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | > | > | | | | > > | > > | > | | > > | > | > | > > | > > | > > > > | > > > | > > > | | | | | < > | | | > | > | > > | > | > > > | | | | | | > | | | | > > | > > > > | | < | > > | > > > | > | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > | 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 | #endif /* *---------------------------------------------------------------------- * * GetModeFromPermString -- * * This procedure is invoked to process the "file permissions" Tcl * command, to check for a "rwxrwxrwx" or "ugoa+-=rwxst" string. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int GetModeFromPermString(interp, modeStringPtr, modePtr) Tcl_Interp *interp; /* The interp we are using for errors. */ char *modeStringPtr; /* Permissions string */ mode_t *modePtr; /* pointer to the mode value */ { mode_t newMode; mode_t oldMode; /* Storage for the value of the old mode (that * is passed in), to allow for the chmod style * manipulation. */ int i,n, who, op, what, op_found, who_found; /* * We start off checking for an "rwxrwxrwx" style permissions string */ if (strlen(modeStringPtr) != 9) { goto chmodStyleCheck; } newMode = 0; for (i = 0; i < 9; i++) { switch (*(modeStringPtr+i)) { case 'r': if ((i%3) != 0) { goto chmodStyleCheck; } newMode |= (1<<(8-i)); break; case 'w': if ((i%3) != 1) { goto chmodStyleCheck; } newMode |= (1<<(8-i)); break; case 'x': if ((i%3) != 2) { goto chmodStyleCheck; } newMode |= (1<<(8-i)); break; case 's': if (((i%3) != 2) || (i > 5)) { goto chmodStyleCheck; } newMode |= (1<<(8-i)); newMode |= (1<<(11-(i/3))); break; case 'S': if (((i%3) != 2) || (i > 5)) { goto chmodStyleCheck; } newMode |= (1<<(11-(i/3))); break; case 't': if (i != 8) { goto chmodStyleCheck; } newMode |= (1<<(8-i)); newMode |= (1<<9); break; case 'T': if (i != 8) { goto chmodStyleCheck; } newMode |= (1<<9); break; case '-': break; default: /* * Oops, not what we thought it was, so go on */ goto chmodStyleCheck; } } *modePtr = newMode; return TCL_OK; chmodStyleCheck: /* * We now check for an "ugoa+-=rwxst" style permissions string */ for (n = 0 ; *(modeStringPtr+n) != '\0' ; n = n + i) { oldMode = *modePtr; who = op = what = op_found = who_found = 0; for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; i++ ) { if (!who_found) { /* who */ switch (*(modeStringPtr+n+i)) { case 'u': who |= 0x9c0; continue; case 'g': who |= 0x438; continue; case 'o': who |= 0x207; continue; case 'a': who |= 0xfff; continue; } } who_found = 1; if (who == 0) { who = 0xfff; } if (!op_found) { /* op */ switch (*(modeStringPtr+n+i)) { case '+': op = 1; op_found = 1; continue; case '-': op = 2; op_found = 1; continue; case '=': op = 3; op_found = 1; continue; default: return TCL_ERROR; } } /* what */ switch (*(modeStringPtr+n+i)) { case 'r': what |= 0x124; continue; case 'w': what |= 0x92; continue; case 'x': what |= 0x49; continue; case 's': what |= 0xc00; continue; case 't': what |= 0x200; continue; case ',': break; default: return TCL_ERROR; } if (*(modeStringPtr+n+i) == ',') { i++; break; } } switch (op) { case 1 : *modePtr = oldMode | (who & what); continue; case 2 : *modePtr = oldMode & ~(who & what); continue; case 3 : *modePtr = (oldMode & ~who) | (who & what); continue; } } return TCL_OK; } /* *--------------------------------------------------------------------------- * * TclpObjNormalizePath -- * * This function scans through a path specification and replaces it, in * place, with a normalized version. A normalized version is one in which * all symlinks in the path are replaced with their expanded form (except * a symlink at the very end of the path). * * Results: * The new 'nextCheckpoint' value, giving as far as we could understand * in the path. * * Side effects: * The pathPtr string, is modified. * *--------------------------------------------------------------------------- */ int TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) Tcl_Interp *interp; Tcl_Obj *pathPtr; int nextCheckpoint; { char *currentPathEndPosition; int pathLen; char cur; char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); #ifndef NO_REALPATH char normPath[MAXPATHLEN]; Tcl_DString ds; CONST char *nativePath; #endif /* * We add '1' here because if nextCheckpoint is zero we know that '/' * exists, and if it isn't zero, it must point at a directory separator * which we also know exists. */ currentPathEndPosition = path + nextCheckpoint; if (*currentPathEndPosition == '/') { currentPathEndPosition++; } #ifndef NO_REALPATH /* * For speed, try to get the entire path in one go. */ if (nextCheckpoint == 0) { char *lastDir = strrchr(currentPathEndPosition, '/'); if (lastDir != NULL) { nativePath = Tcl_UtfToExternalDString(NULL, path, lastDir-path, &ds); if (Realpath(nativePath, normPath) != NULL) { nextCheckpoint = lastDir - path; goto wholeStringOk; } } } /* * Else do it the slow way. */ #endif 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) { int newNormLen; wholeStringOk: newNormLen = strlen(normPath); if ((newNormLen == Tcl_DStringLength(&ds)) && (strcmp(normPath, nativePath) == 0)) { /* * String is unchanged. */ Tcl_DStringFree(&ds); /* * Enable this to have the native FS claim normalization of the * whole path for existing files. That would permit the caller to * declare normalization complete without calls to additional * filesystems. Saving lots of calls is probably worth the extra * access() time here. When no other FS's are registered though, * things are less clear. * if (0 == access(normPath, F_OK)) { return pathLen; } */ return nextCheckpoint; } /* * Free up the native path and put in its place the converted, * normalized path. */ Tcl_DStringFree(&ds); Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds); if (path[nextCheckpoint] != '\0') { /* * Not at end, append remaining path. */ int normLen = Tcl_DStringLength(&ds); Tcl_DStringAppend(&ds, path + nextCheckpoint, pathLen - nextCheckpoint); /* * We recognise up to and including the directory separator. */ nextCheckpoint = normLen + 1; } else { /* * We recognise the whole string. */ nextCheckpoint = Tcl_DStringLength(&ds); } /* * Overwrite with the normalized path. */ Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); } Tcl_DStringFree(&ds); #endif /* !NO_REALPATH */ return nextCheckpoint; } #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) /* *---------------------------------------------------------------------- * * GetReadOnlyAttribute * * Gets the readonly attribute (user immutable flag) of a file. * * Results: * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there * is no error. The object will have ref count 0. * * Side effects: * A new object is allocated. * *---------------------------------------------------------------------- */ static int GetReadOnlyAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { Tcl_StatBuf statBuf; int result; result = TclpObjStat(fileName, &statBuf); if (result != 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } *attributePtrPtr = Tcl_NewBooleanObj((statBuf.st_flags&UF_IMMUTABLE) != 0); return TCL_OK; } /* *--------------------------------------------------------------------------- * * SetReadOnlyAttribute * * Sets the readonly attribute (user immutable flag) of a file. * * Results: * Standard TCL result. * * Side effects: * The readonly attribute of the file is changed. * *--------------------------------------------------------------------------- */ static int SetReadOnlyAttribute(interp, objIndex, fileName, attributePtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr; /* The attribute to set. */ { Tcl_StatBuf statBuf; int result; int readonly; CONST char *native; if (Tcl_GetBooleanFromObj(interp, attributePtr, &readonly) != TCL_OK) { return TCL_ERROR; } result = TclpObjStat(fileName, &statBuf); if (result != 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } if (readonly) { statBuf.st_flags |= UF_IMMUTABLE; } else { statBuf.st_flags &= ~UF_IMMUTABLE; } native = Tcl_FSGetNativePath(fileName); result = chflags(native, statBuf.st_flags); /* INTL: Native. */ if (result != 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not set flags for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } return TCL_OK; } #endif /* defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclUnixFile.c.
|
| | | | | | | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | /* * 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.44.2.2 2005/09/09 18:48:40 dgp Exp $ */ #include "tclInt.h" #include "tclFileSystem.h" static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types); /* *--------------------------------------------------------------------------- * * TclpFindExecutable -- * * This function computes the absolute path name of the current * application, given its argv[0] value. * * Results: * None. * * Side effects: * The computed path name is stored as a ProcessGlobalValue. |
︙ | ︙ | |||
50 51 52 53 54 55 56 | } Tcl_DStringInit(&buffer); name = argv0; for (p = name; *p != '\0'; p++) { if (*p == '/') { /* | | | | | | | < | | 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 | } Tcl_DStringInit(&buffer); name = argv0; for (p = name; *p != '\0'; p++) { if (*p == '/') { /* * The name contains a slash, so use the name directly without * doing a path search. */ goto gotName; } } p = getenv("PATH"); /* INTL: Native. */ if (p == NULL) { /* * There's no PATH environment variable; use the default that is used * by sh. */ p = ":/bin:/usr/bin"; } else if (*p == '\0') { /* * An empty path is equivalent to ".". */ p = "./"; } /* * Search through all the directories named in the PATH variable to see if * argv[0] is in one of them. If so, use that file name. */ while (1) { while (isspace(UCHAR(*p))) { /* INTL: BUG */ p++; } name = p; while ((*p != ':') && (*p != 0)) { p++; } Tcl_DStringSetLength(&buffer, 0); |
︙ | ︙ | |||
123 124 125 126 127 128 129 | TclSetObjNameOfExecutable(Tcl_NewObj(), NULL); goto done; /* * If the name starts with "/" then just store it */ | | | | > | | | | 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 | TclSetObjNameOfExecutable(Tcl_NewObj(), NULL); goto done; /* * If the name starts with "/" then just store it */ gotName: #ifdef DJGPP if (name[1] == ':') #else if (name[0] == '/') #endif { encoding = Tcl_GetEncoding(NULL, NULL); Tcl_ExternalToUtfDString(encoding, name, -1, &utfName); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); Tcl_DStringFree(&utfName); goto done; } /* * The name is relative to the current working directory. First strip off * a leading "./", if any, then add the full path name of the current * working directory. */ if ((name[0] == '.') && (name[1] == '/')) { name += 2; } Tcl_DStringInit(&nameString); |
︙ | ︙ | |||
164 165 166 167 168 169 170 | } Tcl_DStringFree(&cwd); Tcl_DStringAppend(&buffer, Tcl_DStringValue(&nameString), Tcl_DStringLength(&nameString)); Tcl_DStringFree(&nameString); encoding = Tcl_GetEncoding(NULL, NULL); | | > | | | | | | | | | > | > | > > | > | > > | | | | | | | > > | > > | 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 | } Tcl_DStringFree(&cwd); Tcl_DStringAppend(&buffer, Tcl_DStringValue(&nameString), Tcl_DStringLength(&nameString)); Tcl_DStringFree(&nameString); encoding = Tcl_GetEncoding(NULL, NULL); Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1, &utfName); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); Tcl_DStringFree(&utfName); done: Tcl_DStringFree(&buffer); } /* *---------------------------------------------------------------------- * * TclpMatchInDirectory -- * * This routine is used by the globbing code to search a directory for * all files which match a given pattern. * * Results: * The return value is a standard Tcl result indicating whether an error * occurred in globbing. Errors are left in interp, good results are * [lappend]ed to resultPtr (which must be a valid object). * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) Tcl_Interp *interp; /* Interpreter to receive errors. */ Tcl_Obj *resultPtr; /* List object to lappend results. */ Tcl_Obj *pathPtr; /* Contains path to directory to search. */ CONST char *pattern; /* Pattern to match against. */ Tcl_GlobTypeData *types; /* Object containing list of acceptable types. * May be NULL. In particular the directory * flag is very important. */ { CONST char *native; Tcl_Obj *fileNamePtr; if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) { /* * The native filesystem never adds mounts. */ return TCL_OK; } fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (fileNamePtr == NULL) { return TCL_ERROR; } if (pattern == NULL || (*pattern == '\0')) { /* * Match a file directly. */ native = (CONST char*) Tcl_FSGetNativePath(pathPtr); if (NativeMatchType(native, types)) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); } Tcl_DecrRefCount(fileNamePtr); return TCL_OK; } else { DIR *d; Tcl_DirEntry *entryPtr; CONST char *dirName; int dirLength; int matchHidden; int nativeDirLen; Tcl_StatBuf statBuf; Tcl_DString ds; /* native encoding of dir */ Tcl_DString dsOrig; /* utf-8 encoding of dir */ Tcl_DStringInit(&dsOrig); dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); /* * Make sure that the directory part of the name really is a * directory. If the directory name is "", use the name "." instead, * because some UNIX systems don't treat "" like "." automatically. * Keep the "" for use in generating file names, otherwise "glob * foo.c" would return "./foo.c". */ if (dirLength == 0) { dirName = "."; } else { dirName = Tcl_DStringValue(&dsOrig); /* * Make sure we have a trailing directory delimiter. */ if (dirName[dirLength-1] != '/') { dirName = Tcl_DStringAppend(&dsOrig, "/", 1); dirLength++; } } /* |
︙ | ︙ | |||
273 274 275 276 277 278 279 | Tcl_DecrRefCount(fileNamePtr); return TCL_OK; } d = opendir(native); /* INTL: Native. */ if (d == NULL) { Tcl_DStringFree(&ds); | > | | | | > > | | | | | | | > | | | | | > | | | | | | < | > | | < | | | < | | | > | | | | | > > | > > | | < | | > > | | < | < | < | < | < | < > | > | 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 | Tcl_DecrRefCount(fileNamePtr); return TCL_OK; } d = opendir(native); /* INTL: Native. */ if (d == NULL) { Tcl_DStringFree(&ds); if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't read directory \"", Tcl_DStringValue(&dsOrig), "\": ", Tcl_PosixError(interp), (char *) NULL); } Tcl_DStringFree(&dsOrig); Tcl_DecrRefCount(fileNamePtr); return TCL_ERROR; } nativeDirLen = Tcl_DStringLength(&ds); /* * Check to see if -type or the pattern requests hidden files. */ matchHidden = ((types && (types->perm & TCL_GLOB_PERM_HIDDEN)) || ((pattern[0] == '.') || ((pattern[0] == '\\') && (pattern[1] == '.')))); while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */ Tcl_DString utfDs; CONST char *utfname; /* * Skip this file if it doesn't agree with the hidden parameters * requested by the user (via -type or pattern). */ if (*entryPtr->d_name == '.') { if (!matchHidden) continue; } else { if (matchHidden) continue; } /* * Now check to see if the file matches, according to both type * and pattern. If so, add the file to the result. */ utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &utfDs); if (Tcl_StringCaseMatch(utfname, pattern, 0)) { int typeOk = 1; if (types != NULL) { Tcl_DStringSetLength(&ds, nativeDirLen); native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1); typeOk = NativeMatchType(native, types); } if (typeOk) { Tcl_ListObjAppendElement(interp, resultPtr, TclNewFSPathObj(pathPtr, utfname, Tcl_DStringLength(&utfDs))); } } Tcl_DStringFree(&utfDs); } closedir(d); Tcl_DStringFree(&ds); Tcl_DStringFree(&dsOrig); Tcl_DecrRefCount(fileNamePtr); return TCL_OK; } } static int NativeMatchType( CONST char* nativeEntry, /* Native path to check. */ Tcl_GlobTypeData *types) /* Type description to match against. */ { Tcl_StatBuf buf; 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 to mean the file does not match any defined * permission, and therefore it is not added to the list of * files to return. */ return 0; } /* * readonly means that there are NO write permissions (even for * user), but execute is OK for anybody OR that the user immutable * flag is set (where supported). */ if (((types->perm & TCL_GLOB_PERM_RONLY) && #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) !(buf.st_flags & UF_IMMUTABLE) && #endif (buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) || ((types->perm & TCL_GLOB_PERM_R) && (access(nativeEntry, R_OK) != 0)) || ((types->perm & TCL_GLOB_PERM_W) && (access(nativeEntry, W_OK) != 0)) || ((types->perm & TCL_GLOB_PERM_X) && (access(nativeEntry, X_OK) != 0)) ) { 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. The only ok case is if this is a * link to a nonexistent file, and the user did 'glob -l'. * So we check that here: */ if (types->type & TCL_GLOB_TYPE_LINK) { if (TclOSlstat(nativeEntry, &buf) == 0) { if (S_ISLNK(buf.st_mode)) { return 1; } } } 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; } |
︙ | ︙ | |||
451 452 453 454 455 456 457 | } /* *--------------------------------------------------------------------------- * * TclpGetUserHome -- * | | | | | | | | | | 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 | } /* *--------------------------------------------------------------------------- * * TclpGetUserHome -- * * This function takes the specified user name and finds their home * directory. * * Results: * The result is a pointer to a string specifying the user's home * directory, or NULL if the user's home directory could not be * determined. Storage for the result string is allocated in bufferPtr; * the caller must call Tcl_DStringFree() when the result is no longer * needed. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * TclpGetUserHome(name, bufferPtr) CONST char *name; /* User name for desired home directory. */ Tcl_DString *bufferPtr; /* Uninitialized or free DString filled with * name of user's home directory. */ { struct passwd *pwPtr; Tcl_DString ds; CONST char *native; native = Tcl_UtfToExternalDString(NULL, name, -1, &ds); pwPtr = getpwnam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); if (pwPtr == NULL) { endpwent(); return NULL; } Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr); endpwent(); return Tcl_DStringValue(bufferPtr); |
︙ | ︙ | |||
506 507 508 509 510 511 512 | * * Side effects: * See access() documentation. * *--------------------------------------------------------------------------- */ | | | | | | | | 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 | * * Side effects: * See access() documentation. * *--------------------------------------------------------------------------- */ int TclpObjAccess(pathPtr, mode) Tcl_Obj *pathPtr; /* Path of file to access */ int mode; /* Permission setting. */ { CONST char *path = Tcl_FSGetNativePath(pathPtr); if (path == NULL) { return -1; } else { return access(path, mode); } } /* *--------------------------------------------------------------------------- * * TclpObjChdir -- * * This function replaces the library version of chdir(). * * Results: * See chdir() documentation. * * Side effects: * See chdir() documentation. * *--------------------------------------------------------------------------- */ int TclpObjChdir(pathPtr) Tcl_Obj *pathPtr; /* Path to new working directory */ { CONST char *path = Tcl_FSGetNativePath(pathPtr); if (path == NULL) { return -1; } else { return chdir(path); } |
︙ | ︙ | |||
563 564 565 566 567 568 569 | * * Side effects: * See lstat() documentation. * *---------------------------------------------------------------------- */ | | | | | | | | < | | > > | > > | < | | | | | | | | | < | | | | > | | | | | | | | | 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 | * * Side effects: * See lstat() documentation. * *---------------------------------------------------------------------- */ 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); } /* *--------------------------------------------------------------------------- * * TclpGetNativeCwd -- * * This function replaces the library version of getcwd(). * * Results: * The input and output are filesystem paths in native form. The result * is either the given clientData, if the working directory hasn't * changed, or a new clientData (owned by our caller), giving the new * native path, or NULL if the current directory could not be determined. * If NULL is returned, the caller can examine the standard posix error * codes to determine the cause of the problem. * * Side effects: * None. * *---------------------------------------------------------------------- */ ClientData TclpGetNativeCwd(clientData) ClientData clientData; { char buffer[MAXPATHLEN+1]; #ifdef USEGETWD if (getwd(buffer) == NULL) /* INTL: Native. */ #else if (getcwd(buffer, MAXPATHLEN+1) == NULL) /* INTL: Native. */ #endif { return NULL; } if ((clientData != NULL) && strcmp(buffer, (CONST char*)clientData) == 0) { /* * No change to pwd. */ return clientData; } else { char *newCd = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); strcpy(newCd, buffer); return (ClientData) newCd; } } /* *--------------------------------------------------------------------------- * * TclpGetCwd -- * * This function replaces the library version of getcwd(). (Obsolete * function, only retained for old extensions which may call it * directly). * * Results: * The result is a pointer to a string specifying the current directory, * or NULL if the current directory could not be determined. If NULL is * returned, an error message is left in the interp's result. Storage for * the result string is allocated in bufferPtr; the caller must call * Tcl_DStringFree() when the result is no longer needed. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * TclpGetCwd(interp, bufferPtr) Tcl_Interp *interp; /* If non-NULL, used for error reporting. */ Tcl_DString *bufferPtr; /* Uninitialized or free DString filled with * name of current directory. */ { char buffer[MAXPATHLEN+1]; #ifdef USEGETWD if (getwd(buffer) == NULL) /* INTL: Native. */ #else if (getcwd(buffer, MAXPATHLEN+1) == NULL) /* INTL: Native. */ #endif { if (interp != NULL) { Tcl_AppendResult(interp, "error getting working directory name: ", Tcl_PosixError(interp), (char *) NULL); } return NULL; } return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr); } /* *--------------------------------------------------------------------------- * * TclpReadlink -- * * This function replaces the library version of readlink(). * * Results: * The result is a pointer to a string specifying the contents of the * symbolic link given by 'path', or NULL if the symbolic link could not * be read. Storage for the result string is allocated in bufferPtr; the * caller must call Tcl_DStringFree() when the result is no longer * needed. * * Side effects: * See readlink() documentation. * *--------------------------------------------------------------------------- */ char * TclpReadlink(path, linkPtr) CONST char *path; /* Path of file to readlink (UTF-8). */ Tcl_DString *linkPtr; /* Uninitialized or free DString filled with * contents of link (UTF-8). */ { #ifndef DJGPP char link[MAXPATHLEN]; int length; CONST char *native; 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); #else |
︙ | ︙ | |||
726 727 728 729 730 731 732 | * * Side effects: * See stat() documentation. * *---------------------------------------------------------------------- */ | | < | | | | | | | | | | > | > | > > | > > | > | | < > > | > > | > | > > > | | < > > | | | > | | | | | < | < | | | | | > > | > > | | | | | < | | > | | | | | | > | | | | | < > > | > > | | | | > | > | > > | | | > | | | | > > > > > > > > | 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 | * * Side effects: * See stat() documentation. * *---------------------------------------------------------------------- */ int TclpObjStat(pathPtr, bufPtr) 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 = NULL; if (src == NULL) return NULL; /* * If we're making a symbolic link and the path is relative, then we * must check whether it exists _relative_ to the directory in which * the src is found (not relative to the current cwd which is just not * relevant in this case). * * If we're making a hard link, then a relative path is just converted * to absolute relative to the cwd. */ if ((linkAction & TCL_CREATE_SYMBOLIC_LINK) && (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) { Tcl_Obj *dirPtr, *absPtr; dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME); if (dirPtr == NULL) { return NULL; } absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr); Tcl_IncrRefCount(absPtr); if (Tcl_FSAccess(absPtr, F_OK) == -1) { Tcl_DecrRefCount(absPtr); Tcl_DecrRefCount(dirPtr); /* * Target doesn't exist. */ errno = ENOENT; return NULL; } /* * Target exists; we'll construct the relative path we want below. */ Tcl_DecrRefCount(absPtr); Tcl_DecrRefCount(dirPtr); } else { target = Tcl_FSGetNativePath(toPtr); if (access(target, F_OK) == -1) { /* * Target doesn't exist. */ errno = ENOENT; return NULL; } if (target == NULL) { return NULL; } } if (access(src, F_OK) != -1) { /* * Src exists. */ errno = EEXIST; return NULL; } /* * Check symbolic link flag first, since we prefer to create these. */ if (linkAction & TCL_CREATE_SYMBOLIC_LINK) { int targetLen; Tcl_DString ds; Tcl_Obj *transPtr; /* * Now we don't want to link to the absolute, normalized path. * Relative links are quite acceptable (but links to ~user are not * -- these must be expanded first). */ transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr); if (transPtr == NULL) { return NULL; } target = Tcl_GetStringFromObj(transPtr, &targetLen); target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds); Tcl_DecrRefCount(transPtr); if (symlink(target, src) != 0) { toPtr = NULL; } Tcl_DStringFree(&ds); } 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; Tcl_DString ds; Tcl_Obj *transPtr; transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); if (transPtr == NULL) { return NULL; } Tcl_DecrRefCount(transPtr); length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link)); if (length < 0) { return NULL; } Tcl_ExternalToUtfDString(NULL, link, length, &ds); linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); if (linkPtr != NULL) { Tcl_IncrRefCount(linkPtr); } return linkPtr; } } #endif /* S_IFLNK */ /* *--------------------------------------------------------------------------- * * TclpFilesystemPathType -- * * This function is part of the native filesystem support, and returns * the path type of the given path. Right now it simply returns NULL. In * the future it could return specific path types, like 'nfs', 'samba', * 'FAT32', etc. * * Results: * NULL at present. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_Obj* TclpFilesystemPathType(pathPtr) Tcl_Obj* pathPtr; { /* * All native paths are of the same type. */ return NULL; } /* *--------------------------------------------------------------------------- * * TclpNativeToNormalized -- * * Convert native format to a normalized path object, with refCount of * zero. * * Currently assumes all native paths are actually normalized already, so * if the path given is not normalized this will actually just convert to * a valid string path, but not necessarily a normalized one. * * Results: * A valid normalized path. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_Obj* TclpNativeToNormalized(clientData) ClientData clientData; { Tcl_DString ds; Tcl_Obj *objPtr; int len; CONST char *copy; Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds); copy = Tcl_DStringValue(&ds); len = Tcl_DStringLength(&ds); objPtr = Tcl_NewStringObj(copy,len); Tcl_DStringFree(&ds); return objPtr; } /* *--------------------------------------------------------------------------- * * TclNativeCreateNativeRep -- * * Create a native representation for the given path. * * Results: * The nativePath representation. * * Side effects: * Memory will be allocated. The path may need to be normalized. * *--------------------------------------------------------------------------- */ ClientData TclNativeCreateNativeRep(pathPtr) Tcl_Obj* pathPtr; { char *nativePathPtr; Tcl_DString ds; Tcl_Obj* validPathPtr; int len; char *str; if (TclFSCwdIsNative()) { /* * The cwd is native, which means we can use the translated path * without worrying about normalization (this will also usually be * shorter so the utf-to-external conversion will be somewhat faster). */ validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); } else { /* * Make sure the normalized path is set. */ validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); Tcl_IncrRefCount(validPathPtr); } str = Tcl_GetStringFromObj(validPathPtr, &len); Tcl_UtfToExternalDString(NULL, str, len, &ds); len = Tcl_DStringLength(&ds) + sizeof(char); Tcl_DecrRefCount(validPathPtr); nativePathPtr = ckalloc((unsigned) len); memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len); Tcl_DStringFree(&ds); return (ClientData)nativePathPtr; } /* *--------------------------------------------------------------------------- * * TclNativeDupInternalRep -- * * Duplicate the native representation. * * Results: * The copied native representation, or NULL if it is not possible to * copy the representation. * * Side effects: * Memory will be allocated for the copy. * *--------------------------------------------------------------------------- */ ClientData TclNativeDupInternalRep(clientData) ClientData clientData; { char *copy; size_t len; if (clientData == NULL) { return NULL; } /* * ASCII representation when running on Unix. */ len = sizeof(char) + (strlen((CONST char*) clientData) * sizeof(char)); copy = (char *) ckalloc(len); memcpy((VOID *) copy, (VOID *) clientData, len); return (ClientData)copy; } /* *--------------------------------------------------------------------------- * * TclpUtime -- * * Set the modification date for a file. * * Results: * 0 on success, -1 on error. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int TclpUtime(pathPtr, tval) Tcl_Obj *pathPtr; /* File to modify */ struct utimbuf *tval; /* New modification date structure */ { return utime(Tcl_FSGetNativePath(pathPtr), tval); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclUnixInit.c.
1 2 3 4 5 6 7 8 9 | /* * tclUnixInit.c -- * * Contains the Unix-specific interpreter initialization functions. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. * | | | | | > | < > | | | | < | | | | < | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 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 | /* * 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.53.2.6 2005/08/15 18:14:14 dgp Exp $ */ #include "tclInt.h" #include <stddef.h> #include <locale.h> #ifdef HAVE_LANGINFO #include <langinfo.h> #endif #include <sys/resource.h> #if defined(__FreeBSD__) # include <floatingpoint.h> #endif #if defined(__bsdi__) # include <sys/param.h> # if _BSDI_VERSION > 199501 # include <dlfcn.h> # endif #endif #ifdef HAVE_COREFOUNDATION #include <CoreFoundation/CoreFoundation.h> #endif /* * Define this if you want to revert to the old behavior of never checking the * stack. */ #undef TCL_NO_STACK_CHECK /* * Define this if you want to see a lot of output regarding stack checking. */ #undef TCL_DEBUG_STACK_CHECK /* * Values used to compute how much space is really available for Tcl's use for * the stack. * * NOTE: Now I have some idea why the maximum stack size must be divided by 64 * on FreeBSD with threads enabled to get a reasonably correct value. * * The getrlimit() function is documented to return the maximum stack size in * bytes. However, with threads enabled, the pthread library does bad things * to the stack size limits. First, the limits cannot be changed. Second, * they appear to be reported incorrectly by a factor of about 64. * * The defines below may need to be adjusted if more platforms have this * broken behavior with threads enabled. */ #if defined(__FreeBSD__) # define TCL_MAGIC_STACK_DIVISOR 64 # define TCL_RESERVED_STACK_PAGES 3 #endif |
︙ | ︙ | |||
90 91 92 93 94 95 96 | #ifdef TCL_DEBUG_STACK_CHECK #define STACK_DEBUG(args) printf args #else #define STACK_DEBUG(args) (void)0 #endif /* TCL_DEBUG_STACK_CHECK */ /* | | | | | | | | | | | | < > > > > > > > > > > < > > > | 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 | #ifdef TCL_DEBUG_STACK_CHECK #define STACK_DEBUG(args) printf args #else #define STACK_DEBUG(args) (void)0 #endif /* TCL_DEBUG_STACK_CHECK */ /* * Tcl tries to use standard and homebrew methods to guess the right encoding * on the platform. However, there is always a final fallback, and this value * is it. Make sure it is a real Tcl encoding. */ #ifndef TCL_DEFAULT_ENCODING #define TCL_DEFAULT_ENCODING "iso8859-1" #endif /* * Default directory in which to look for Tcl library scripts. The symbol is * defined by Makefile. */ static char defaultLibraryDir[sizeof(TCL_LIBRARY)+200] = TCL_LIBRARY; /* * Directory in which to look for packages (each package is typically * installed as a subdirectory of this directory). The symbol is defined by * Makefile. */ static char pkgPath[sizeof(TCL_PACKAGE_PATH)+200] = TCL_PACKAGE_PATH; /* * The following table is used to map from Unix locale strings to encoding * files. If HAVE_LANGINFO is defined, then this is a fallback table when the * result from nl_langinfo isn't a recognized encoding. Otherwise this is the * first list checked for a mapping from env encoding to Tcl encoding name. */ typedef struct LocaleTable { CONST char *lang; CONST char *encoding; } LocaleTable; /* * The table below is sorted for the sake of doing binary searches on it. The * indenting reflects different categories of data. The leftmost data * represent the encoding names directly implemented by data files in Tcl's * default encoding directory. Indented by one TAB are the encoding names that * are common alternative spellings. Indented by two TABs are the accumulated * "bug fixes" that have been added to deal with the wide variability seen * among existing platforms. */ static CONST LocaleTable localeTable[] = { {"", "iso8859-1"}, {"ansi-1251", "cp1251"}, {"ansi_x3.4-1968", "iso8859-1"}, {"ascii", "ascii"}, {"big5", "big5"}, {"cp1250", "cp1250"}, {"cp1251", "cp1251"}, {"cp1252", "cp1252"}, {"cp1253", "cp1253"}, {"cp1254", "cp1254"}, |
︙ | ︙ | |||
165 166 167 168 169 170 171 172 173 174 | {"cp949", "cp949"}, {"cp950", "cp950"}, {"dingbats", "dingbats"}, {"ebcdic", "ebcdic"}, {"euc-cn", "euc-cn"}, {"euc-jp", "euc-jp"}, {"euc-kr", "euc-kr"}, {"gb12345", "gb12345"}, {"gb1988", "gb1988"}, {"gb2312-raw", "gb2312-raw"}, | > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < < < < < < < < | < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < | < | | | | > < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | < | | < | | | 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 | {"cp949", "cp949"}, {"cp950", "cp950"}, {"dingbats", "dingbats"}, {"ebcdic", "ebcdic"}, {"euc-cn", "euc-cn"}, {"euc-jp", "euc-jp"}, {"euc-kr", "euc-kr"}, {"eucjp", "euc-jp"}, {"euckr", "euc-kr"}, {"euctw", "euc-cn"}, {"gb12345", "gb12345"}, {"gb1988", "gb1988"}, {"gb2312", "gb2312"}, {"gb2312-1980", "gb2312"}, {"gb2312-raw", "gb2312-raw"}, {"greek8", "cp869"}, {"ibm1250", "cp1250"}, {"ibm1251", "cp1251"}, {"ibm1252", "cp1252"}, {"ibm1253", "cp1253"}, {"ibm1254", "cp1254"}, {"ibm1255", "cp1255"}, {"ibm1256", "cp1256"}, {"ibm1257", "cp1257"}, {"ibm1258", "cp1258"}, {"ibm437", "cp437"}, {"ibm737", "cp737"}, {"ibm775", "cp775"}, {"ibm850", "cp850"}, {"ibm852", "cp852"}, {"ibm855", "cp855"}, {"ibm857", "cp857"}, {"ibm860", "cp860"}, {"ibm861", "cp861"}, {"ibm862", "cp862"}, {"ibm863", "cp863"}, {"ibm864", "cp864"}, {"ibm865", "cp865"}, {"ibm866", "cp866"}, {"ibm869", "cp869"}, {"ibm874", "cp874"}, {"ibm932", "cp932"}, {"ibm936", "cp936"}, {"ibm949", "cp949"}, {"ibm950", "cp950"}, {"iso-2022", "iso2022"}, {"iso-2022-jp", "iso2022-jp"}, {"iso-2022-kr", "iso2022-kr"}, {"iso-8859-1", "iso8859-1"}, {"iso-8859-10", "iso8859-10"}, {"iso-8859-13", "iso8859-13"}, {"iso-8859-14", "iso8859-14"}, {"iso-8859-15", "iso8859-15"}, {"iso-8859-16", "iso8859-16"}, {"iso-8859-2", "iso8859-2"}, {"iso-8859-3", "iso8859-3"}, {"iso-8859-4", "iso8859-4"}, {"iso-8859-5", "iso8859-5"}, {"iso-8859-6", "iso8859-6"}, {"iso-8859-7", "iso8859-7"}, {"iso-8859-8", "iso8859-8"}, {"iso-8859-9", "iso8859-9"}, {"iso2022", "iso2022"}, {"iso2022-jp", "iso2022-jp"}, {"iso2022-kr", "iso2022-kr"}, {"iso8859-1", "iso8859-1"}, {"iso8859-10", "iso8859-10"}, {"iso8859-13", "iso8859-13"}, {"iso8859-14", "iso8859-14"}, {"iso8859-15", "iso8859-15"}, {"iso8859-16", "iso8859-16"}, {"iso8859-2", "iso8859-2"}, {"iso8859-3", "iso8859-3"}, {"iso8859-4", "iso8859-4"}, {"iso8859-5", "iso8859-5"}, {"iso8859-6", "iso8859-6"}, {"iso8859-7", "iso8859-7"}, {"iso8859-8", "iso8859-8"}, {"iso8859-9", "iso8859-9"}, {"iso88591", "iso8859-1"}, {"iso885915", "iso8859-15"}, {"iso88592", "iso8859-2"}, {"iso88595", "iso8859-5"}, {"iso88596", "iso8859-6"}, {"iso88597", "iso8859-7"}, {"iso88598", "iso8859-8"}, {"iso88599", "iso8859-9"}, #ifdef hpux {"ja", "shiftjis"}, #else {"ja", "euc-jp"}, #endif {"ja_jp", "euc-jp"}, {"ja_jp.euc", "euc-jp"}, {"ja_jp.eucjp", "euc-jp"}, {"ja_jp.jis", "iso2022-jp"}, {"ja_jp.mscode", "shiftjis"}, {"ja_jp.sjis", "shiftjis"}, {"ja_jp.ujis", "euc-jp"}, {"japan", "euc-jp"}, #ifdef hpux {"japanese", "shiftjis"}, #else {"japanese", "euc-jp"}, #endif {"japanese-sjis", "shiftjis"}, {"japanese-ujis", "euc-jp"}, {"japanese.euc", "euc-jp"}, {"japanese.sjis", "shiftjis"}, {"jis0201", "jis0201"}, {"jis0208", "jis0208"}, {"jis0212", "jis0212"}, {"jp_jp", "shiftjis"}, {"ko", "euc-kr"}, {"ko_kr", "euc-kr"}, {"ko_kr.euc", "euc-kr"}, {"ko_kw.euckw", "euc-kr"}, {"koi8-r", "koi8-r"}, {"koi8-u", "koi8-u"}, {"korean", "euc-kr"}, {"ksc5601", "ksc5601"}, {"maccenteuro", "macCentEuro"}, {"maccroatian", "macCroatian"}, {"maccyrillic", "macCyrillic"}, {"macdingbats", "macDingbats"}, {"macgreek", "macGreek"}, {"maciceland", "macIceland"}, {"macjapan", "macJapan"}, {"macroman", "macRoman"}, {"macromania", "macRomania"}, {"macthai", "macThai"}, {"macturkish", "macTurkish"}, {"macukraine", "macUkraine"}, {"roman8", "iso8859-1"}, {"ru", "iso8859-5"}, {"ru_ru", "iso8859-5"}, {"ru_su", "iso8859-5"}, {"shiftjis", "shiftjis"}, {"sjis", "shiftjis"}, {"symbol", "symbol"}, {"tis-620", "tis-620"}, {"tis620", "tis-620"}, {"turkish8", "cp857"}, {"utf8", "utf-8"}, {"zh", "cp936"}, {"zh_cn.gb2312", "euc-cn"}, {"zh_cn.gbk", "euc-cn"}, {"zh_cz.gb2312", "euc-cn"}, {"zh_tw", "euc-tw"}, {"zh_tw.big5", "big5"}, }; #ifndef TCL_NO_STACK_CHECK static int GetStackSize _ANSI_ARGS_((size_t *stackSizePtr)); #endif /* TCL_NO_STACK_CHECK */ #ifdef HAVE_COREFOUNDATION static int MacOSXGetLibraryPath _ANSI_ARGS_(( Tcl_Interp *interp, int maxPathLen, char *tclLibPath)); #endif /* HAVE_COREFOUNDATION */ /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * |
︙ | ︙ | |||
388 389 390 391 392 393 394 | open("/dev/null", O_WRONLY); } if (TclOSseek(2, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) { open("/dev/null", O_WRONLY); } /* | | | | < | | | > | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | > | > > | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > | > > < | < | < | < < < | | | > > > | | > | > | < | < < < | > | | | < | < | < | < < < | < | | < < < | | | < < | | | | 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 | open("/dev/null", O_WRONLY); } if (TclOSseek(2, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) { open("/dev/null", O_WRONLY); } /* * The code below causes SIGPIPE (broken pipe) errors to be ignored. This * is needed so that Tcl processes don't die if they create child * processes (e.g. using "exec" or "open") that terminate prematurely. * The signal handler is only set up when the first interpreter is * created; after this the application can override the handler with a * different one of its own, if it wants. */ #ifdef SIGPIPE (void) signal(SIGPIPE, SIG_IGN); #endif /* SIGPIPE */ #ifdef __FreeBSD__ fpsetround(FP_RN); (void) fpsetmask(0L); #endif #if defined(__bsdi__) && (_BSDI_VERSION > 199501) /* * Find local symbols. Don't report an error if we fail. */ (void) dlopen (NULL, RTLD_NOW); /* INTL: Native. */ #endif /* * Initialize the C library's locale subsystem. This is required for input * methods to work properly on X11. We only do this for LC_CTYPE because * that's the necessary one, and we don't want to affect LC_TIME here. * The side effect of setting the default locale should be to load any * locale specific modules that are needed by X. [BUG: 5422 3345 4236 2522 * 2521]. */ setlocale(LC_CTYPE, ""); /* * In case the initial locale is not "C", ensure that the numeric * processing is done in "C" locale regardless. This is needed because Tcl * relies on routines like strtod, but should not have locale dependent * behavior. */ setlocale(LC_NUMERIC, "C"); } /* *--------------------------------------------------------------------------- * * TclpInitLibraryPath -- * * This is the fallback routine that sets the library path if the * application has not set one by the first time it is needed. * * Results: * None. * * Side effects: * Sets the library path to an initial value. * *------------------------------------------------------------------------- */ void TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr) char **valuePtr; int *lengthPtr; Tcl_Encoding *encodingPtr; { #define LIBRARY_SIZE 32 Tcl_Obj *pathPtr, *objPtr; CONST char *str; Tcl_DString buffer, ds; int pathc; CONST char **pathv; char installLib[LIBRARY_SIZE]; Tcl_DStringInit(&ds); pathPtr = Tcl_NewObj(); /* * Initialize the substrings used when locating an executable. The * installLib variable computes the path as though the executable is * installed. */ sprintf(installLib, "lib/tcl%s", TCL_VERSION); /* * Look for the library relative to the TCL_LIBRARY env variable. If the * last dirname in the TCL_LIBRARY path does not match the last dirname in * the installLib variable, use the last dir name of installLib in * addition to the orginal TCL_LIBRARY path. */ str = getenv("TCL_LIBRARY"); /* INTL: Native. */ Tcl_ExternalToUtfDString(NULL, str, -1, &buffer); str = Tcl_DStringValue(&buffer); if ((str != NULL) && (str[0] != '\0')) { /* * If TCL_LIBRARY is set, search there. */ objPtr = Tcl_NewStringObj(str, -1); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); Tcl_SplitPath(str, &pathc, &pathv); if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) { /* * If TCL_LIBRARY is set but refers to a different tcl * installation than the current version, try fiddling with the * specified directory to make it refer to this installation by * removing the old "tclX.Y" and substituting the current version * string. */ pathv[pathc - 1] = installLib + 4; str = Tcl_JoinPath(pathc, pathv, &ds); objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); Tcl_DStringFree(&ds); } ckfree((char *) pathv); } /* * Finally, look for the library relative to the compiled-in path. This is * needed when users install Tcl with an exec-prefix that is different * from the prtefix. */ { #ifdef HAVE_COREFOUNDATION char tclLibPath[MAXPATHLEN + 1]; if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) { str = tclLibPath; } else #endif /* HAVE_COREFOUNDATION */ { /* * TODO: Pull this value from the TIP 59 table. */ str = defaultLibraryDir; } if (str[0] != '\0') { objPtr = Tcl_NewStringObj(str, -1); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); } } Tcl_DStringFree(&buffer); *encodingPtr = Tcl_GetEncoding(NULL, NULL); str = Tcl_GetStringFromObj(pathPtr, lengthPtr); *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1); memcpy((VOID *) *valuePtr, (VOID *) str, (size_t)(*lengthPtr)+1); Tcl_DecrRefCount(pathPtr); } /* *--------------------------------------------------------------------------- * * TclpSetInitialEncodings -- * * Based on the locale, determine the encoding of the operating system * and the default encoding for newly opened files. * * Called at process initialization time, and part way through startup, * we verify that the initial encodings were correctly setup. Depending * on Tcl's environment, there may not have been enough information first * time through (above). * * Results: * None. * * Side effects: * The Tcl library path is converted from native encoding to UTF-8, on * the first call, and the encodings may be changed on first or second * call. * *--------------------------------------------------------------------------- */ void TclpSetInitialEncodings() { Tcl_DString encodingName; Tcl_SetSystemEncoding(NULL, TclpGetEncodingNameFromEnvironment(&encodingName)); Tcl_DStringFree(&encodingName); } void TclpSetInterfaces() { /* do nothing */ } static CONST char * SearchKnownEncodings(encoding) CONST char *encoding; { int left = 0; int right = sizeof(localeTable)/sizeof(LocaleTable); while (left <= right) { int test = (left + right)/2; int code = strcmp(localeTable[test].lang, encoding); if (code == 0) { return localeTable[test].encoding; } if (code < 0) { left = test+1; } else { right = test-1; } } return NULL; } CONST char * TclpGetEncodingNameFromEnvironment(bufPtr) Tcl_DString *bufPtr; { CONST char *encoding; CONST char *knownEncoding; Tcl_DStringInit(bufPtr); /* * Determine the current encoding from the LC_* or LANG environment * variables. We previously used setlocale() to determine the locale, but * this does not work on some systems (e.g. Linux/i386 RH 5.0). */ #ifdef HAVE_LANGINFO if (setlocale(LC_CTYPE, "") != NULL) { Tcl_DString ds; /* * Use a DString so we can modify case. */ Tcl_DStringInit(&ds); encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1); Tcl_UtfToLower(Tcl_DStringValue(&ds)); knownEncoding = SearchKnownEncodings(encoding); if (knownEncoding != NULL) { Tcl_DStringAppend(bufPtr, knownEncoding, -1); } else if (NULL != Tcl_GetEncoding(NULL, encoding)) { Tcl_DStringAppend(bufPtr, encoding, -1); } Tcl_DStringFree(&ds); if (Tcl_DStringLength(bufPtr)) { return Tcl_DStringValue(bufPtr); } } #endif /* HAVE_LANGINFO */ /* * Classic fallback check. This tries a homebrew algorithm to determine * what encoding should be used based on env vars. */ encoding = getenv("LC_ALL"); if (encoding == NULL || encoding[0] == '\0') { encoding = getenv("LC_CTYPE"); } if (encoding == NULL || encoding[0] == '\0') { encoding = getenv("LANG"); } if (encoding == NULL || encoding[0] == '\0') { encoding = NULL; } if (encoding != NULL) { CONST char *p; Tcl_DString ds; Tcl_DStringInit(&ds); p = encoding; encoding = Tcl_DStringAppend(&ds, p, -1); Tcl_UtfToLower(Tcl_DStringValue(&ds)); knownEncoding = SearchKnownEncodings(encoding); if (knownEncoding != NULL) { Tcl_DStringAppend(bufPtr, knownEncoding, -1); } else if (NULL != Tcl_GetEncoding(NULL, encoding)) { Tcl_DStringAppend(bufPtr, encoding, -1); } if (Tcl_DStringLength(bufPtr)) { Tcl_DStringFree(&ds); return Tcl_DStringValue(bufPtr); } /* * We didn't recognize the full value as an encoding name. If there is * an encoding subfield, we can try to guess from that. */ for (p = encoding; *p != '\0'; p++) { if (*p == '.') { p++; break; } } if (*p != '\0') { knownEncoding = SearchKnownEncodings(p); if (knownEncoding != NULL) { Tcl_DStringAppend(bufPtr, knownEncoding, -1); } else if (NULL != Tcl_GetEncoding(NULL, p)) { Tcl_DStringAppend(bufPtr, p, -1); } } Tcl_DStringFree(&ds); if (Tcl_DStringLength(bufPtr)) { return Tcl_DStringValue(bufPtr); } } return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, -1); } /* *--------------------------------------------------------------------------- * * TclpSetVariables -- * * Performs platform-specific interpreter initialization related to the * tcl_library and tcl_platform variables, and other platform-specific * things. * * Results: * None. * * Side effects: * Sets "tclDefaultLibrary", "tcl_pkgPath", and "tcl_platform" Tcl * variables. |
︙ | ︙ | |||
724 725 726 727 728 729 730 | #ifndef NO_UNAME struct utsname name; #endif int unameOK; CONST char *user; Tcl_DString ds; | | | | | | < | < | | > | | | > > | > > | | > > | | | | | | | | > | | > | > | | | | | | | | | | | | > | | | | | | | | | | | | | | | | > | | | | | > | | | > > | 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 | #ifndef NO_UNAME struct utsname name; #endif int unameOK; CONST char *user; Tcl_DString ds; #ifdef HAVE_COREFOUNDATION char tclLibPath[MAXPATHLEN + 1]; if (MacOSXGetLibraryPath(interp, MAXPATHLEN, tclLibPath) == TCL_OK) { CONST char *str; Tcl_DString ds; CFBundleRef bundleRef; Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "tcl_pkgPath", " ", TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds); if ((str != NULL) && (str[0] != '\0')) { char *p = Tcl_DStringValue(&ds); /* * Convert DYLD_FRAMEWORK_PATH from colon to space separated. */ do { if (*p == ':') { *p = ' '; } } while (*p++); Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); Tcl_SetVar(interp, "tcl_pkgPath", " ", TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); Tcl_DStringFree(&ds); } bundleRef = CFBundleGetMainBundle(); if (bundleRef) { CFURLRef frameworksURL; Tcl_StatBuf statBuf; frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef); if (frameworksURL) { if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE, (unsigned char*) tclLibPath, MAXPATHLEN) && ! TclOSstat(tclLibPath, &statBuf) && S_ISDIR(statBuf.st_mode)) { Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); Tcl_SetVar(interp, "tcl_pkgPath", " ", TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); } CFRelease(frameworksURL); } frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef); if (frameworksURL) { if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE, (unsigned char*) tclLibPath, MAXPATHLEN) && ! TclOSstat(tclLibPath, &statBuf) && S_ISDIR(statBuf.st_mode)) { Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); Tcl_SetVar(interp, "tcl_pkgPath", " ", TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); } CFRelease(frameworksURL); } } Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); } else #endif /* HAVE_COREFOUNDATION */ { Tcl_SetVar(interp, "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 if (uname(&name) >= 0) { CONST char *native; unameOK = 1; native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds); Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); /* * The following code is a special hack to handle differences in the * way version information is returned by uname. On most systems the * full version number is available in name.release. However, under * AIX the major version number is in name.version and the minor * version number is in name.release. */ if ((strchr(name.release, '.') != NULL) || !isdigit(UCHAR(name.version[0]))) { /* INTL: digit */ Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, TCL_GLOBAL_ONLY); } else { #ifdef DJGPP /* * For some obscure reason DJGPP puts major version into * name.release and minor into name.version. As of DJGPP 2.04 this * is documented in djgpp libc.info file. */ Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".", TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version, TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); #else |
︙ | ︙ | |||
847 848 849 850 851 852 853 | if (!unameOK) { Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY); } /* | | < | | | | | | < | 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 | if (!unameOK) { Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY); } /* * Copy USER or LOGNAME environment variable into tcl_platform(user). */ Tcl_DStringInit(&ds); user = TclGetEnv("USER", &ds); if (user == NULL) { user = TclGetEnv("LOGNAME", &ds); if (user == NULL) { user = ""; } } Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); } /* *---------------------------------------------------------------------- * * TclpFindVariable -- * * Locate the entry in environ for a given name. On Unix this routine is * case sensetive, on Windows this matches mixed case. * * Results: * The return value is the index in environ of an entry with the name * "name", or -1 if there is no such entry. The integer at *lengthPtr is * filled in with the length of name (if a matching entry is found) or * the length of the environ array (if no matching entry is found). * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
916 917 918 919 920 921 922 | } Tcl_DStringFree(&envString); } *lengthPtr = i; | | | | | | > | > > > | | | | | | | 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 | } Tcl_DStringFree(&envString); } *lengthPtr = i; done: Tcl_DStringFree(&envString); return result; } /* *---------------------------------------------------------------------- * * TclpCheckStackSpace -- * * Detect if we are about to blow the stack. Called before an evaluation * can happen when nesting depth is checked. * * Results: * 1 if there is enough stack space to continue; 0 if not. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclpCheckStackSpace() { #ifdef TCL_NO_STACK_CHECK /* * This function was normally unimplemented on Unix platforms and this * implements old behavior, i.e. no stack checking performed. */ return 1; #else ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* Most variables are actually in a * thread-specific data block to minimise the * impact on the stack. */ register ptrdiff_t stackUsed; int localVar; /* Reference to somewhere on the local stack. * This is declared last so it's as "deep" as * possible. */ if (tsdPtr == NULL) { /* * This should probably be a panic(); if we're out of stack, we might * have virtually no room to manoeuver at all. */ Tcl_Panic("failed to get thread specific stack check data"); } /* * The first time through, we record the "outermost" stack frame. */ if (tsdPtr->outerVarPtr == NULL) { tsdPtr->outerVarPtr = &localVar; } if (tsdPtr->initialised == 0) { /* * We appear to have not computed the stack size before. Attempt to * retrieve it from either the current thread or, failing that, the * process accounting limit. Note that we assume that stack sizes do * not change throughout the lifespan of the thread/process; this is * almost always true. */ tsdPtr->stackDetermineResult = GetStackSize(&tsdPtr->stackSize); tsdPtr->initialised = 1; } switch (tsdPtr->stackDetermineResult) { |
︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 | if (&localVar > tsdPtr->outerVarPtr) { stackUsed = (char *)&localVar - (char *)tsdPtr->outerVarPtr; } else { stackUsed = (char *)tsdPtr->outerVarPtr - (char *)&localVar; } /* | | < | | | | | | | | | | 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 | if (&localVar > tsdPtr->outerVarPtr) { stackUsed = (char *)&localVar - (char *)tsdPtr->outerVarPtr; } else { stackUsed = (char *)tsdPtr->outerVarPtr - (char *)&localVar; } /* * Now we perform the actual check. Are we about to blow our stack frame? */ if (stackUsed < (ptrdiff_t) tsdPtr->stackSize) { STACK_DEBUG(("stack OK\tin:%p\tout:%p\tuse:%04X\tmax:%04X\n", &localVar, tsdPtr->outerVarPtr, stackUsed, tsdPtr->stackSize)); return 1; } else { STACK_DEBUG(("stack OVERFLOW\tin:%p\tout:%p\tuse:%04X\tmax:%04X\n", &localVar, tsdPtr->outerVarPtr, stackUsed, tsdPtr->stackSize)); return 0; } #endif /* TCL_NO_STACK_CHECK */ } /* *---------------------------------------------------------------------- * * GetStackSize -- * * Discover what the stack size for the current thread/process actually * is. Expects to only ever be called once per thread and then only at a * point when there is a reasonable amount of space left on the current * stack; TclpCheckStackSpace is called sufficiently frequently that that * is true. * * Results: * TCL_OK if the stack space was discovered, TCL_BREAK if the stack space * was undiscoverable in a way that stack checks should fail, and * TCL_CONTINUE if the stack space was undiscoverable in a way that stack * checks should succeed. * * Side effects: * None * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1068 1069 1070 1071 1072 1073 1074 | return TCL_BREAK; } if (rawStackSize > 0) { goto finalSanityCheck; } /* | | | | < | | | | 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 | return TCL_BREAK; } if (rawStackSize > 0) { goto finalSanityCheck; } /* * If we have zero or an error, try the system limits instead. After all, * the pthread documentation states that threads should always be bound by * the system stack size limit in any case. */ #endif /* TCL_THREADS */ if (getrlimit(RLIMIT_STACK, &rLimit) != 0) { /* * getrlimit() failed, just fail the whole thing. */ return TCL_BREAK; } if (rLimit.rlim_cur == RLIM_INFINITY) { /* * Limit is "infinite"; there is no stack limit. */ return TCL_CONTINUE; } rawStackSize = rLimit.rlim_cur; /* * Final sanity check on the determined stack size. If we fail this, * assume there are bogus values about and that we can't actually figure * out what the stack size really is. */ #ifdef TCL_THREADS /* Stop warning... */ finalSanityCheck: #endif if (rawStackSize <= 0) { return TCL_CONTINUE; |
︙ | ︙ | |||
1118 1119 1120 1121 1122 1123 1124 | #endif /* TCL_NO_STACK_CHECK */ /* *---------------------------------------------------------------------- * * MacOSXGetLibraryPath -- * | | | < | > | | > > | > > > > > > > > | 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 | #endif /* TCL_NO_STACK_CHECK */ /* *---------------------------------------------------------------------- * * MacOSXGetLibraryPath -- * * If we have a bundle structure for the Tcl installation, then check * there first to see if we can find the libraries there. * * Results: * TCL_OK if we have found the tcl library; TCL_ERROR otherwise. * * Side effects: * Same as for Tcl_MacOSXOpenVersionedBundleResources. * *---------------------------------------------------------------------- */ #ifdef HAVE_COREFOUNDATION static int MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath) { int foundInFramework = TCL_ERROR; #ifdef TCL_FRAMEWORK foundInFramework = Tcl_MacOSXOpenVersionedBundleResources(interp, "com.tcltk.tcllibrary", TCL_FRAMEWORK_VERSION, 0, maxPathLen, tclLibPath); #endif return foundInFramework; } #endif /* HAVE_COREFOUNDATION */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclUnixNotfy.c.
1 2 3 | /* * tclUnixNotify.c -- * | | | | < | | | > > > > > > > | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | < | | | > > | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | /* * 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.18.2.6 2005/08/02 18:16:57 dgp Exp $ */ #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is * in tclMacOSXNotify.c */ #include "tclInt.h" #include <signal.h> /* * This code does deep stub magic to allow replacement of the notifier at * runtime. */ extern TclStubs tclStubs; extern Tcl_NotifierProcs tclOriginalNotifier; /* * This structure is used to keep track of the notifier info for a registered * file. */ typedef struct FileHandler { int fd; int mask; /* Mask of desired events: TCL_READABLE, * etc. */ int readyMask; /* Mask of events that have been seen since * the last time file handlers were invoked * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ ClientData clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; /* * The following structure is what is added to the Tcl event queue when file * handlers are ready to fire. */ typedef struct FileHandlerEvent { Tcl_Event header; /* Information that is standard for all * events. */ int fd; /* File descriptor that is ready. Used to find * the FileHandler structure for the file * (can't point directly to the FileHandler * structure because it could go away while * the event is queued). */ } FileHandlerEvent; /* * * The following structure contains a set of select() masks to track readable, * writable, and exceptional conditions. */ typedef struct SelectMasks { fd_set readable; fd_set writable; fd_set exceptional; } SelectMasks; /* * The following static structure contains the state information for the * select based implementation of the Tcl notifier. One of these structures is * created for each thread that is using the notifier. */ typedef struct ThreadSpecificData { FileHandler *firstFileHandlerPtr; /* Pointer to head of file handler list. */ SelectMasks checkMasks; /* This structure is used to build up the * masks to be used in the next call to * select. Bits are set in response to calls * to Tcl_CreateFileHandler. */ SelectMasks readyMasks; /* This array reflects the readable/writable * conditions that were found to exist by the * last call to select. */ int numFdBits; /* Number of valid bits in checkMasks (one * more than highest fd for which * Tcl_WatchFile has been called). */ #ifdef TCL_THREADS int onList; /* True if it is in this list */ unsigned int pollState; /* pollState is used to implement a polling * handshake between each thread and the * notifier thread. Bits defined below. */ struct ThreadSpecificData *nextPtr, *prevPtr; /* All threads that are currently waiting on * an event have their ThreadSpecificData * structure on a doubly-linked listed formed * from these pointers. You must hold the * notifierMutex lock before accessing these * fields. */ Tcl_Condition waitCV; /* Any other thread alerts a notifier that an * event is ready to be processed by signaling * this condition variable. */ int eventReady; /* True if an event is ready to be processed. * Used as condition flag together with waitCV * above. */ #endif } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #ifdef TCL_THREADS /* * The following static indicates the number of threads that have initialized * notifiers. * * You must hold the notifierMutex lock before accessing this variable. */ static int notifierCount = 0; /* * The following variable points to the head of a doubly-linked list of * ThreadSpecificData structures for all threads that are currently waiting on * an event. * * You must hold the notifierMutex lock before accessing this list. */ static ThreadSpecificData *waitingListPtr = NULL; /* * The notifier thread spends all its time in select() waiting for a file * descriptor associated with one of the threads on the waitingListPtr list to * do something interesting. But if the contents of the waitingListPtr list * ever changes, we need to wake up and restart the select() system call. You * can wake up the notifier thread by writing a single byte to the file * descriptor defined below. This file descriptor is the input-end of a pipe * and the notifier thread is listening for data on the output-end of the same * pipe. Hence writing to this file descriptor will cause the select() system * call to return and wake up the notifier thread. * * You must hold the notifierMutex lock before accessing this list. */ static int triggerPipe = -1; /* * The notifierMutex locks access to all of the global notifier state. */ TCL_DECLARE_MUTEX(notifierMutex) /* * The notifier thread signals the notifierCV when it has finished * initializing the triggerPipe and right before the notifier thread * terminates. */ static Tcl_Condition notifierCV; /* * The pollState bits: * POLL_WANT is set by each thread before it waits on its condition * variable. It is checked by the notifier before it does select. * POLL_DONE is set by the notifier if it goes into select after seeing * POLL_WANT. The idea is to ensure it tries a select with the * same bits the initial thread had set. */ #define POLL_WANT 0x1 #define POLL_DONE 0x2 /* * This is the thread ID of the notifier thread that does select. */ static Tcl_ThreadId notifierThread; #endif /* * Static routines defined in this file. */ #ifdef TCL_THREADS static void NotifierThreadProc(ClientData clientData); #endif static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); /* *---------------------------------------------------------------------- * * Tcl_InitNotifier -- * * Initializes the platform specific notifier state. |
︙ | ︙ | |||
215 216 217 218 219 220 221 | /* * Start the Notifier thread if necessary. */ Tcl_MutexLock(¬ifierMutex); if (notifierCount == 0) { if (TclpThreadCreate(¬ifierThread, NotifierThreadProc, NULL, | | | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 | /* * Start the Notifier thread if necessary. */ Tcl_MutexLock(¬ifierMutex); if (notifierCount == 0) { if (TclpThreadCreate(¬ifierThread, NotifierThreadProc, NULL, TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) { Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread"); } } notifierCount++; /* * Wait for the notifier pipe to be created. |
︙ | ︙ | |||
239 240 241 242 243 244 245 | } /* *---------------------------------------------------------------------- * * Tcl_FinalizeNotifier -- * | | | | | | | > | | | | | | | < | > > | | > > > > > | | < | | | < | 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 | } /* *---------------------------------------------------------------------- * * Tcl_FinalizeNotifier -- * * This function is called to cleanup the notifier state before a thread * is terminated. * * Results: * None. * * Side effects: * May terminate the background notifier thread if this is the last * notifier instance. * *---------------------------------------------------------------------- */ void Tcl_FinalizeNotifier(clientData) ClientData clientData; /* Not used. */ { #ifdef TCL_THREADS ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_MutexLock(¬ifierMutex); notifierCount--; /* * If this is the last thread to use the notifier, close the notifier pipe * and wait for the background thread to terminate. */ if (notifierCount == 0) { int result; if (triggerPipe < 0) { Tcl_Panic("Tcl_FinalizeNotifier: notifier pipe not initialized"); } /* * Send "q" message to the notifier thread so that it will terminate. * The notifier will return from its call to select() and notice that * a "q" message has arrived, it will then close its side of the pipe * and terminate its thread. Note the we can not just close the pipe * and check for EOF in the notifier thread because if a background * child process was created with exec, select() would not register * the EOF on the pipe until the child processes had terminated. [Bug: * 4139] [Bug: 1222872] */ write(triggerPipe, "q", 1); close(triggerPipe); while(triggerPipe >= 0) { Tcl_ConditionWait(¬ifierCV, ¬ifierMutex, NULL); } result = Tcl_JoinThread(notifierThread, NULL); if (result) { Tcl_Panic("Tcl_FinalizeNotifier: unable to join notifier thread"); } } /* * Clean up any synchronization objects in the thread local storage. */ Tcl_ConditionFinalize(&(tsdPtr->waitCV)); Tcl_MutexUnlock(¬ifierMutex); #endif } /* *---------------------------------------------------------------------- * * Tcl_AlertNotifier -- * * Wake up the specified notifier from any thread. This routine is called * by the platform independent notifier code whenever the Tcl_ThreadAlert * routine is called. This routine is guaranteed not to be called on a * given notifier after Tcl_FinalizeNotifier is called for that notifier. * * Results: * None. * * Side effects: * Signals the notifier condition variable for the specified notifier. * *---------------------------------------------------------------------- */ void Tcl_AlertNotifier(clientData) ClientData clientData; |
︙ | ︙ | |||
337 338 339 340 341 342 343 | } /* *---------------------------------------------------------------------- * * Tcl_SetTimer -- * | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_SetTimer -- * * This function sets the current notifier timer value. This interface is * not implemented in this notifier because we are always running inside * of Tcl_DoOneEvent. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_SetTimer(timePtr) Tcl_Time *timePtr; /* Timeout value, may be NULL. */ { /* * The interval timer doesn't do anything in this implementation, because * the only event loop is via Tcl_DoOneEvent, which passes timeout values * to Tcl_WaitForEvent. */ if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) { tclStubs.tcl_SetTimer(timePtr); } } |
︙ | ︙ | |||
393 394 395 396 397 398 399 | } /* *---------------------------------------------------------------------- * * Tcl_CreateFileHandler -- * | | | | | | | | | | | | | | | | | | < | > | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_CreateFileHandler -- * * This function registers a file handler with the select notifier. * * Results: * None. * * Side effects: * Creates a new file handler structure. * *---------------------------------------------------------------------- */ void Tcl_CreateFileHandler(fd, mask, proc, clientData) int fd; /* Handle of stream to watch. */ int mask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc; /* Function to call for each selected * event. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr; if (tclStubs.tcl_CreateFileHandler != tclOriginalNotifier.createFileHandlerProc) { tclStubs.tcl_CreateFileHandler(fd, mask, proc, clientData); return; } for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; filePtr = filePtr->nextPtr) { if (filePtr->fd == fd) { break; } } if (filePtr == NULL) { filePtr = (FileHandler*) ckalloc(sizeof(FileHandler)); filePtr->fd = fd; filePtr->readyMask = 0; filePtr->nextPtr = tsdPtr->firstFileHandlerPtr; tsdPtr->firstFileHandlerPtr = filePtr; } filePtr->proc = proc; filePtr->clientData = clientData; filePtr->mask = mask; /* * Update the check masks for this file. */ if (mask & TCL_READABLE) { FD_SET(fd, &(tsdPtr->checkMasks.readable)); } else { FD_CLR(fd, &(tsdPtr->checkMasks.readable)); } if (mask & TCL_WRITABLE) { FD_SET(fd, &(tsdPtr->checkMasks.writable)); } else { FD_CLR(fd, &(tsdPtr->checkMasks.writable)); } if (mask & TCL_EXCEPTION) { FD_SET(fd, &(tsdPtr->checkMasks.exceptional)); } else { FD_CLR(fd, &(tsdPtr->checkMasks.exceptional)); } if (tsdPtr->numFdBits <= fd) { tsdPtr->numFdBits = fd+1; } } /* *---------------------------------------------------------------------- * * Tcl_DeleteFileHandler -- * * Cancel a previously-arranged callback arrangement for a file. * * Results: * None. * * Side effects: * If a callback was previously registered on file, remove it. * *---------------------------------------------------------------------- */ void Tcl_DeleteFileHandler(fd) int fd; /* Stream id for which to remove callback * function. */ { FileHandler *filePtr, *prevPtr; int i; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tclStubs.tcl_DeleteFileHandler != tclOriginalNotifier.deleteFileHandlerProc) { tclStubs.tcl_DeleteFileHandler(fd); return; } /* * Find the entry for the given file (and return if there isn't one). */ for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ; prevPtr = filePtr, filePtr = filePtr->nextPtr) { if (filePtr == NULL) { return; } if (filePtr->fd == fd) { break; } } /* * Update the check masks for this file. */ if (filePtr->mask & TCL_READABLE) { FD_CLR(fd, &(tsdPtr->checkMasks.readable)); } if (filePtr->mask & TCL_WRITABLE) { FD_CLR(fd, &(tsdPtr->checkMasks.writable)); } if (filePtr->mask & TCL_EXCEPTION) { FD_CLR(fd, &(tsdPtr->checkMasks.exceptional)); } /* * Find current max fd. */ if (fd+1 == tsdPtr->numFdBits) { tsdPtr->numFdBits = 0; for (i = fd-1; i >= 0; i--) { if (FD_ISSET(i, &(tsdPtr->checkMasks.readable)) || FD_ISSET(i, &(tsdPtr->checkMasks.writable)) || FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) { tsdPtr->numFdBits = i+1; break; } } } /* |
︙ | ︙ | |||
555 556 557 558 559 560 561 | } /* *---------------------------------------------------------------------- * * FileHandlerEventProc -- * | | | | | | | | | | | | | | | | | | | | | | < | > | | | | < < > > > > > > > > > | | | < | > > > > > > > > > > > > > > > > | | > > | | | | | | > > > > | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | < < | | < | | | | | | | | | | | | | | < | | | | | | | < | | | | | | 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 | } /* *---------------------------------------------------------------------- * * FileHandlerEventProc -- * * This function is called by Tcl_ServiceEvent when a file event reaches * the front of the event queue. This function is responsible for * actually handling the event by invoking the callback for the file * handler. * * Results: * Returns 1 if the event was handled, meaning it should be removed from * the queue. Returns 0 if the event was not handled, meaning it should * stay on the queue. The only time the event isn't handled is if the * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the file handler's callback function does. * *---------------------------------------------------------------------- */ static int FileHandlerEventProc(evPtr, flags) Tcl_Event *evPtr; /* Event to service. */ int flags; /* Flags that indicate what events to handle, * such as TCL_FILE_EVENTS. */ { int mask; FileHandler *filePtr; FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; ThreadSpecificData *tsdPtr; if (!(flags & TCL_FILE_EVENTS)) { return 0; } /* * Search through the file handlers to find the one whose handle matches * the event. We do this rather than keeping a pointer to the file handler * directly in the event, so that the handler can be deleted while the * event is queued without leaving a dangling pointer. */ tsdPtr = TCL_TSD_INIT(&dataKey); for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL; filePtr = filePtr->nextPtr) { if (filePtr->fd != fileEvPtr->fd) { continue; } /* * The code is tricky for two reasons: * 1. The file handler's desired events could have changed since the * time when the event was queued, so AND the ready mask with the * desired mask. * 2. The file could have been closed and re-opened since the time * when the event was queued. This is why the ready mask is stored * in the file handler rather than the queued event: it will be * zeroed when a new file handler is created for the newly opened * file. */ mask = filePtr->readyMask & filePtr->mask; filePtr->readyMask = 0; if (mask != 0) { (*filePtr->proc)(filePtr->clientData, mask); } break; } return 1; } /* *---------------------------------------------------------------------- * * Tcl_WaitForEvent -- * * This function is called by Tcl_DoOneEvent to wait for new events on * the message queue. If the block time is 0, then Tcl_WaitForEvent just * polls without blocking. * * Results: * Returns -1 if the select would block forever, otherwise returns 0. * * Side effects: * Queues file events that are detected by the select. * *---------------------------------------------------------------------- */ int Tcl_WaitForEvent(timePtr) Tcl_Time *timePtr; /* Maximum block time, or NULL. */ { FileHandler *filePtr; FileHandlerEvent *fileEvPtr; int mask; Tcl_Time myTime; #ifdef TCL_THREADS int waitForFiles; Tcl_Time *myTimePtr; #else /* * Impl. notes: timeout & timeoutPtr are used if, and only if threads are * not enabled. They are the arguments for the regular select() used when * the core is not thread-enabled. */ struct timeval timeout, *timeoutPtr; int numFound; #endif /* TCL_THREADS */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) { return tclStubs.tcl_WaitForEvent(timePtr); } /* * Set up the timeout structure. Note that if there are no events to check * for, we return with a negative result rather than blocking forever. */ if (timePtr != NULL) { /* * TIP #233 (Virtualized Time). Is virtual time in effect? And do we * actually have something to scale? If yes to both then we call the * handler to do this scaling. */ myTime.sec = timePtr->sec; myTime.usec = timePtr->usec; if (myTime.sec != 0 || myTime.usec != 0) { (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData); } #ifdef TCL_THREADS myTimePtr = &myTime; #else timeout.tv_sec = myTime.sec; timeout.tv_usec = myTime.usec; timeoutPtr = &timeout; #endif /* TCL_THREADS */ #ifndef TCL_THREADS } else if (tsdPtr->numFdBits == 0) { /* * If there are no threads, no timeout, and no fds registered, then * there are no events possible and we must avoid deadlock. Note that * this is not entirely correct because there might be a signal that * could interrupt the select call, but we don't handle that case if * we aren't using threads. */ return -1; #endif /* !TCL_THREADS */ } else { #ifdef TCL_THREADS myTimePtr = NULL; #else timeoutPtr = NULL; #endif /* TCL_THREADS */ } #ifdef TCL_THREADS /* * Place this thread on the list of interested threads, signal the * notifier thread, and wait for a response or a timeout. */ Tcl_MutexLock(¬ifierMutex); waitForFiles = (tsdPtr->numFdBits > 0); if (myTimePtr != NULL && myTimePtr->sec == 0 && myTimePtr->usec == 0) { /* * Cannot emulate a polling select with a polling condition variable. * Instead, pretend to wait for files and tell the notifier thread * what we are doing. The notifier thread makes sure it goes through * select with its select mask in the same state as ours currently is. * We block until that happens. */ waitForFiles = 1; tsdPtr->pollState = POLL_WANT; myTimePtr = NULL; } else { tsdPtr->pollState = 0; } if (waitForFiles) { /* * Add the ThreadSpecificData structure of this thread to the list of * ThreadSpecificData structures of all threads that are waiting on * file events. */ tsdPtr->nextPtr = waitingListPtr; if (waitingListPtr) { waitingListPtr->prevPtr = tsdPtr; } tsdPtr->prevPtr = 0; waitingListPtr = tsdPtr; tsdPtr->onList = 1; write(triggerPipe, "", 1); } FD_ZERO(&(tsdPtr->readyMasks.readable)); FD_ZERO(&(tsdPtr->readyMasks.writable)); FD_ZERO(&(tsdPtr->readyMasks.exceptional)); if (!tsdPtr->eventReady) { Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, myTimePtr); } tsdPtr->eventReady = 0; if (waitForFiles && tsdPtr->onList) { /* * Remove the ThreadSpecificData structure of this thread from the * waiting list. Alert the notifier thread to recompute its select * masks - skipping this caused a hang when trying to close a pipe * which the notifier thread was still doing a select on. */ if (tsdPtr->prevPtr) { tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; } else { waitingListPtr = tsdPtr->nextPtr; } if (tsdPtr->nextPtr) { tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; } tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; tsdPtr->onList = 0; write(triggerPipe, "", 1); } #else tsdPtr->readyMasks = tsdPtr->checkMasks; numFound = select(tsdPtr->numFdBits, &(tsdPtr->readyMasks.readable), &(tsdPtr->readyMasks.writable), &(tsdPtr->readyMasks.exceptional), timeoutPtr); /* * Some systems don't clear the masks after an error, so we have to do it * here. */ if (numFound == -1) { FD_ZERO(&(tsdPtr->readyMasks.readable)); FD_ZERO(&(tsdPtr->readyMasks.writable)); FD_ZERO(&(tsdPtr->readyMasks.exceptional)); } #endif /* TCL_THREADS */ /* * Queue all detected file events before returning. */ for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL); filePtr = filePtr->nextPtr) { mask = 0; if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.readable))) { mask |= TCL_READABLE; } if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.writable))) { mask |= TCL_WRITABLE; } if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.exceptional))) { mask |= TCL_EXCEPTION; } if (!mask) { continue; } /* * Don't bother to queue an event if the mask was previously non-zero * since an event must still be on the queue. */ if (filePtr->readyMask == 0) { fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->fd = filePtr->fd; Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); } filePtr->readyMask = mask; } #ifdef TCL_THREADS Tcl_MutexUnlock(¬ifierMutex); #endif /* TCL_THREADS */ return 0; } #ifdef TCL_THREADS /* *---------------------------------------------------------------------- * * NotifierThreadProc -- * * This routine is the initial (and only) function executed by the * special notifier thread. Its job is to wait for file descriptors to * become readable or writable or to have an exception condition and then * to notify other threads who are interested in this information by * signalling a condition variable. Other threads can signal this * notifier thread of a change in their interests by writing a single * byte to a special pipe that the notifier thread is monitoring. * * Result: * None. Once started, this routine never exits. It dies with the overall * process. * * Side effects: * The trigger pipe used to signal the notifier thread is created when * the notifier thread first starts. * *---------------------------------------------------------------------- */ static void NotifierThreadProc(clientData) ClientData clientData; /* Not used. */ { ThreadSpecificData *tsdPtr; fd_set readableMask; fd_set writableMask; fd_set exceptionalMask; int fds[2]; int i, status, numFdBits = 0, receivePipe; long found; struct timeval poll = {0., 0.}, *timePtr; char buf[2]; if (pipe(fds) != 0) { Tcl_Panic("NotifierThreadProc: could not create trigger pipe."); } |
︙ | ︙ | |||
888 889 890 891 892 893 894 | #else if (ioctl(receivePipe, (int) FIONBIO, &status) < 0) { Tcl_Panic("NotifierThreadProc: could not make receive pipe non blocking."); } if (ioctl(fds[1], (int) FIONBIO, &status) < 0) { Tcl_Panic("NotifierThreadProc: could not make trigger pipe non blocking."); } | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > | 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 | #else if (ioctl(receivePipe, (int) FIONBIO, &status) < 0) { Tcl_Panic("NotifierThreadProc: could not make receive pipe non blocking."); } if (ioctl(fds[1], (int) FIONBIO, &status) < 0) { Tcl_Panic("NotifierThreadProc: could not make trigger pipe non blocking."); } #endif /* FIONBIO */ /* * Install the write end of the pipe into the global variable. */ Tcl_MutexLock(¬ifierMutex); triggerPipe = fds[1]; /* * Signal any threads that are waiting. */ Tcl_ConditionNotify(¬ifierCV); Tcl_MutexUnlock(¬ifierMutex); /* * Look for file events and report them to interested threads. */ while (1) { FD_ZERO(&readableMask); FD_ZERO(&writableMask); FD_ZERO(&exceptionalMask); /* * Compute the logical OR of the select masks from all the waiting * notifiers. */ Tcl_MutexLock(¬ifierMutex); timePtr = NULL; for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { for (i = tsdPtr->numFdBits-1; i >= 0; --i) { if (FD_ISSET(i, &(tsdPtr->checkMasks.readable))) { FD_SET(i, &readableMask); } if (FD_ISSET(i, &(tsdPtr->checkMasks.writable))) { FD_SET(i, &writableMask); } if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) { FD_SET(i, &exceptionalMask); } } if (tsdPtr->numFdBits > numFdBits) { numFdBits = tsdPtr->numFdBits; } if (tsdPtr->pollState & POLL_WANT) { /* * Here we make sure we go through select() with the same mask * bits that were present when the thread tried to poll. */ tsdPtr->pollState |= POLL_DONE; timePtr = &poll; } } Tcl_MutexUnlock(¬ifierMutex); /* * Set up the select mask to include the receive pipe. */ if (receivePipe >= numFdBits) { numFdBits = receivePipe + 1; } FD_SET(receivePipe, &readableMask); if (select(numFdBits, &readableMask, &writableMask, &exceptionalMask, timePtr) == -1) { /* * Try again immediately on an error. */ continue; } /* * Alert any threads that are waiting on a ready file descriptor. */ Tcl_MutexLock(¬ifierMutex); for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { found = 0; for (i = tsdPtr->numFdBits-1; i >= 0; --i) { if (FD_ISSET(i, &(tsdPtr->checkMasks.readable)) && FD_ISSET(i, &readableMask)) { FD_SET(i, &(tsdPtr->readyMasks.readable)); found = 1; } if (FD_ISSET(i, &(tsdPtr->checkMasks.writable)) && FD_ISSET(i, &writableMask)) { FD_SET(i, &(tsdPtr->readyMasks.writable)); found = 1; } if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional)) && FD_ISSET(i, &exceptionalMask)) { FD_SET(i, &(tsdPtr->readyMasks.exceptional)); found = 1; } } if (found || (tsdPtr->pollState & POLL_DONE)) { tsdPtr->eventReady = 1; if (tsdPtr->onList) { /* * Remove the ThreadSpecificData structure of this thread * from the waiting list. This prevents us from * continuously spining on select until the other threads * runs and services the file event. */ if (tsdPtr->prevPtr) { tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; } else { waitingListPtr = tsdPtr->nextPtr; } if (tsdPtr->nextPtr) { tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; } tsdPtr->nextPtr = tsdPtr->prevPtr = NULL; tsdPtr->onList = 0; tsdPtr->pollState = 0; } Tcl_ConditionNotify(&tsdPtr->waitCV); } } Tcl_MutexUnlock(¬ifierMutex); /* * Consume the next byte from the notifier pipe if the pipe was * readable. Note that there may be multiple bytes pending, but to * avoid a race condition we only read one at a time. */ if (FD_ISSET(receivePipe, &readableMask)) { i = read(receivePipe, buf, 1); if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) { /* * Someone closed the write end of the pipe or sent us a Quit * message [Bug: 4139] and then closed the write end of the * pipe so we need to shut down the notifier thread. */ break; } } } /* * Clean up the read end of the pipe and signal any threads waiting on * termination of the notifier thread. */ close(receivePipe); Tcl_MutexLock(¬ifierMutex); triggerPipe = -1; Tcl_ConditionNotify(¬ifierCV); Tcl_MutexUnlock(¬ifierMutex); TclpThreadExit (0); } #endif /* TCL_THREADS */ #endif /* HAVE_COREFOUNDATION */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclUnixPipe.c.
|
| | | | | | | | | | | | | > | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | /* * 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.26.2.3 2005/08/02 18:16:57 dgp Exp $ */ #include "tclInt.h" #ifdef USE_VFORK #define fork vfork #endif /* * The following macros convert between TclFile's and fd's. The conversion * simple involves shifting fd's up by one to ensure that no valid fd is ever * the same as NULL. */ #define MakeFile(fd) ((TclFile)(((int)fd)+1)) #define GetFd(file) (((int)file)-1) /* * This structure describes per-instance state of a pipe based channel. */ typedef struct PipeState { Tcl_Channel channel; /* Channel associated with this file. */ TclFile inFile; /* Output from pipe. */ TclFile outFile; /* Input to pipe. */ TclFile errorFile; /* Error output from pipe. */ int numPids; /* How many processes are attached to this * pipe? */ Tcl_Pid *pidPtr; /* The process IDs themselves. Allocated by * the creator of the pipe. */ int isNonBlocking; /* Nonzero when the pipe is in nonblocking * mode. Used to decide whether to wait for * the children at close time. */ } PipeState; /* * Declarations for local procedures defined in this file: */ static int PipeBlockModeProc _ANSI_ARGS_((ClientData instanceData, |
︙ | ︙ | |||
61 62 63 64 65 66 67 | ClientData instanceData, CONST char *buf, int toWrite, int *errorCode)); static void PipeWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); static void RestoreSignals _ANSI_ARGS_((void)); static int SetupStdFile _ANSI_ARGS_((TclFile file, int type)); /* | | | | > > | 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 | ClientData instanceData, CONST char *buf, int toWrite, int *errorCode)); static void PipeWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); static void RestoreSignals _ANSI_ARGS_((void)); static int SetupStdFile _ANSI_ARGS_((TclFile file, int type)); /* * This structure describes the channel type structure for command pipe based * I/O: */ static Tcl_ChannelType pipeChannelType = { "pipe", /* Type name. */ TCL_CHANNEL_VERSION_4, /* v4 channel */ PipeCloseProc, /* Close proc. */ PipeInputProc, /* Input proc. */ PipeOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ PipeWatchProc, /* Initialize notifier. */ PipeGetHandleProc, /* Get OS handles out of channel. */ NULL, /* close2proc. */ PipeBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc */ NULL, /* thread action proc */ }; /* *---------------------------------------------------------------------- * * TclpMakeFile -- * |
︙ | ︙ | |||
105 106 107 108 109 110 111 | TclFile TclpMakeFile(channel, direction) Tcl_Channel channel; /* Channel to get file from. */ int direction; /* Either TCL_READABLE or TCL_WRITABLE. */ { ClientData data; | | | | | | 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 | TclFile TclpMakeFile(channel, direction) Tcl_Channel channel; /* Channel to get file from. */ int direction; /* Either TCL_READABLE or TCL_WRITABLE. */ { ClientData data; if (Tcl_GetChannelHandle(channel, direction, (ClientData *) &data) == TCL_OK) { return MakeFile((int) data); } else { return (TclFile) NULL; } } /* *---------------------------------------------------------------------- * * TclpOpenFile -- * * Open a file for use in a pipeline. * * Results: * Returns a new TclFile handle or NULL on failure. * * Side effects: * May cause a file to be created on the file system. * |
︙ | ︙ | |||
142 143 144 145 146 147 148 | 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) { | | | | | | | | | | | 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 | 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) && !(mode & O_APPEND)) { TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_END); } /* * Increment the fd so it can't be 0, which would conflict with the * NULL return for errors. */ return MakeFile(fd); } return NULL; } /* *---------------------------------------------------------------------- * * TclpCreateTempFile -- * * This function creates a temporary file initialized with an optional * string, and returns a file handle with the file pointer at the * beginning of the file. * * Results: * A handle to a file. * * Side effects: * None. * |
︙ | ︙ | |||
235 236 237 238 239 240 241 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Obj * TclpTempFileName() { char fileName[L_tmpnam + 9]; Tcl_Obj *result = NULL; int fd; /* |
︙ | ︙ | |||
259 260 261 262 263 264 265 | if (fd == -1) { return NULL; } fcntl(fd, F_SETFD, FD_CLOEXEC); unlink(fileName); /* INTL: Native. */ result = TclpNativeToNormalized((ClientData) fileName); | | | | | | | | | | 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 | if (fd == -1) { return NULL; } fcntl(fd, F_SETFD, FD_CLOEXEC); unlink(fileName); /* INTL: Native. */ result = TclpNativeToNormalized((ClientData) fileName); close(fd); return result; } /* *---------------------------------------------------------------------- * * TclpCreatePipe -- * * Creates a pipe - simply calls the pipe() function. * * Results: * Returns 1 on success, 0 on failure. * * Side effects: * Creates a pipe. * *---------------------------------------------------------------------- */ int TclpCreatePipe(readPipe, writePipe) TclFile *readPipe; /* Location to store file handle for read side * of pipe. */ TclFile *writePipe; /* Location to store file handle for write * side of pipe. */ { int pipeIds[2]; if (pipe(pipeIds) != 0) { return 0; } |
︙ | ︙ | |||
325 326 327 328 329 330 331 | TclFile file; /* The file to close. */ { int fd = GetFd(file); /* * Refuse to close the fds for stdin, stdout and stderr. */ | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | > | < | > | | | | | | | | | | | | | | | | | 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 | TclFile file; /* The file to close. */ { int fd = GetFd(file); /* * Refuse to close the fds for stdin, stdout and stderr. */ if ((fd == 0) || (fd == 1) || (fd == 2)) { return 0; } Tcl_DeleteFileHandler(fd); return close(fd); } /* *--------------------------------------------------------------------------- * * TclpCreateProcess -- * * Create a child process that has the specified files as its standard * input, output, and error. The child process runs asynchronously and * runs with the same environment variables as the creating process. * * The path is searched to find the specified executable. * * Results: * The return value is TCL_ERROR and an error message is left in the * interp's result if there was a problem creating the child process. * Otherwise, the return value is TCL_OK and *pidPtr is filled with the * process id of the child process. * * Side effects: * A process is created. * *--------------------------------------------------------------------------- */ /* ARGSUSED */ int TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) Tcl_Interp *interp; /* Interpreter in which to leave errors that * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ int argc; /* Number of arguments in following array. */ CONST char **argv; /* Array of argument strings in UTF-8. * argv[0] contains the name of the executable * translated using Tcl_TranslateFileName * call). Additional arguments have not been * converted. */ TclFile inputFile; /* If non-NULL, gives the file to use as input * for the child process. If inputFile file is * not readable or is NULL, the child will * receive no standard input. */ TclFile outputFile; /* If non-NULL, gives the file that receives * output from the child process. If * outputFile file is not writeable or is * NULL, output from the child will be * discarded. */ TclFile errorFile; /* If non-NULL, gives the file that receives * errors from the child process. If errorFile * file is not writeable or is NULL, errors * from the child will be discarded. errorFile * may be the same as outputFile. */ Tcl_Pid *pidPtr; /* If this procedure is successful, pidPtr is * filled with the process id of the child * process. */ { TclFile errPipeIn, errPipeOut; int joinThisError, count, status, fd; char errSpace[200 + TCL_INTEGER_SPACE]; Tcl_DString *dsArray; char **newArgv; int pid, i; errPipeIn = NULL; errPipeOut = NULL; pid = -1; /* * Create a pipe that the child can use to return error information if * anything goes wrong. */ if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) { Tcl_AppendResult(interp, "couldn't create pipe: ", Tcl_PosixError(interp), (char *) NULL); goto error; } /* * We need to allocate and convert this before the fork so it is properly * deallocated later */ dsArray = (Tcl_DString *) ckalloc(argc * sizeof(Tcl_DString)); newArgv = (char **) ckalloc((argc+1) * sizeof(char *)); newArgv[argc] = NULL; for (i = 0; i < argc; i++) { newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]); } joinThisError = errorFile && (errorFile == outputFile); pid = fork(); if (pid == 0) { fd = GetFd(errPipeOut); /* * Set up stdio file handles for the child process. */ if (!SetupStdFile(inputFile, TCL_STDIN) || !SetupStdFile(outputFile, TCL_STDOUT) || (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR)) || (joinThisError && ((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) { sprintf(errSpace, "%dforked process couldn't set up input/output: ", errno); write(fd, errSpace, (size_t) strlen(errSpace)); _exit(1); } /* * Close the input side of the error pipe. */ RestoreSignals(); execvp(newArgv[0], newArgv); /* INTL: Native. */ sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, argv[0]); write(fd, errSpace, (size_t) strlen(errSpace)); _exit(1); } /* * Free the mem we used for the fork */ for (i = 0; i < argc; i++) { Tcl_DStringFree(&dsArray[i]); } ckfree((char *) dsArray); ckfree((char *) newArgv); if (pid == -1) { Tcl_AppendResult(interp, "couldn't fork child process: ", Tcl_PosixError(interp), (char *) NULL); goto error; } /* * Read back from the error pipe to see if the child started up OK. The * info in the pipe (if any) consists of a decimal errno value followed by * an error message. */ TclpCloseFile(errPipeOut); errPipeOut = NULL; fd = GetFd(errPipeIn); count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1)); if (count > 0) { char *end; errSpace[count] = 0; errno = strtol(errSpace, &end, 10); Tcl_AppendResult(interp, end, Tcl_PosixError(interp), (char *) NULL); goto error; } TclpCloseFile(errPipeIn); *pidPtr = (Tcl_Pid) pid; return TCL_OK; error: if (pid != -1) { /* * Reap the child process now if an error occurred during its startup. * We don't call this with WNOHANG because that can lead to defunct * processes on an MP system. We shouldn't have to worry about hanging * here, since this is the error case. [Bug: 6148] */ Tcl_WaitPid((Tcl_Pid) pid, &status, 0); } if (errPipeIn) { TclpCloseFile(errPipeIn); } if (errPipeOut) { TclpCloseFile(errPipeOut); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * RestoreSignals -- * * This procedure is invoked in a forked child process just before * exec-ing a new program to restore all signals to their default * settings. * * Results: * None. * * Side effects: * Signal settings get changed. * *---------------------------------------------------------------------- */ static void RestoreSignals() { #ifdef SIGABRT signal(SIGABRT, SIG_DFL); #endif #ifdef SIGALRM |
︙ | ︙ | |||
594 595 596 597 598 599 600 | } /* *---------------------------------------------------------------------- * * SetupStdFile -- * | | | | | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 | } /* *---------------------------------------------------------------------- * * SetupStdFile -- * * Set up stdio file handles for the child process, using the current * standard channels if no other files are specified. If no standard * channel is defined, or if no file is associated with the channel, then * the corresponding standard fd is closed. * * Results: * Returns 1 on success, or 0 on failure. * * Side effects: * Replaces stdio fds. * |
︙ | ︙ | |||
620 621 622 623 624 625 626 | Tcl_Channel channel; int fd; int targetFd = 0; /* Initializations here needed only to */ int direction = 0; /* prevent warnings about using uninitialized * variables. */ switch (type) { | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | Tcl_Channel channel; int fd; int targetFd = 0; /* Initializations here needed only to */ int direction = 0; /* prevent warnings about using uninitialized * variables. */ switch (type) { case TCL_STDIN: targetFd = 0; direction = TCL_READABLE; break; case TCL_STDOUT: targetFd = 1; direction = TCL_WRITABLE; break; case TCL_STDERR: targetFd = 2; direction = TCL_WRITABLE; break; } if (!file) { channel = Tcl_GetStdChannel(type); if (channel) { file = TclpMakeFile(channel, direction); } } if (file) { fd = GetFd(file); if (fd != targetFd) { if (dup2(fd, targetFd) == -1) { return 0; } /* * Must clear the close-on-exec flag for the target FD, since some * systems (e.g. Ultrix) do not clear the CLOEXEC flag on the * target FD. */ fcntl(targetFd, F_SETFD, 0); } else { /* * Since we aren't dup'ing the file, we need to explicitly clear * the close-on-exec flag. */ fcntl(fd, F_SETFD, 0); } } else { close(targetFd); } return 1; } /* *---------------------------------------------------------------------- * * TclpCreateCommandChannel -- * * This function is called by the generic IO level to perform the * platform specific channel initialization for a command channel. * * Results: * Returns a new channel or NULL on failure. * * Side effects: * Allocates a new channel. * *---------------------------------------------------------------------- */ Tcl_Channel TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) TclFile readFile; /* If non-null, gives the file for reading. */ TclFile writeFile; /* If non-null, gives the file for writing. */ TclFile errorFile; /* If non-null, gives the file where errors * can be read. */ int numPids; /* The number of pids in the pid array. */ Tcl_Pid *pidPtr; /* An array of process identifiers. Allocated * by the caller, freed when the channel is * closed or the processes are detached (in a * background exec). */ { char channelName[16 + TCL_INTEGER_SPACE]; int channelId; PipeState *statePtr = (PipeState *) ckalloc((unsigned) sizeof(PipeState)); int mode; statePtr->inFile = readFile; statePtr->outFile = writeFile; statePtr->errorFile = errorFile; statePtr->numPids = numPids; statePtr->pidPtr = pidPtr; statePtr->isNonBlocking = 0; mode = 0; if (readFile) { mode |= TCL_READABLE; } if (writeFile) { mode |= TCL_WRITABLE; } /* * Use one of the fds associated with the channel as the channel id. */ if (readFile) { channelId = GetFd(readFile); } else if (writeFile) { channelId = GetFd(writeFile); } else if (errorFile) { channelId = GetFd(errorFile); } else { channelId = 0; } /* * For backward compatibility with previous versions of Tcl, we use * "file%d" as the base name for pipes even though it would be more * natural to use "pipe%d". */ sprintf(channelName, "file%d", channelId); statePtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, (ClientData) statePtr, mode); return statePtr->channel; } /* *---------------------------------------------------------------------- * * TclGetAndDetachPids -- * * This procedure is invoked in the generic implementation of a * background "exec" (an exec when invoked with a terminating "&") to * store a list of the PIDs for processes in a command pipeline in the * interp's result and to detach the processes. * * Results: * None. * * Side effects: * Modifies the interp's result. Detaches processes. * *---------------------------------------------------------------------- */ void TclGetAndDetachPids(interp, chan) Tcl_Interp *interp; /* Interpreter to append the PIDs to. */ Tcl_Channel chan; /* Handle for the pipeline. */ { PipeState *pipePtr; Tcl_ChannelType *chanTypePtr; int i; char buf[TCL_INTEGER_SPACE]; /* * Punt if the channel is not a command channel. */ chanTypePtr = Tcl_GetChannelType(chan); if (chanTypePtr != &pipeChannelType) { return; } pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); for (i = 0; i < pipePtr->numPids; i++) { TclFormatInt(buf, (long) TclpGetPid(pipePtr->pidPtr[i])); Tcl_AppendElement(interp, buf); Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); } if (pipePtr->numPids > 0) { ckfree((char *) pipePtr->pidPtr); pipePtr->numPids = 0; } } /* *---------------------------------------------------------------------- * * PipeBlockModeProc -- * * Helper procedure to set blocking and nonblocking modes on a pipe based * channel. Invoked by generic IO level code. * * Results: * 0 if successful, errno when failed. * * Side effects: * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int PipeBlockModeProc(instanceData, mode) ClientData instanceData; /* Pipe state. */ int mode; /* The mode to set. Can be one of * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { PipeState *psPtr = (PipeState *) instanceData; int curStatus; int fd; #ifndef USE_FIONBIO if (psPtr->inFile) { fd = GetFd(psPtr->inFile); curStatus = fcntl(fd, F_GETFL); if (mode == TCL_MODE_BLOCKING) { curStatus &= (~(O_NONBLOCK)); } else { curStatus |= O_NONBLOCK; } if (fcntl(fd, F_SETFL, curStatus) < 0) { return errno; } } if (psPtr->outFile) { fd = GetFd(psPtr->outFile); curStatus = fcntl(fd, F_GETFL); if (mode == TCL_MODE_BLOCKING) { curStatus &= (~(O_NONBLOCK)); } else { curStatus |= O_NONBLOCK; } if (fcntl(fd, F_SETFL, curStatus) < 0) { return errno; } } #endif /* !FIONBIO */ #ifdef USE_FIONBIO if (psPtr->inFile) { fd = GetFd(psPtr->inFile); if (mode == TCL_MODE_BLOCKING) { curStatus = 0; } else { curStatus = 1; } if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { return errno; } } if (psPtr->outFile != NULL) { fd = GetFd(psPtr->outFile); if (mode == TCL_MODE_BLOCKING) { curStatus = 0; } else { curStatus = 1; } if (ioctl(fd, (int) FIONBIO, &curStatus) < 0) { return errno; } } #endif /* USE_FIONBIO */ psPtr->isNonBlocking = (mode == TCL_MODE_NONBLOCKING); return 0; } /* *---------------------------------------------------------------------- * * PipeCloseProc -- * * This procedure is invoked by the generic IO level to perform * channel-type-specific cleanup when a command pipeline channel is * closed. * * Results: * 0 on success, errno otherwise. * * Side effects: * Closes the command pipeline channel. * |
︙ | ︙ | |||
924 925 926 927 928 929 930 | if (pipePtr->outFile) { if ((TclpCloseFile(pipePtr->outFile) < 0) && (errorCode == 0)) { errorCode = errno; } } if (pipePtr->isNonBlocking || TclInExit()) { | < | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | < | | | | | | < | | | | | | | 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 | if (pipePtr->outFile) { if ((TclpCloseFile(pipePtr->outFile) < 0) && (errorCode == 0)) { errorCode = errno; } } if (pipePtr->isNonBlocking || TclInExit()) { /* * If the channel is non-blocking or Tcl is being cleaned up, just * detach the children PIDs, reap them (important if we are in a * dynamic load module), and discard the errorFile. */ Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); Tcl_ReapDetachedProcs(); if (pipePtr->errorFile) { TclpCloseFile(pipePtr->errorFile); } } else { /* * Wrap the error file into a channel and give it to the cleanup * routine. */ if (pipePtr->errorFile) { errChan = Tcl_MakeFileChannel( (ClientData) GetFd(pipePtr->errorFile), TCL_READABLE); } else { errChan = NULL; } result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, errChan); } if (pipePtr->numPids != 0) { ckfree((char *) pipePtr->pidPtr); } ckfree((char *) pipePtr); if (errorCode == 0) { return result; } return errorCode; } /* *---------------------------------------------------------------------- * * PipeInputProc -- * * This procedure is invoked from the generic IO level to read input from * a command pipeline based channel. * * Results: * The number of bytes read is returned or -1 on error. An output * argument contains a POSIX error code if an error occurs, or zero. * * Side effects: * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int PipeInputProc(instanceData, buf, toRead, errorCodePtr) ClientData instanceData; /* Pipe state. */ char *buf; /* Where to store data read. */ int toRead; /* How much space is available in the * buffer? */ int *errorCodePtr; /* Where to store error code. */ { PipeState *psPtr = (PipeState *) instanceData; int bytesRead; /* How many bytes were actually read from the * input device? */ *errorCodePtr = 0; /* * Assume there is always enough input available. This will block * appropriately, and read will unblock as soon as a short read is * possible, if the channel is in blocking mode. If the channel is * nonblocking, the read will never block. Some OSes can throw an * interrupt error, for which we should immediately retry. [Bug #415131] */ do { bytesRead = read(GetFd(psPtr->inFile), buf, (size_t) toRead); } while ((bytesRead < 0) && (errno == EINTR)); if (bytesRead < 0) { *errorCodePtr = errno; return -1; } else { return bytesRead; } } /* *---------------------------------------------------------------------- * * PipeOutputProc-- * * This procedure is invoked from the generic IO level to write output to * a command pipeline based channel. * * Results: * The number of bytes written is returned or -1 on error. An output * argument contains a POSIX error code if an error occurred, or zero. * * Side effects: * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int PipeOutputProc(instanceData, buf, toWrite, errorCodePtr) ClientData instanceData; /* Pipe state. */ CONST char *buf; /* The data buffer. */ int toWrite; /* How many bytes to write? */ int *errorCodePtr; /* Where to store error code. */ { PipeState *psPtr = (PipeState *) instanceData; int written; *errorCodePtr = 0; /* * Some OSes can throw an interrupt error, for which we should immediately * retry. [Bug #415131] */ do { written = write(GetFd(psPtr->outFile), buf, (size_t) toWrite); } while ((written < 0) && (errno == EINTR)); if (written < 0) { |
︙ | ︙ | |||
1076 1077 1078 1079 1080 1081 1082 | * * Initialize the notifier to watch the fds from this channel. * * Results: * None. * * Side effects: | | | | | | | | 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 | * * Initialize the notifier to watch the fds from this channel. * * Results: * None. * * Side effects: * Sets up the notifier so that a future event on the channel will be * seen by Tcl. * *---------------------------------------------------------------------- */ static void PipeWatchProc(instanceData, mask) ClientData instanceData; /* The pipe state. */ int mask; /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { PipeState *psPtr = (PipeState *) instanceData; int newmask; if (psPtr->inFile) { newmask = mask & (TCL_READABLE | TCL_EXCEPTION); if (newmask) { |
︙ | ︙ | |||
1119 1120 1121 1122 1123 1124 1125 | } /* *---------------------------------------------------------------------- * * PipeGetHandleProc -- * | | | | | | 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 | } /* *---------------------------------------------------------------------- * * PipeGetHandleProc -- * * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a * command pipeline based channel. * * Results: * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1190 1191 1192 1193 1194 1195 1196 | } /* *---------------------------------------------------------------------- * * Tcl_PidObjCmd -- * | | | < < < < < < > > > > > > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } /* *---------------------------------------------------------------------- * * Tcl_PidObjCmd -- * * This procedure is invoked to process the "pid" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_PidObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST *objv; /* Argument strings. */ { if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); return TCL_ERROR; } if (objc == 1) { Tcl_SetObjResult(interp, Tcl_NewLongObj((long) getpid())); } else { Tcl_Channel chan; Tcl_ChannelType *chanTypePtr; PipeState *pipePtr; int i; Tcl_Obj *resultPtr, *longObjPtr; chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } chanTypePtr = Tcl_GetChannelType(chan); if (chanTypePtr != &pipeChannelType) { return TCL_OK; } pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); resultPtr = Tcl_NewObj(); for (i = 0; i < pipePtr->numPids; i++) { longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i])); Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr); } Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclpFinalizePipes -- * * Cleans up the pipe subsystem from Tcl_FinalizeThread * * Results: * None. * * Notes: * This procedure carries out no operation on Unix. * *---------------------------------------------------------------------- */ void TclpFinalizePipes() { } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
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.39.2.2 2005/05/21 15:10:35 kennykb Exp $ */ #ifndef _TCLUNIXPORT #define _TCLUNIXPORT /* *--------------------------------------------------------------------------- |
︙ | ︙ | |||
52 53 54 55 56 57 58 | # include <dirent.h> #endif #endif #ifdef HAVE_STRUCT_DIRENT64 typedef struct dirent64 Tcl_DirEntry; # define TclOSreaddir readdir64 | < < | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | # include <dirent.h> #endif #endif #ifdef HAVE_STRUCT_DIRENT64 typedef struct dirent64 Tcl_DirEntry; # define TclOSreaddir readdir64 #else typedef struct dirent Tcl_DirEntry; # define TclOSreaddir readdir #endif #ifdef HAVE_TYPE_OFF64_T typedef off64_t Tcl_SeekOffset; # define TclOSseek lseek64 # define TclOSopen open64 #else |
︙ | ︙ | |||
554 555 556 557 558 559 560 | #ifdef TCL_THREADS # include <pthread.h> typedef pthread_mutex_t TclpMutex; EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr)); | < < < < < < < < < < < | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 | #ifdef TCL_THREADS # include <pthread.h> typedef pthread_mutex_t TclpMutex; EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN struct tm * TclpLocaltime(CONST time_t *); EXTERN struct tm * TclpGmtime(CONST time_t *); EXTERN char * TclpInetNtoa(struct in_addr); /* #define localtime(x) TclpLocaltime(x) * #define gmtime(x) TclpGmtime(x) */ # undef inet_ntoa # define inet_ntoa(x) TclpInetNtoa(x) # ifdef HAVE_PTHREAD_ATTR_GET_NP # define TclpPthreadGetAttrs pthread_attr_get_np # ifdef ATTRGETNP_NOT_DECLARED /* * Assume it is in pthread_np.h if it isn't in pthread.h. [Bug 1064882] * We might need to revisit this in the future. :^( */ |
︙ | ︙ |
Changes to unix/tclUnixSock.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclUnixSock.c -- * * This file contains Unix-specific socket related code. * * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | < < < < < < < < < < < < < < < < < < < < < | | < > | > | < < < < < > > > > > > | < | < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 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 | /* * tclUnixSock.c -- * * This file contains Unix-specific socket related code. * * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclUnixSock.c,v 1.9.2.3 2005/09/09 18:48:40 dgp Exp $ */ #include "tclInt.h" /* * The following variable holds the network name of this host. */ static TclInitProcessGlobalValueProc InitializeHostName; static ProcessGlobalValue hostName = {0, 0, NULL, NULL, InitializeHostName, NULL, NULL}; /* *---------------------------------------------------------------------- * * InitializeHostName -- * * This routine sets the process global value of the name of * the local host on which the process is running. * * Results: * None. * *---------------------------------------------------------------------- */ static void InitializeHostName(valuePtr, lengthPtr, encodingPtr) char **valuePtr; int *lengthPtr; Tcl_Encoding *encodingPtr; { CONST char *native = NULL; #ifndef NO_UNAME struct utsname u; struct hostent *hp; (VOID *) memset((VOID *) &u, (int) 0, sizeof(struct utsname)); if (uname(&u) > -1) { /* INTL: Native. */ hp = gethostbyname(u.nodename); /* INTL: Native. */ if (hp == NULL) { /* * Sometimes the nodename is fully qualified, but gets truncated * as it exceeds SYS_NMLN. See if we can just get the immediate |
︙ | ︙ | |||
100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | } if (hp != NULL) { native = hp->h_name; } else { native = u.nodename; } } #else /* * Uname doesn't exist; try gethostname instead. */ if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */ native = buffer; } #endif | > > > > > > > > > > > > > > > > > > > > > | < | | < | | > > > > > > > > > > > > > > > > > | > | > > | 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 | } if (hp != NULL) { native = hp->h_name; } else { native = u.nodename; } } if (native == NULL) { native = tclEmptyStringRep; } #else /* * Uname doesn't exist; try gethostname instead. * * There is no portable macro for the maximum length * of host names returned by gethostbyname(). We should only * trust SYS_NMLN if it is at least 255 + 1 bytes to comply with DNS * host name limits. * * Note: SYS_NMLN is a restriction on "uname" not on gethostbyname! * * For example HP-UX 10.20 has SYS_NMLN == 9, while gethostbyname() * can return a fully qualified name from DNS of up to 255 bytes. * * Fix suggested by Viktor Dukhovni ([email protected]) */ # if defined(SYS_NMLN) && SYS_NMLEN >= 256 char buffer[SYS_NMLEN]; # else char buffer[256]; # endif if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */ native = buffer; } #endif *encodingPtr = Tcl_GetEncoding(NULL, NULL); *lengthPtr = strlen(native); *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1); memcpy((VOID *) *valuePtr, (VOID *) native, (size_t)(*lengthPtr)+1); } /* *---------------------------------------------------------------------- * * Tcl_GetHostName -- * * Returns the name of the local host. * * Results: * A string containing the network name for this machine, or * an empty string if we can't figure out the name. The caller * must not modify or free this string. * * Side effects: * Caches the name to return for future calls. * *---------------------------------------------------------------------- */ CONST char * Tcl_GetHostName() { return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); } /* *---------------------------------------------------------------------- * * TclpHasSockets -- * |
︙ | ︙ | |||
142 143 144 145 146 147 148 149 | */ int TclpHasSockets(interp) Tcl_Interp *interp; /* Not used. */ { return TCL_OK; } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 148 149 150 151 152 153 154 155 | */ int TclpHasSockets(interp) Tcl_Interp *interp; /* Not used. */ { return TCL_OK; } |
Changes to unix/tclUnixThrd.c.
1 2 3 4 5 6 7 8 | /* * tclUnixThrd.c -- * * This file implements the UNIX-specific thread support. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * | | | | < < < < | < | | | | | | | | | | | | | | | | | | | | 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 | /* * tclUnixThrd.c -- * * This file implements the UNIX-specific thread support. * * 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. * * SCCS: @(#) tclUnixThrd.c 1.18 98/02/19 14:24:12 */ #include "tclInt.h" #ifdef TCL_THREADS #include "pthread.h" typedef struct ThreadSpecificData { char nabuf[16]; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * masterLock is used to serialize creation of mutexes, condition variables, * and thread local storage. This is the only place that can count on the * ability to statically initialize the mutex. */ static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER; /* * initLock is used to serialize initialization and finalization of Tcl. It * cannot use any dyamically allocated storage. */ static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER; /* * allocLock is used by Tcl's version of malloc for synchronization. For * obvious reasons, cannot use any dyamically allocated storage. */ static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER; static pthread_mutex_t *allocLockPtr = &allocLock; /* * These are for the critical sections inside this file. */ #define MASTER_LOCK pthread_mutex_lock(&masterLock) #define MASTER_UNLOCK pthread_mutex_unlock(&masterLock) #endif /* TCL_THREADS */ /* *---------------------------------------------------------------------- * * TclpThreadCreate -- * * This procedure creates a new thread. * * Results: * TCL_OK if the thread could be created. The thread ID is returned in a * parameter. * * Side effects: * A new thread is created. * *---------------------------------------------------------------------- */ int TclpThreadCreate(idPtr, proc, clientData, stackSize, flags) Tcl_ThreadId *idPtr; /* Return, the ID of the thread */ Tcl_ThreadCreateProc proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ int stackSize; /* Size of stack for the new thread */ int flags; /* Flags controlling behaviour of the * new thread. */ { #ifdef TCL_THREADS pthread_attr_t attr; pthread_t theThread; int result; pthread_attr_init(&attr); pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); #ifdef HAVE_PTHREAD_ATTR_SETSTACKSIZE if (stackSize != TCL_THREAD_STACK_DEFAULT) { pthread_attr_setstacksize(&attr, (size_t) stackSize); #ifdef TCL_THREAD_STACK_MIN } else { /* * Certain systems define a thread stack size that by default is too * small for many operations. The user has the option of defining * TCL_THREAD_STACK_MIN to a value large enough to work for their * needs. This would look like (for 128K min stack): * make MEM_DEBUG_FLAGS=-DTCL_THREAD_STACK_MIN=131072L * * This solution is not optimal, as we should allow the user to * specify a size at runtime, but we don't want to slow this function * down, and that would still leave the main thread at the default. */ size_t size; result = pthread_attr_getstacksize(&attr, &size); if (!result && (size < TCL_THREAD_STACK_MIN)) { pthread_attr_setstacksize(&attr, (size_t) TCL_THREAD_STACK_MIN); } #endif } #endif if (! (flags & TCL_THREAD_JOINABLE)) { pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED); } if (pthread_create(&theThread, &attr, (void * (*)(void *))proc, (void *)clientData) && pthread_create(&theThread, NULL, (void * (*)(void *))proc, (void *)clientData)) { |
︙ | ︙ | |||
149 150 151 152 153 154 155 | * * This procedure waits upon the exit of the specified thread. * * Results: * TCL_OK if the wait was successful, TCL_ERROR else. * * Side effects: | | < | | | | | 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 | * * This procedure waits upon the exit of the specified thread. * * Results: * TCL_OK if the wait was successful, TCL_ERROR else. * * Side effects: * The result area is set to the exit code of the thread we waited upon. * *---------------------------------------------------------------------- */ int Tcl_JoinThread(threadId, state) Tcl_ThreadId threadId; /* Id of the thread to wait upon. */ int *state; /* Reference to the storage the result of the * thread we wait upon will be written * into. */ { #ifdef TCL_THREADS int result; result = pthread_join ((pthread_t) threadId, (VOID**) state); return (result == 0) ? TCL_OK : TCL_ERROR; #else |
︙ | ︙ | |||
237 238 239 240 241 242 243 | pthread_attr_destroy(&threadAttr); return -1; } pthread_attr_destroy(&threadAttr); return (int) stackSize; #else /* | | | < > | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 | pthread_attr_destroy(&threadAttr); return -1; } pthread_attr_destroy(&threadAttr); return (int) stackSize; #else /* * Cannot determine the real stack size of this thread. The caller might * want to try looking at the process accounting limits instead. */ return 0; #endif } #endif /* TCL_THREADS */ /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
279 280 281 282 283 284 285 | /* *---------------------------------------------------------------------- * * TclpInitLock * * This procedure is used to grab a lock that serializes initialization | | | | | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 | /* *---------------------------------------------------------------------- * * TclpInitLock * * This procedure is used to grab a lock that serializes initialization * and finalization of Tcl. On some platforms this may also initialize * the mutex used to serialize creation of more mutexes and thread local * storage keys. * * Results: * None. * * Side effects: * Acquire the initialization mutex. * |
︙ | ︙ | |||
305 306 307 308 309 310 311 | } /* *---------------------------------------------------------------------- * * TclpFinalizeLock * | | | | | | | > | | | 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 | } /* *---------------------------------------------------------------------- * * TclpFinalizeLock * * This procedure is used to destroy all private resources used in this * file. * * Results: * None. * * Side effects: * Destroys everything private. TclpInitLock must be held entering this * function. * *---------------------------------------------------------------------- */ void TclFinalizeLock () { #ifdef TCL_THREADS /* * You do not need to destroy mutexes that were created with the * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any * destruction: masterLock, allocLock, and initLock. */ pthread_mutex_unlock(&initLock); #endif } /* *---------------------------------------------------------------------- * * TclpInitUnlock * * This procedure is used to release a lock that serializes * initialization and finalization of Tcl. * * Results: * None. * * Side effects: * Release the initialization mutex. * |
︙ | ︙ | |||
361 362 363 364 365 366 367 | } /* *---------------------------------------------------------------------- * * TclpMasterLock * | | | | < | | | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 | } /* *---------------------------------------------------------------------- * * TclpMasterLock * * This procedure is used to grab a lock that serializes creation and * finalization of serialization objects. This interface is only needed * in finalization; it is hidden during creation of the objects. * * This lock must be different than the initLock because the initLock is * held during creation of syncronization objects. * * Results: * None. * * Side effects: * Acquire the master mutex. * |
︙ | ︙ | |||
392 393 394 395 396 397 398 | /* *---------------------------------------------------------------------- * * TclpMasterUnlock * | | | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 | /* *---------------------------------------------------------------------- * * TclpMasterUnlock * * This procedure is used to release a lock that serializes creation and * finalization of synchronization objects. * * Results: * None. * * Side effects: * Release the master mutex. * |
︙ | ︙ | |||
418 419 420 421 422 423 424 | /* *---------------------------------------------------------------------- * * Tcl_GetAllocMutex * | | | | | | | 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 | /* *---------------------------------------------------------------------- * * Tcl_GetAllocMutex * * This procedure returns a pointer to a statically initialized mutex for * use by the memory allocator. The alloctor must use this lock, because * all other locks are allocated... * * Results: * A pointer to a mutex that is suitable for passing to Tcl_MutexLock and * Tcl_MutexUnlock. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
449 450 451 452 453 454 455 | #ifdef TCL_THREADS /* *---------------------------------------------------------------------- * * Tcl_MutexLock -- * | | | | | | | | | 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 | #ifdef TCL_THREADS /* *---------------------------------------------------------------------- * * Tcl_MutexLock -- * * This procedure is invoked to lock a mutex. This procedure handles * initializing the mutex, if necessary. The caller can rely on the fact * that Tcl_Mutex is an opaque pointer. This routine will change that * pointer from NULL after first use. * * Results: * None. * * Side effects: * May block the current thread. The mutex is aquired when this returns. * Will allocate memory for a pthread_mutex_t and initialize this the * first time this Tcl_Mutex is used. * *---------------------------------------------------------------------- */ void Tcl_MutexLock(mutexPtr) Tcl_Mutex *mutexPtr; /* Really (pthread_mutex_t **) */ |
︙ | ︙ | |||
494 495 496 497 498 499 500 | /* *---------------------------------------------------------------------- * * Tcl_MutexUnlock -- * | | | | 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 | /* *---------------------------------------------------------------------- * * Tcl_MutexUnlock -- * * This procedure is invoked to unlock a mutex. The mutex must have been * locked by Tcl_MutexLock. * * Results: * None. * * Side effects: * The mutex is released when this returns. * |
︙ | ︙ | |||
520 521 522 523 524 525 526 | /* *---------------------------------------------------------------------- * * TclpFinalizeMutex -- * | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | 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 | /* *---------------------------------------------------------------------- * * TclpFinalizeMutex -- * * This procedure is invoked to clean up one mutex. This is only safe to * call at the end of time. * * This assumes the Master Lock is held. * * Results: * None. * * Side effects: * The mutex list is deallocated. * *---------------------------------------------------------------------- */ void TclpFinalizeMutex(mutexPtr) Tcl_Mutex *mutexPtr; { pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **)mutexPtr; if (pmutexPtr != NULL) { pthread_mutex_destroy(pmutexPtr); ckfree((char *)pmutexPtr); *mutexPtr = NULL; } } /* *---------------------------------------------------------------------- * * Tcl_ConditionWait -- * * This procedure is invoked to wait on a condition variable. The mutex * is automically released as part of the wait, and automatically grabbed * when the condition is signaled. * * The mutex must be held when this procedure is called. * * Results: * None. * * Side effects: * May block the current thread. The mutex is aquired when this returns. * Will allocate memory for a pthread_mutex_t and initialize this the * first time this Tcl_Mutex is used. * *---------------------------------------------------------------------- */ void Tcl_ConditionWait(condPtr, mutexPtr, timePtr) Tcl_Condition *condPtr; /* Really (pthread_cond_t **) */ Tcl_Mutex *mutexPtr; /* Really (pthread_mutex_t **) */ Tcl_Time *timePtr; /* Timeout on waiting period */ { pthread_cond_t *pcondPtr; pthread_mutex_t *pmutexPtr; struct timespec ptime; if (*condPtr == NULL) { MASTER_LOCK; /* * Double check inside mutex to avoid race, then initialize condition * variable if necessary. */ if (*condPtr == NULL) { pcondPtr = (pthread_cond_t *)ckalloc(sizeof(pthread_cond_t)); pthread_cond_init(pcondPtr, NULL); *condPtr = (Tcl_Condition)pcondPtr; TclRememberCondition(condPtr); |
︙ | ︙ | |||
790 791 792 793 794 795 796 | /* *---------------------------------------------------------------------- * * Tcl_ConditionNotify -- * * This procedure is invoked to signal a condition variable. * | | | | 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 | /* *---------------------------------------------------------------------- * * Tcl_ConditionNotify -- * * This procedure is invoked to signal a condition variable. * * The mutex must be held during this call to avoid races, but this * interface does not enforce that. * * Results: * None. * * Side effects: * May unblock another thread. * |
︙ | ︙ | |||
822 823 824 825 826 827 828 | /* *---------------------------------------------------------------------- * * TclpFinalizeCondition -- * | | | | 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 | /* *---------------------------------------------------------------------- * * TclpFinalizeCondition -- * * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * * This assumes the Master Lock is held. * * Results: * None. * * Side effects: |
︙ | ︙ | |||
854 855 856 857 858 859 860 | #endif /* TCL_THREADS */ /* *---------------------------------------------------------------------- * * TclpReaddir, TclpLocaltime, TclpGmtime, TclpInetNtoa -- * | | | > > > > < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < | < < < < < < < < < < < | | | > | | 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 | #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. * * Notes: * TclpReaddir is no longer used by the core (see 1095909), but it * appears in the internal stubs table (see #589526). * *---------------------------------------------------------------------- */ Tcl_DirEntry * TclpReaddir(DIR * dir) { return TclOSreaddir(dir); } char * TclpInetNtoa(struct in_addr addr) { #ifdef TCL_THREADS ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 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 volatile int initialized = 0; static pthread_key_t key; typedef struct allocMutex { Tcl_Mutex tlock; pthread_mutex_t plock; } allocMutex; Tcl_Mutex * TclpNewAllocMutex(void) { struct allocMutex *lockPtr; |
︙ | ︙ | |||
963 964 965 966 967 968 969 | } void TclpFreeAllocMutex(mutex) Tcl_Mutex *mutex; /* The alloc mutex to free. */ { allocMutex* lockPtr = (allocMutex*) mutex; | | > > | > > > | > > | | > | | | | | 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 | } void TclpFreeAllocMutex(mutex) Tcl_Mutex *mutex; /* The alloc mutex to free. */ { allocMutex* lockPtr = (allocMutex*) mutex; if (!lockPtr) { return; } pthread_mutex_destroy(&lockPtr->plock); free(lockPtr); } void TclpFreeAllocCache(ptr) void *ptr; { if (ptr != NULL) { /* * Called by the pthread lib when a thread exits */ TclFreeAllocCache(ptr); } else if (initialized) { /* * Called by us in TclFinalizeThreadAlloc() during the library * finalization initiated from Tcl_Finalize() */ pthread_key_delete(key); initialized = 0; } } void * TclpGetAllocCache(void) { if (!initialized) { |
︙ | ︙ | |||
1002 1003 1004 1005 1006 1007 1008 | } void TclpSetAllocCache(void *arg) { pthread_setspecific(key, arg); } | < > > > > > > > > | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 | } void TclpSetAllocCache(void *arg) { pthread_setspecific(key, arg); } #endif /* USE_THREAD_ALLOC */ #endif /* TCL_THREADS */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclUnixTime.c.
|
| | | | | | | | | | | | | | | | < > | > | | > > > > > > > > > > > > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | /* * 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.22.2.2 2005/08/02 18:16:58 dgp Exp $ */ #include "tclInt.h" #include <locale.h> #define TM_YEAR_BASE 1900 #define IsLeapYear(x) (((x)%4 == 0) && ((x)%100 != 0 || (x)%400 == 0)) /* * TclpGetDate is coded to return a pointer to a 'struct tm'. For thread * safety, this structure must be in thread-specific data. The 'tmKey' * variable is the key to this buffer. */ static Tcl_ThreadDataKey tmKey; typedef struct ThreadSpecificData { struct tm gmtime_buf; struct tm localtime_buf; } ThreadSpecificData; /* * If we fall back on the thread-unsafe versions of gmtime and localtime, use * this mutex to try to protect them. */ TCL_DECLARE_MUTEX(tmMutex) static char *lastTZ = NULL; /* Holds the last setting of the TZ * environment variable, or an empty string if * the variable was not set. */ /* * Static functions declared in this file. */ static void SetTZIfNecessary _ANSI_ARGS_((void)); static void CleanupMemory _ANSI_ARGS_((ClientData)); static void NativeScaleTime _ANSI_ARGS_((Tcl_Time *timebuf, ClientData clientData)); static void NativeGetTime _ANSI_ARGS_((Tcl_Time *timebuf, ClientData clientData)); /* * TIP #233 (Virtualized Time): Data for the time hooks, if any. */ Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime; Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime; ClientData tclTimeClientData = NULL; /* *----------------------------------------------------------------------------- * * TclpGetSeconds -- * * This procedure returns the number of seconds from the epoch. On most * Unix systems the epoch is Midnight Jan 1, 1970 GMT. * * Results: * Number of seconds from the epoch. * * Side effects: * None. * |
︙ | ︙ | |||
71 72 73 74 75 76 77 | /* *----------------------------------------------------------------------------- * * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution | | | > > > | > > | > > > | < < < | > > | > | | | < | | | | > > | | | < | | | | | | | > | | < | < < < | | | > | < | < < < | | < < | > | | < < | | < > | | > > | > > | | > > > | | < > | | > > > < < | < < < | | | | 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 | /* *----------------------------------------------------------------------------- * * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution * clock available on the system. There are no garantees on what the * resolution will be. In Tcl we will call this value a "click". The * start time is also system dependant. * * Results: * Number of clicks from some start time. * * Side effects: * None. * *----------------------------------------------------------------------------- */ unsigned long TclpGetClicks() { unsigned long now; #ifdef NO_GETTOD if (tclGetTimeProcPtr != NativeGetTime) { Tcl_Time time; (*tclGetTimeProcPtr) (&time, tclTimeClientData); now = time.sec*1000000 + time.usec; } else { /* * A semi-NativeGetTime, specialized to clicks. */ struct tms dummy; now = (unsigned long) times(&dummy); } #else Tcl_Time time; (*tclGetTimeProcPtr) (&time, tclTimeClientData); now = time.sec*1000000 + time.usec; #endif return now; } /* *---------------------------------------------------------------------- * * TclpGetTimeZone -- * * Determines the current timezone. The method varies wildly between * different platform implementations, so its hidden in this function. * * Results: * The return value is the local time zone, measured in minutes away from * GMT (-ve for east, +ve for west). * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclpGetTimeZone(currentTime) unsigned long currentTime; { int timeZone; /* * We prefer first to use the time zone in "struct tm" if the structure * contains such a member. Following that, we try to locate the external * 'timezone' variable and use its value. If both of those methods fail, * we attempt to convert a known time to local time and use the difference * from UTC as the local time zone. In all cases, we need to undo any * Daylight Saving Time adjustment. */ #if defined(HAVE_TM_TZADJ) #define TCL_GOT_TIMEZONE /* * Struct tm contains tm_tzadj - that value may be used. */ time_t curTime = (time_t) currentTime; struct tm *timeDataPtr = TclpLocaltime(&curTime); timeZone = timeDataPtr->tm_tzadj / 60; if (timeDataPtr->tm_isdst) { timeZone += 60; } #endif #if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE) #define TCL_GOT_TIMEZONE /* * Struct tm contains tm_gmtoff - that value may be used. */ time_t curTime = (time_t) currentTime; struct tm *timeDataPtr = TclpLocaltime(&curTime); timeZone = -(timeDataPtr->tm_gmtoff / 60); if (timeDataPtr->tm_isdst) { timeZone += 60; } #endif #if defined(HAVE_TIMEZONE_VAR) && !defined(TCL_GOT_TIMEZONE) && !defined(USE_DELTA_FOR_TZ) #define TCL_GOT_TIMEZONE /* * The 'timezone' external var is present and may be used. */ SetTZIfNecessary(); /* * Note: this is not a typo in "timezone" below! See tzset documentation * for details. */ timeZone = timezone / 60; #endif #if !defined(TCL_GOT_TIMEZONE) #define TCL_GOT_TIMEZONE /* * Fallback - determine time zone with a known reference time. */ time_t tt; struct tm *stm; tt = 849268800L; /* 1996-11-29 12:00:00 GMT */ stm = TclpLocaltime(&tt); /* eg 1996-11-29 6:00:00 CST6CDT */ /* * The calculation below assumes a max of +12 or -12 hours from GMT. */ timeZone = (12 - stm->tm_hour)*60 + (0 - stm->tm_min); if (stm->tm_isdst) { timeZone += 60; } /* * Now have offset for our known reference time, eg +360 for CST6CDT. */ #endif #ifndef TCL_GOT_TIMEZONE /* * Cause fatal compile error, we don't know how to get timezone. */ #error autoconf did not figure out how to determine the timezone. #endif return timeZone; } /* *---------------------------------------------------------------------- * * Tcl_GetTime -- * * Gets the current system time in seconds and microseconds since the * beginning of the epoch: 00:00 UCT, January 1, 1970. * * This function is hooked, allowing users to specify their own virtual * system time. * * Results: * Returns the current time in timePtr. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_GetTime(timePtr) Tcl_Time *timePtr; /* Location to store time information. */ { (*tclGetTimeProcPtr) (timePtr, tclTimeClientData); } /* *---------------------------------------------------------------------- * * TclpGetDate -- * * This function converts between seconds and struct tm. If useGMT is * true, then the returned date will be in Greenwich Mean Time (GMT). * Otherwise, it will be in the local time zone. * * Results: * Returns a static tm structure. * * Side effects: * None. * |
︙ | ︙ | |||
300 301 302 303 304 305 306 | * Side effects: * Invokes gmtime or gmtime_r as appropriate. * *---------------------------------------------------------------------- */ struct tm * | | | | < | > | | | < | | | > | > > | | | | 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 | * Side effects: * Invokes gmtime or gmtime_r as appropriate. * *---------------------------------------------------------------------- */ struct tm * TclpGmtime(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. */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey); #ifdef HAVE_GMTIME_R gmtime_r(timePtr, &(tsdPtr->gmtime_buf)); #else Tcl_MutexLock(&tmMutex); memcpy((VOID *) &(tsdPtr->gmtime_buf), (VOID *) gmtime(timePtr), sizeof(struct tm)); Tcl_MutexUnlock(&tmMutex); #endif return &(tsdPtr->gmtime_buf); } /* * Forwarder for obsolete item in Stubs */ struct tm* TclpGmtime_unix(timePtr) CONST time_t *timePtr; { return TclpGmtime(timePtr); } /* *---------------------------------------------------------------------- * * TclpLocaltime -- * |
︙ | ︙ | |||
350 351 352 353 354 355 356 | * Invokes localtime or localtime_r as appropriate. * *---------------------------------------------------------------------- */ struct tm * TclpLocaltime(timePtr) | | | < | > | | | < | | | > | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | > | | | | | | | | | | < | | | | > > > > > > > > | 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 | * Invokes localtime or localtime_r as appropriate. * *---------------------------------------------------------------------- */ struct tm * TclpLocaltime(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. */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey); SetTZIfNecessary(); #ifdef HAVE_LOCALTIME_R localtime_r(timePtr, &(tsdPtr->localtime_buf)); #else Tcl_MutexLock(&tmMutex); memcpy((VOID *) &(tsdPtr->localtime_buf), (VOID *) localtime(timePtr), sizeof(struct tm)); Tcl_MutexUnlock(&tmMutex); #endif return &(tsdPtr->localtime_buf); } /* * Forwarder for obsolete item in Stubs */ struct tm* TclpLocaltime_unix(timePtr) CONST time_t *timePtr; { return TclpLocaltime(timePtr); } /* *---------------------------------------------------------------------- * * Tcl_SetTimeProc -- * * TIP #233 (Virtualized Time): Registers two handlers for the * virtualization of Tcl's access to time information. * * Results: * None. * * Side effects: * Remembers the handlers, alters core behaviour. * *---------------------------------------------------------------------- */ void Tcl_SetTimeProc(getProc, scaleProc, clientData) Tcl_GetTimeProc *getProc; Tcl_ScaleTimeProc *scaleProc; ClientData clientData; { tclGetTimeProcPtr = getProc; tclScaleTimeProcPtr = scaleProc; tclTimeClientData = clientData; } /* *---------------------------------------------------------------------- * * Tcl_QueryTimeProc -- * * TIP #233 (Virtualized Time): Query which time handlers are registered. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_QueryTimeProc(getProc, scaleProc, clientData) Tcl_GetTimeProc **getProc; Tcl_ScaleTimeProc **scaleProc; ClientData *clientData; { if (getProc) { *getProc = tclGetTimeProcPtr; } if (scaleProc) { *scaleProc = tclScaleTimeProcPtr; } if (clientData) { *clientData = tclTimeClientData; } } /* *---------------------------------------------------------------------- * * NativeScaleTime -- * * TIP #233: Scale from virtual time to the real-time. For native scaling * the relationship is 1:1 and nothing has to be done. * * Results: * Scales the time in timePtr. * * Side effects: * See above. * *---------------------------------------------------------------------- */ static void NativeScaleTime(timePtr, clientData) Tcl_Time *timePtr; ClientData clientData; { /* Native scale is 1:1. Nothing is done */ } /* *---------------------------------------------------------------------- * * NativeGetTime -- * * TIP #233: Gets the current system time in seconds and microseconds * since the beginning of the epoch: 00:00 UCT, January 1, 1970. * * Results: * Returns the current time in timePtr. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void NativeGetTime(timePtr, clientData) Tcl_Time *timePtr; ClientData clientData; { struct timeval tv; struct timezone tz; (void) gettimeofday(&tv, &tz); timePtr->sec = tv.tv_sec; timePtr->usec = tv.tv_usec; } /* *---------------------------------------------------------------------- * * SetTZIfNecessary -- * * Determines whether a call to 'tzset' is needed prior to the next call * to 'localtime' or examination of the 'timezone' variable. * * Results: * None. * * Side effects: * If 'tzset' has never been called in the current process, or if the * value of the environment variable TZ has changed since the last call * to 'tzset', then 'tzset' is called again. * *---------------------------------------------------------------------- */ static void SetTZIfNecessary() { CONST char *newTZ = getenv("TZ"); Tcl_MutexLock(&tmMutex); if (newTZ == NULL) { newTZ = ""; } if (lastTZ == NULL || strcmp(lastTZ, newTZ)) { tzset(); if (lastTZ == NULL) { Tcl_CreateExitHandler(CleanupMemory, (ClientData) NULL); } else { Tcl_Free(lastTZ); } lastTZ = Tcl_Alloc(strlen(newTZ) + 1); strcpy(lastTZ, newTZ); } Tcl_MutexUnlock(&tmMutex); } /* *---------------------------------------------------------------------- * * CleanupMemory -- * * Releases the private copy of the TZ environment variable upon exit * from Tcl. * * Results: * None. * * Side effects: * Frees allocated memory. * *---------------------------------------------------------------------- */ static void CleanupMemory(ClientData ignored) { Tcl_Free(lastTZ); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to unix/tclXtNotify.c.
|
| | | | | | | | | | > | | | | | | | | | | | | | | | < | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | /* * tclXtNotify.c -- * * This file contains the notifier driver implementation for the Xt * intrinsics. * * 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: tclXtNotify.c,v 1.6.2.1 2005/08/02 18:16:58 dgp Exp $ */ #include <X11/Intrinsic.h> #include "tclInt.h" /* * This structure is used to keep track of the notifier info for a a * registered file. */ typedef struct FileHandler { int fd; int mask; /* Mask of desired events: TCL_READABLE, * etc. */ int readyMask; /* Events that have been seen since the last * time FileHandlerEventProc was called for * this file. */ XtInputId read; /* Xt read callback handle. */ XtInputId write; /* Xt write callback handle. */ XtInputId except; /* Xt exception callback handle. */ Tcl_FileProc *proc; /* Procedure to call, in the style of * Tcl_CreateFileHandler. */ ClientData clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; /* * The following structure is what is added to the Tcl event queue when file * handlers are ready to fire. */ typedef struct FileHandlerEvent { Tcl_Event header; /* Information that is standard for all * events. */ int fd; /* File descriptor that is ready. Used to find * the FileHandler structure for the file * (can't point directly to the FileHandler * structure because it could go away while * the event is queued). */ } FileHandlerEvent; /* * The following static structure contains the state information for the Xt * based implementation of the Tcl notifier. */ static struct NotifierState { XtAppContext appContext; /* The context used by the Xt notifier. Can be * set with TclSetAppContext. */ int appContextCreated; /* Was it created by us? */ XtIntervalId currentTimeout;/* Handle of current timer. */ FileHandler *firstFileHandlerPtr; /* Pointer to head of file handler list. */ } notifier; /* * The following static indicates whether this module has been initialized. */ static int initialized = 0; |
︙ | ︙ | |||
80 81 82 83 84 85 86 | static void FileProc _ANSI_ARGS_((caddr_t clientData, int *source, XtInputId *id)); void InitNotifier _ANSI_ARGS_((void)); static void NotifierExitHandler _ANSI_ARGS_(( ClientData clientData)); static void TimerProc _ANSI_ARGS_((caddr_t clientData, XtIntervalId *id)); | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | static void FileProc _ANSI_ARGS_((caddr_t clientData, int *source, XtInputId *id)); void InitNotifier _ANSI_ARGS_((void)); static void NotifierExitHandler _ANSI_ARGS_(( ClientData clientData)); static void TimerProc _ANSI_ARGS_((caddr_t clientData, XtIntervalId *id)); static void CreateFileHandler _ANSI_ARGS_((int fd, int mask, Tcl_FileProc * proc, ClientData clientData)); static void DeleteFileHandler _ANSI_ARGS_((int fd)); static void SetTimer _ANSI_ARGS_((Tcl_Time * timePtr)); static int WaitForEvent _ANSI_ARGS_((Tcl_Time * timePtr)); /* * Functions defined in this file for use by users of the Xt Notifier: |
︙ | ︙ | |||
103 104 105 106 107 108 109 | * * Set the notifier application context. * * Results: * None. * * Side effects: | | | | | | | < | | | | | | < < | | | | | < | | | | | | | < | | | | | | | | | 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 | * * Set the notifier application context. * * Results: * None. * * Side effects: * Sets the application context used by the notifier. Panics if the * context is already set when called. * *---------------------------------------------------------------------- */ XtAppContext TclSetAppContext(appContext) XtAppContext appContext; { if (!initialized) { InitNotifier(); } /* * If we already have a context we check whether we were asked to set a * new context. If so, we panic because we try to prevent switching * contexts by mistake. Otherwise, we return the one we have. */ if (notifier.appContext != NULL) { if (appContext != NULL) { /* * We already have a context. We do not allow switching contexts * after initialization, so we panic. */ Tcl_Panic("TclSetAppContext: multiple application contexts"); } } else { /* * If we get here we have not yet gotten a context, so either create * one or use the one supplied by our caller. */ if (appContext == NULL) { /* * We must create a new context and tell our caller what it is, so * she can use it too. */ notifier.appContext = XtCreateApplicationContext(); notifier.appContextCreated = 1; } else { /* * Otherwise we remember the context that our caller gave us and * use it. */ notifier.appContextCreated = 0; notifier.appContext = appContext; } } return notifier.appContext; } /* *---------------------------------------------------------------------- * * InitNotifier -- |
︙ | ︙ | |||
185 186 187 188 189 190 191 192 | *---------------------------------------------------------------------- */ void InitNotifier() { Tcl_NotifierProcs notifier; /* | > | | | | | | | | | | | | | 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 | *---------------------------------------------------------------------- */ void InitNotifier() { Tcl_NotifierProcs notifier; /* * Only reinitialize if we are not in exit handling. The notifier can get * reinitialized after its own exit handler has run, because of exit * handlers for the I/O and timer sub-systems (order dependency). */ if (TclInExit()) { return; } notifier.createFileHandlerProc = CreateFileHandler; notifier.deleteFileHandlerProc = DeleteFileHandler; notifier.setTimerProc = SetTimer; notifier.waitForEventProc = WaitForEvent; Tcl_SetNotifier(¬ifier); /* * DO NOT create the application context yet; doing so would prevent * external applications from setting it for us to their own ones. */ initialized = 1; memset(¬ifier, 0, sizeof(notifier)); Tcl_CreateExitHandler(NotifierExitHandler, NULL); } /* *---------------------------------------------------------------------- * * NotifierExitHandler -- * * This function is called to cleanup the notifier state before Tcl is * unloaded. * * Results: * None. * * Side effects: * Destroys the notifier window. * *---------------------------------------------------------------------- */ static void NotifierExitHandler( ClientData clientData) /* Not used. */ { if (notifier.currentTimeout != 0) { XtRemoveTimeOut(notifier.currentTimeout); } for (; notifier.firstFileHandlerPtr != NULL; ) { Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd); } if (notifier.appContextCreated) { XtDestroyApplicationContext(notifier.appContext); notifier.appContextCreated = 0; notifier.appContext = NULL; } initialized = 0; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
278 279 280 281 282 283 284 | TclSetAppContext(NULL); if (notifier.currentTimeout != 0) { XtRemoveTimeOut(notifier.currentTimeout); } if (timePtr) { timeout = timePtr->sec * 1000 + timePtr->usec / 1000; | | < | | < | | 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 | TclSetAppContext(NULL); if (notifier.currentTimeout != 0) { XtRemoveTimeOut(notifier.currentTimeout); } if (timePtr) { timeout = timePtr->sec * 1000 + timePtr->usec / 1000; notifier.currentTimeout = XtAppAddTimeOut(notifier.appContext, (unsigned long) timeout, TimerProc, NULL); } else { notifier.currentTimeout = 0; } } /* *---------------------------------------------------------------------- * * TimerProc -- * * This procedure is the XtTimerCallbackProc used to handle timeouts. * * Results: * None. * * Side effects: * Processes all queued events. * *---------------------------------------------------------------------- */ static void TimerProc(data, id) caddr_t data; /* Not used. */ |
︙ | ︙ | |||
327 328 329 330 331 332 333 | * * This procedure registers a file handler with the Xt notifier. * * Results: * None. * * Side effects: | | | | | | | | | 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 | * * This procedure registers a file handler with the Xt notifier. * * Results: * None. * * Side effects: * Creates a new file handler structure and registers one or more input * procedures with Xt. * *---------------------------------------------------------------------- */ static void CreateFileHandler(fd, mask, proc, clientData) int fd; /* Handle of stream to watch. */ int mask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * called. */ Tcl_FileProc *proc; /* Procedure to call for each selected * event. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { FileHandler *filePtr; if (!initialized) { InitNotifier(); } |
︙ | ︙ | |||
378 379 380 381 382 383 384 | /* * Register the file with the Xt notifier, if it hasn't been done yet. */ if (mask & TCL_READABLE) { if (!(filePtr->mask & TCL_READABLE)) { | < | | | < | | < | | < | | | < | 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 | /* * Register the file with the Xt notifier, if it hasn't been done yet. */ if (mask & TCL_READABLE) { if (!(filePtr->mask & TCL_READABLE)) { filePtr->read = XtAppAddInput(notifier.appContext, fd, XtInputReadMask, FileProc, filePtr); } } else { if (filePtr->mask & TCL_READABLE) { XtRemoveInput(filePtr->read); } } if (mask & TCL_WRITABLE) { if (!(filePtr->mask & TCL_WRITABLE)) { filePtr->write = XtAppAddInput(notifier.appContext, fd, XtInputWriteMask, FileProc, filePtr); } } else { if (filePtr->mask & TCL_WRITABLE) { XtRemoveInput(filePtr->write); } } if (mask & TCL_EXCEPTION) { if (!(filePtr->mask & TCL_EXCEPTION)) { filePtr->except = XtAppAddInput(notifier.appContext, fd, XtInputExceptMask, FileProc, filePtr); } } else { if (filePtr->mask & TCL_EXCEPTION) { XtRemoveInput(filePtr->except); } } filePtr->mask = mask; } /* *---------------------------------------------------------------------- * * DeleteFileHandler -- * * Cancel a previously-arranged callback arrangement for a file. * * Results: * None. * * Side effects: * If a callback was previously registered on file, remove it. * *---------------------------------------------------------------------- */ static void DeleteFileHandler(fd) int fd; /* Stream id for which to remove callback * procedure. */ { FileHandler *filePtr, *prevPtr; if (!initialized) { InitNotifier(); } TclSetAppContext(NULL); /* * Find the entry for the given file (and return if there isn't one). */ for (prevPtr = NULL, filePtr = notifier.firstFileHandlerPtr; ; prevPtr = filePtr, filePtr = filePtr->nextPtr) { if (filePtr == NULL) { return; } |
︙ | ︙ | |||
490 491 492 493 494 495 496 | * These procedures are called by Xt when a file becomes readable, * writable, or has an exception. * * Results: * None. * * Side effects: | | < | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 | * These procedures are called by Xt when a file becomes readable, * writable, or has an exception. * * Results: * None. * * Side effects: * Makes an entry on the Tcl event queue if the event is interesting. * *---------------------------------------------------------------------- */ static void FileProc(clientData, fd, id) caddr_t clientData; |
︙ | ︙ | |||
525 526 527 528 529 530 531 | /* * Ignore unwanted or duplicate events. */ if (!(filePtr->mask & mask) || (filePtr->readyMask & mask)) { return; } | | | 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 | /* * Ignore unwanted or duplicate events. */ if (!(filePtr->mask & mask) || (filePtr->readyMask & mask)) { return; } /* * This is an interesting event, so put it onto the event queue. */ filePtr->readyMask |= mask; fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; |
︙ | ︙ | |||
548 549 550 551 552 553 554 | } /* *---------------------------------------------------------------------- * * FileHandlerEventProc -- * | | | | | | | | | | | | | | | | | | | | < | > | | | | | | | | | | | | | | | | > | > > > > > > > > | 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 | } /* *---------------------------------------------------------------------- * * FileHandlerEventProc -- * * This procedure is called by Tcl_ServiceEvent when a file event reaches * the front of the event queue. This procedure is responsible for * actually handling the event by invoking the callback for the file * handler. * * Results: * Returns 1 if the event was handled, meaning it should be removed from * the queue. Returns 0 if the event was not handled, meaning it should * stay on the queue. The only time the event isn't handled is if the * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the file handler's callback procedure does. * *---------------------------------------------------------------------- */ static int FileHandlerEventProc(evPtr, flags) Tcl_Event *evPtr; /* Event to service. */ int flags; /* Flags that indicate what events to handle, * such as TCL_FILE_EVENTS. */ { FileHandler *filePtr; FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; int mask; if (!(flags & TCL_FILE_EVENTS)) { return 0; } /* * Search through the file handlers to find the one whose handle matches * the event. We do this rather than keeping a pointer to the file handler * directly in the event, so that the handler can be deleted while the * event is queued without leaving a dangling pointer. */ for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL; filePtr = filePtr->nextPtr) { if (filePtr->fd != fileEvPtr->fd) { continue; } /* * The code is tricky for two reasons: * 1. The file handler's desired events could have changed since the * time when the event was queued, so AND the ready mask with the * desired mask. * 2. The file could have been closed and re-opened since the time * when the event was queued. This is why the ready mask is stored * in the file handler rather than the queued event: it will be * zeroed when a new file handler is created for the newly opened * file. */ mask = filePtr->readyMask & filePtr->mask; filePtr->readyMask = 0; if (mask != 0) { (*filePtr->proc)(filePtr->clientData, mask); } break; } return 1; } /* *---------------------------------------------------------------------- * * WaitForEvent -- * * This function is called by Tcl_DoOneEvent to wait for new events on * the message queue. If the block time is 0, then Tcl_WaitForEvent just * polls without blocking. * * Results: * Returns 1 if an event was found, else 0. This ensures that * Tcl_DoOneEvent will return 1, even if the event is handled by non-Tcl * code. * * Side effects: * Queues file events that are detected by the select. * *---------------------------------------------------------------------- */ static int WaitForEvent( Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { int timeout; if (!initialized) { InitNotifier(); } TclSetAppContext(NULL); if (timePtr) { timeout = timePtr->sec * 1000 + timePtr->usec / 1000; if (timeout == 0) { if (XtAppPending(notifier.appContext)) { goto process; } else { return 0; } } else { Tcl_SetTimer(timePtr); } } process: XtAppProcessEvent(notifier.appContext, XtIMAll); return 1; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/.cvsignore.
︙ | ︙ | |||
9 10 11 12 13 14 15 | *.i *.asm Makefile tcl.hpj tclConfig.sh nmakehlp.exe .#* | > > | 9 10 11 12 13 14 15 16 17 | *.i *.asm Makefile tcl.hpj tclConfig.sh nmakehlp.exe .#* tcl.sln tcl.suo |
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.84.2.15 2005/09/23 16:47:35 dgp 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 |
︙ | ︙ | |||
98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | # Special compiler flags to use when building man2tcl on Windows. MAN2TCLFLAGS = @MAN2TCLFLAGS@ SRC_DIR = @srcdir@ ROOT_DIR = @srcdir@/.. GENERIC_DIR = @srcdir@/../generic WIN_DIR = @srcdir@ COMPAT_DIR = @srcdir@/../compat # Converts a POSIX path to a Windows native path. CYGPATH = @CYGPATH@ GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)') WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)') | > > | | 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 | # Special compiler flags to use when building man2tcl on Windows. MAN2TCLFLAGS = @MAN2TCLFLAGS@ SRC_DIR = @srcdir@ ROOT_DIR = @srcdir@/.. GENERIC_DIR = @srcdir@/../generic TOMMATH_DIR = @srcdir@/../libtommath WIN_DIR = @srcdir@ COMPAT_DIR = @srcdir@/../compat # Converts a POSIX path to a Windows native path. CYGPATH = @CYGPATH@ GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)') TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)') WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)') ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)' | sed 's/\\*$$//' ) LIBRARY_DIR = $(shell echo '$(ROOT_DIR_NATIVE)/library' | sed 's/\\/\//g' ) DLLSUFFIX = @DLLSUFFIX@ LIBSUFFIX = @LIBSUFFIX@ EXESUFFIX = @EXESUFFIX@ |
︙ | ︙ | |||
152 153 154 155 156 157 158 | @SET_MAKE@ # Setting the VPATH variable to a list of paths will cause the # makefile to look into these paths when resolving .c to .obj # dependencies. | | | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | @SET_MAKE@ # Setting the VPATH variable to a list of paths will cause the # makefile to look into these paths when resolving .c to .obj # dependencies. VPATH = $(GENERIC_DIR):$(TOMMATH_DIR):$(WIN_DIR):$(COMPAT_DIR) AR = @AR@ RANLIB = @RANLIB@ CC = @CC@ RC = @RC@ RES = @RES@ AC_FLAGS = @EXTRA_CFLAGS@ @DEFS@ |
︙ | ︙ | |||
182 183 184 185 186 187 188 | RMDIR = rm -rf MKDIR = mkdir -p SHELL = @SHELL@ RM = rm -f COPY = cp CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ | > | > | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 | RMDIR = rm -rf MKDIR = mkdir -p SHELL = @SHELL@ RM = rm -f COPY = cp CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ -I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ ${COMPILE_DEBUG_FLAGS} CC_OBJNAME = @CC_OBJNAME@ CC_EXENAME = @CC_EXENAME@ STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ -I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ ${COMPILE_DEBUG_FLAGS} TCLTEST_OBJS = \ tclTest.$(OBJEXT) \ tclTestObj.$(OBJEXT) \ tclTestProcBodyObj.$(OBJEXT) \ tclThreadTest.$(OBJEXT) \ |
︙ | ︙ | |||
234 235 236 237 238 239 240 241 242 243 244 245 246 247 | tclHash.$(OBJEXT) \ tclHistory.$(OBJEXT) \ tclIndexObj.$(OBJEXT) \ tclInterp.$(OBJEXT) \ tclIO.$(OBJEXT) \ tclIOCmd.$(OBJEXT) \ tclIOGT.$(OBJEXT) \ tclIOSock.$(OBJEXT) \ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ tclLiteral.$(OBJEXT) \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ tclMain.$(OBJEXT) \ | > | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | tclHash.$(OBJEXT) \ tclHistory.$(OBJEXT) \ tclIndexObj.$(OBJEXT) \ tclInterp.$(OBJEXT) \ tclIO.$(OBJEXT) \ tclIOCmd.$(OBJEXT) \ tclIOGT.$(OBJEXT) \ tclIORChan.$(OBJEXT) \ tclIOSock.$(OBJEXT) \ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ tclLiteral.$(OBJEXT) \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ tclMain.$(OBJEXT) \ |
︙ | ︙ | |||
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 | tclPreserve.$(OBJEXT) \ tclProc.$(OBJEXT) \ tclRegexp.$(OBJEXT) \ tclResolve.$(OBJEXT) \ tclResult.$(OBJEXT) \ tclScan.$(OBJEXT) \ tclStringObj.$(OBJEXT) \ tclStubInit.$(OBJEXT) \ tclStubLib.$(OBJEXT) \ tclThread.$(OBJEXT) \ tclThreadAlloc.$(OBJEXT) \ tclThreadJoin.$(OBJEXT) \ tclThreadStorage.$(OBJEXT) \ tclTimer.$(OBJEXT) \ tclTrace.$(OBJEXT) \ tclUtf.$(OBJEXT) \ tclUtil.$(OBJEXT) \ tclVar.$(OBJEXT) WIN_OBJS = \ tclWin32Dll.$(OBJEXT) \ tclWinChan.$(OBJEXT) \ tclWinConsole.$(OBJEXT) \ tclWinSerial.$(OBJEXT) \ tclWinError.$(OBJEXT) \ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | tclPreserve.$(OBJEXT) \ tclProc.$(OBJEXT) \ tclRegexp.$(OBJEXT) \ tclResolve.$(OBJEXT) \ tclResult.$(OBJEXT) \ tclScan.$(OBJEXT) \ tclStringObj.$(OBJEXT) \ tclStrToD.$(OBJEXT) \ tclStubInit.$(OBJEXT) \ tclStubLib.$(OBJEXT) \ tclThread.$(OBJEXT) \ tclThreadAlloc.$(OBJEXT) \ tclThreadJoin.$(OBJEXT) \ tclThreadStorage.$(OBJEXT) \ tclTimer.$(OBJEXT) \ tclTomMathInterface.$(OBJEXT) \ tclTrace.$(OBJEXT) \ tclUtf.$(OBJEXT) \ tclUtil.$(OBJEXT) \ tclVar.$(OBJEXT) TOMMATH_OBJS = \ bncore.${OBJEXT} \ bn_reverse.${OBJEXT} \ bn_fast_s_mp_mul_digs.${OBJEXT} \ bn_fast_s_mp_sqr.${OBJEXT} \ bn_mp_add.${OBJEXT} \ bn_mp_add_d.${OBJEXT} \ bn_mp_and.${OBJEXT} \ bn_mp_clamp.${OBJEXT} \ bn_mp_clear.${OBJEXT} \ bn_mp_clear_multi.${OBJEXT} \ bn_mp_cmp.${OBJEXT} \ bn_mp_cmp_d.${OBJEXT} \ bn_mp_cmp_mag.${OBJEXT} \ bn_mp_copy.${OBJEXT} \ bn_mp_count_bits.${OBJEXT} \ bn_mp_div.${OBJEXT} \ bn_mp_div_d.${OBJEXT} \ bn_mp_div_2.${OBJEXT} \ bn_mp_div_2d.${OBJEXT} \ bn_mp_div_3.${OBJEXT} \ bn_mp_exch.${OBJEXT} \ bn_mp_expt_d.${OBJEXT} \ bn_mp_grow.${OBJEXT} \ bn_mp_init.${OBJEXT} \ bn_mp_init_copy.${OBJEXT} \ bn_mp_init_multi.${OBJEXT} \ bn_mp_init_set.${OBJEXT} \ bn_mp_init_size.${OBJEXT} \ bn_mp_karatsuba_mul.${OBJEXT} \ bn_mp_karatsuba_sqr.$(OBJEXT) \ bn_mp_lshd.${OBJEXT} \ bn_mp_mod.${OBJEXT} \ bn_mp_mod_2d.${OBJEXT} \ bn_mp_mul.${OBJEXT} \ bn_mp_mul_2.${OBJEXT} \ bn_mp_mul_2d.${OBJEXT} \ bn_mp_mul_d.${OBJEXT} \ bn_mp_neg.${OBJEXT} \ bn_mp_or.${OBJEXT} \ bn_mp_radix_size.${OBJEXT} \ bn_mp_radix_smap.${OBJEXT} \ bn_mp_read_radix.${OBJEXT} \ bn_mp_rshd.${OBJEXT} \ bn_mp_set.${OBJEXT} \ bn_mp_shrink.${OBJEXT} \ bn_mp_sqr.${OBJEXT} \ bn_mp_sqrt.${OBJEXT} \ bn_mp_sub.${OBJEXT} \ bn_mp_sub_d.${OBJEXT} \ bn_mp_to_unsigned_bin.${OBJEXT} \ bn_mp_to_unsigned_bin_n.${OBJEXT} \ bn_mp_toom_mul.${OBJEXT} \ bn_mp_toom_sqr.${OBJEXT} \ bn_mp_toradix_n.${OBJEXT} \ bn_mp_unsigned_bin_size.${OBJEXT} \ bn_mp_xor.${OBJEXT} \ bn_mp_zero.${OBJEXT} \ bn_s_mp_add.${OBJEXT} \ bn_s_mp_mul_digs.${OBJEXT} \ bn_s_mp_sqr.${OBJEXT} \ bn_s_mp_sub.${OBJEXT} WIN_OBJS = \ tclWin32Dll.$(OBJEXT) \ tclWinChan.$(OBJEXT) \ tclWinConsole.$(OBJEXT) \ tclWinSerial.$(OBJEXT) \ tclWinError.$(OBJEXT) \ |
︙ | ︙ | |||
300 301 302 303 304 305 306 | REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = tclStubLib.$(OBJEXT) TCLSH_OBJS = tclAppInit.$(OBJEXT) | | | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 | REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = tclStubLib.$(OBJEXT) TCLSH_OBJS = tclAppInit.$(OBJEXT) TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} ${COMPAT_OBJS} TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] all: binaries libraries doc tcltest: $(TCLTEST) |
︙ | ︙ | |||
464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 | # only run by hand as yacc is not available in all environments. # The name of the .c file is different than the name of the .y file # so that make doesn't try to automatically regenerate the .c file. gendate: bison --output-file=$(GENERIC_DIR)/tclDate.c \ --name-prefix=TclDate \ $(GENERIC_DIR)/tclGetDate.y install: all install-binaries install-libraries install-doc install-binaries: binaries @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \ do \ if [ ! -d $$i ] ; then \ | > > > > > > > > > > | 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 | # only run by hand as yacc is not available in all environments. # The name of the .c file is different than the name of the .y file # so that make doesn't try to automatically regenerate the .c file. gendate: bison --output-file=$(GENERIC_DIR)/tclDate.c \ --name-prefix=TclDate \ --no-lines \ $(GENERIC_DIR)/tclGetDate.y # The following target generates the file generic/tommath.h. # It needs to be run (and the results checked) after updating # to a new release of libtommath. gentommath_h: $(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\fix_tommath_h.tcl" \ "$(TOMMATH_DIR_NATIVE)\tommath.h" \ > "$(GENERIC_DIR_NATIVE)\tommath.h" install: all install-binaries install-libraries install-doc install-binaries: binaries @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \ do \ if [ ! -d $$i ] ; then \ |
︙ | ︙ | |||
555 556 557 558 559 560 561 | $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing library http1.0 directory"; @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; | | | | | | 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 | $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing library http1.0 directory"; @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; @echo "Installing package http 2.5.1 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.1.tm; @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 package msgcat 1.4.1 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.1.tm; @echo "Installing package tcltest 2.2.8 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.3/tcltest-2.2.8.tm; @echo "Installing encodings"; @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ done; install-tzdata: @echo "Installing time zone data" |
︙ | ︙ | |||
646 647 648 649 650 651 652 | clean: cleanhelp $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out $(RM) $(TCLSH) $(TCLTEST) $(CAT32) $(RM) *.pch *.ilk *.pdb distclean: clean $(RM) Makefile config.status config.cache config.log tclConfig.sh \ | | | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 | clean: cleanhelp $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out $(RM) $(TCLSH) $(TCLTEST) $(CAT32) $(RM) *.pch *.ilk *.pdb distclean: clean $(RM) Makefile config.status config.cache config.log tclConfig.sh \ tcl.hpj config.status.lineno # # Regenerate the stubs files. # $(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ $(GENERIC_DIR)/tclInt.decls |
︙ | ︙ |
Changes to win/README.
1 2 | Tcl 8.5 for Windows | | | 1 2 3 4 5 6 7 8 9 10 | Tcl 8.5 for Windows RCS: @(#) $Id: README,v 1.32.2.1 2005/08/02 18:16:58 dgp Exp $ 1. Introduction --------------- This is the directory where you configure and compile the Windows version of Tcl. This directory also contains source files for Tcl that are specific to Microsoft Windows. |
︙ | ︙ | |||
26 27 28 29 30 31 32 | Visual C++ 5 or newer or Msys + Mingw | | < < < < < < < < < < < | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | Visual C++ 5 or newer or Msys + Mingw http://prdownloads.sourceforge.net/tcl/msys_mingw8.zip This Msys + Mingw download is the minimal environment needed to build Tcl/Tk under Windows. It includes a shell environment and gcc. The release is designed to make it as easy a possible to build Tcl/Tk. To install, you just download the zip file and extract the files into a directory. The README.TXT file describes how to launch the msys shell, you then run the configure script in the tcl/win directory. In practice, this release is built with Visual C++ 6.0 and the TEA Makefile. If you are building with Visual C++, in the "win" subdirectory of the source release, you will find "makefile.vc". This is the makefile for the Visual C++ compiler and uses the stock NMAKE tool. Detailed |
︙ | ︙ |
Changes to win/README.binary.
1 2 | Tcl/Tk 8.5 for Windows, Binary Distribution | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | Tcl/Tk 8.5 for Windows, Binary Distribution RCS: @(#) $Id: README.binary,v 1.38.2.2 2005/07/12 20:37:31 kennykb Exp $ 1. Introduction --------------- This directory contains the binary distribution of Tcl/Tk 8.5a4 for Windows. It was compiled with Microsoft Visual C++ 6.0 using Win32 API, so that it will run under Windows 98, NT, 2000 and XP. 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.
1 2 | #! /bin/sh # Guess values for system-dependent variables and create Makefiles. | | < | > | | | 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 | #! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.59. # # Copyright (C) 2003 Free Software Foundation, Inc. # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## # Be Bourne compatible if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # Work around bugs in pre-3.0 UWIN ksh. $as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done # Required to use basename. |
︙ | ︙ | |||
214 215 216 217 218 219 220 221 222 223 224 225 226 | as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. | > | | | 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 | as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' ' IFS=" $as_nl" |
︙ | ︙ | |||
663 664 665 666 667 668 669 | *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; };; esac done # Be sure to have absolute paths. for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ | | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 | *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; };; esac done # Be sure to have absolute paths. for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ localstatedir libdir includedir oldincludedir infodir mandir do eval ac_val=$`echo $ac_var` case $ac_val in [\\/$]* | ?:[\\/]* ) ;; *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; };; esac |
︙ | ︙ | |||
703 704 705 706 707 708 709 | # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then its parent. ac_confdir=`(dirname "$0") 2>/dev/null || $as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ | | | | | | 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 | # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then its parent. ac_confdir=`(dirname "$0") 2>/dev/null || $as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$0" : 'X\(//\)[^/]' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$0" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` srcdir=$ac_confdir |
︙ | ︙ | |||
798 799 800 801 802 803 804 | --srcdir=DIR find the sources in DIR [configure dir or \`..'] _ACEOF cat <<_ACEOF Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX | | | | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 | --srcdir=DIR find the sources in DIR [configure dir or \`..'] _ACEOF cat <<_ACEOF Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. |
︙ | ︙ | |||
890 891 892 893 894 895 896 | [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac | | | > > > > > | > > > > > > > | > > > > > > | > > > > > > > > > > | > > > > > | < | | | 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 | [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac # Do not use `cd foo && pwd` to compute absolute paths, because # the directories may not exist. case `pwd` in .) ac_abs_builddir="$ac_dir";; *) case "$ac_dir" in .) ac_abs_builddir=`pwd`;; [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; *) ac_abs_builddir=`pwd`/"$ac_dir";; esac;; esac case $ac_abs_builddir in .) ac_abs_top_builddir=${ac_top_builddir}.;; *) case ${ac_top_builddir}. in .) ac_abs_top_builddir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; esac;; esac case $ac_abs_builddir in .) ac_abs_srcdir=$ac_srcdir;; *) case $ac_srcdir in .) ac_abs_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; esac;; esac case $ac_abs_builddir in .) ac_abs_top_srcdir=$ac_top_srcdir;; *) case $ac_top_srcdir in .) ac_abs_top_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; esac;; esac cd $ac_dir # Check for guested configure; otherwise get Cygnus style configure. if test -f $ac_srcdir/configure.gnu; then echo $SHELL $ac_srcdir/configure.gnu --help=recursive elif test -f $ac_srcdir/configure; then echo $SHELL $ac_srcdir/configure --help=recursive elif test -f $ac_srcdir/configure.ac || test -f $ac_srcdir/configure.in; then echo $ac_configure --help else echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi cd $ac_popdir done fi test -n "$ac_init_help" && exit 0 if $ac_init_version; then cat <<\_ACEOF Copyright (C) 2003 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit 0 fi exec 5>config.log cat >&5 <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.59. Invocation command line was $ $0 $@ _ACEOF { cat <<_ASUNAME ## --------- ## |
︙ | ︙ | |||
1010 1011 1012 1013 1014 1015 1016 | ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) ac_configure_args1="$ac_configure_args1 '$ac_arg'" if test $ac_must_keep_next = true; then | | | | | | | | | | | | | | 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 | ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) ac_configure_args1="$ac_configure_args1 '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" # Get rid of the leading space. ac_sep=" " ;; esac done |
︙ | ︙ | |||
1056 1057 1058 1059 1060 1061 1062 | echo # The following way of writing the cache mishandles newlines in values, { (set) 2>&1 | case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in *ac_space=\ *) sed -n \ | | | | | 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 | echo # The following way of writing the cache mishandles newlines in values, { (set) 2>&1 | case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in *ac_space=\ *) sed -n \ "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" ;; *) sed -n \ "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } echo cat <<\_ASBOX ## ----------------- ## |
︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 | ## Output files. ## ## ------------- ## _ASBOX echo for ac_var in $ac_subst_files do eval ac_val=$`echo $ac_var` | | | | 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 | ## Output files. ## ## ------------- ## _ASBOX echo for ac_var in $ac_subst_files do eval ac_val=$`echo $ac_var` echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo fi if test -s confdefs.h; then cat <<\_ASBOX ## ----------- ## ## confdefs.h. ## ## ----------- ## _ASBOX echo sed "/^$/d" confdefs.h | sort echo fi test "$ac_signal" != 0 && echo "$as_me: caught signal $ac_signal" echo "$as_me: exit $exit_status" } >&5 rm -f core *.core && rm -rf conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal done ac_signal=0 |
︙ | ︙ | |||
1189 1190 1191 1192 1193 1194 1195 | >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in `(set) 2>&1 | | | | | | | | 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 | >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in `(set) 2>&1 | sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val="\$ac_cv_env_${ac_var}_value" eval ac_new_val="\$ac_env_${ac_var}_value" case $ac_old_set,$ac_new_set in set,) { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 echo "$as_me: former value: $ac_old_val" >&2;} { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 echo "$as_me: current value: $ac_new_val" >&2;} ac_cache_corrupted=: fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; |
︙ | ︙ | |||
1270 1271 1272 1273 1274 1275 1276 | # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 | | | 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 | # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 TCL_PATCH_LEVEL="a4" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=3 TCL_DDE_PATCH_LEVEL="" DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION |
︙ | ︙ | |||
1644 1645 1646 1647 1648 1649 1650 | { (eval echo "$as_me:$LINENO: \"$ac_compiler -V </dev/null >&5\"") >&5 (eval $ac_compiler -V </dev/null >&5) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } cat >conftest.$ac_ext <<_ACEOF | < | | | | | | | | | | | | | | | | 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 | { (eval echo "$as_me:$LINENO: \"$ac_compiler -V </dev/null >&5\"") >&5 (eval $ac_compiler -V </dev/null >&5) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6 ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 (eval $ac_link_default) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then # Find the output, starting from the most likely. This scheme is # not robust to junk in `.', hence go to wildcards (a.*) only as a last # resort. # Be careful to initialize this variable, since it used to be cached. # Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile. ac_cv_exeext= # b.out is created by i960 compilers. for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; conftest.$ac_ext ) # This is the source file. ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` # FIXME: I believe we export ac_cv_exeext for Libtool, # but it would be cool to find out if it's true. Does anybody # maintain Libtool? --akim. export ac_cv_exeext break;; * ) break;; esac done else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { echo "$as_me:$LINENO: error: C compiler cannot create executables |
︙ | ︙ | |||
1775 1776 1777 1778 1779 1780 1781 | # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` | | | | 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 | # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` export ac_cv_exeext break;; * ) break;; esac done else { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link See \`config.log' for more details." >&5 echo "$as_me: error: cannot compute suffix of executables: cannot compile and link |
︙ | ︙ | |||
1801 1802 1803 1804 1805 1806 1807 | ac_exeext=$EXEEXT echo "$as_me:$LINENO: checking for suffix of object files" >&5 echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 if test "${ac_cv_objext+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 | ac_exeext=$EXEEXT echo "$as_me:$LINENO: checking for suffix of object files" >&5 echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 if test "${ac_cv_objext+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int |
︙ | ︙ | |||
1852 1853 1854 1855 1856 1857 1858 | ac_objext=$OBJEXT echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 if test "${ac_cv_c_compiler_gnu+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < | > > > > > > > > > > | | | 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 | ac_objext=$OBJEXT echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 if test "${ac_cv_c_compiler_gnu+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_compiler_gnu=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_compiler_gnu=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 GCC=`test $ac_compiler_gnu = yes && echo yes` ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS CFLAGS="-g" echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 if test "${ac_cv_prog_cc_g+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_prog_cc_g=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_prog_cc_g=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then |
︙ | ︙ | |||
1966 1967 1968 1969 1970 1971 1972 | echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 if test "${ac_cv_prog_cc_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_prog_cc_stdc=no ac_save_CC=$CC cat >conftest.$ac_ext <<_ACEOF | < | 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 | echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 if test "${ac_cv_prog_cc_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_prog_cc_stdc=no ac_save_CC=$CC cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <stdarg.h> #include <stdio.h> |
︙ | ︙ | |||
1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 | char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int | > > > > > > > > > > | 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 | char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std1 is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std1. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int |
︙ | ︙ | |||
2020 2021 2022 2023 2024 2025 2026 | # HP-UX older versions -Aa -D_HPUX_SOURCE # SVR4 -Xc -D__EXTENSIONS__ for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | | | 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 | # HP-UX older versions -Aa -D_HPUX_SOURCE # SVR4 -Xc -D__EXTENSIONS__ for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_prog_cc_stdc=$ac_arg break else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext done rm -f conftest.$ac_ext conftest.$ac_objext CC=$ac_save_CC fi case "x$ac_cv_prog_cc_stdc" in |
︙ | ︙ | |||
2065 2066 2067 2068 2069 2070 2071 | cat >conftest.$ac_ext <<_ACEOF #ifndef __cplusplus choke me #endif _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | | < < < > | > > > > > > > > > > | | < | > > > > > > > > > > | | | | 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 | cat >conftest.$ac_ext <<_ACEOF #ifndef __cplusplus choke me #endif _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then for ac_declaration in \ '' \ 'extern "C" void std::exit (int) throw (); using std::exit;' \ 'extern "C" void std::exit (int); using std::exit;' \ 'extern "C" void exit (int) throw ();' \ 'extern "C" void exit (int);' \ 'void exit (int);' do cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_declaration #include <stdlib.h> int main () { exit (42); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then : else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 continue fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_declaration int main () { exit (42); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then break else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext done rm -f conftest* if test -n "$ac_declaration"; then echo '#ifdef __cplusplus' >>confdefs.h echo $ac_declaration >>confdefs.h echo '#endif' >>confdefs.h fi else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu |
︙ | ︙ | |||
2314 2315 2316 2317 2318 2319 2320 | #-------------------------------------------------------------------- # Checks to see if the make progeam sets the $MAKE variable. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5 echo $ECHO_N "checking whether ${MAKE-make} sets \$(MAKE)... $ECHO_C" >&6 | | | 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 | #-------------------------------------------------------------------- # Checks to see if the make progeam sets the $MAKE variable. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5 echo $ECHO_N "checking whether ${MAKE-make} sets \$(MAKE)... $ECHO_C" >&6 set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y,:./+-,___p_,'` if eval "test \"\${ac_cv_prog_make_${ac_make}_set+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.make <<\_ACEOF all: @echo 'ac_maketemp="$(MAKE)"' _ACEOF |
︙ | ︙ | |||
2354 2355 2356 2357 2358 2359 2360 | echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5 echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6 if test "${ac_cv_cygwin+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | | 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 | echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5 echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6 if test "${ac_cv_cygwin+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __CYGWIN__ #error cygwin #endif int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_cygwin=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_cygwin=yes fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_cygwin" >&5 echo "${ECHO_T}$ac_cv_cygwin" >&6 if test "$ac_cv_cygwin" = "yes" ; then { { echo "$as_me:$LINENO: error: Compiling under Cygwin is not currently supported. A maintainer for the Cygwin port of Tcl/Tk is needed. See the README |
︙ | ︙ | |||
2417 2418 2419 2420 2421 2422 2423 | if test "${tcl_cv_seh+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then tcl_cv_seh=no else cat >conftest.$ac_ext <<_ACEOF | < | 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 | if test "${tcl_cv_seh+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then tcl_cv_seh=no else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define WIN32_LEAN_AND_MEAN |
︙ | ︙ | |||
2460 2461 2462 2463 2464 2465 2466 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_seh=no fi | | | 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_seh=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi echo "$as_me:$LINENO: result: $tcl_cv_seh" >&5 echo "${ECHO_T}$tcl_cv_seh" >&6 if test "$tcl_cv_seh" = "no" ; then |
︙ | ︙ | |||
2486 2487 2488 2489 2490 2491 2492 | # echo "$as_me:$LINENO: checking for EXCEPTION_DISPOSITION support in include files" >&5 echo $ECHO_N "checking for EXCEPTION_DISPOSITION support in include files... $ECHO_C" >&6 if test "${tcl_cv_eh_disposition+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 | # echo "$as_me:$LINENO: checking for EXCEPTION_DISPOSITION support in include files" >&5 echo $ECHO_N "checking for EXCEPTION_DISPOSITION support in include files... $ECHO_C" >&6 if test "${tcl_cv_eh_disposition+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define WIN32_LEAN_AND_MEAN |
︙ | ︙ | |||
2509 2510 2511 2512 2513 2514 2515 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | | | 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 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_eh_disposition=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_eh_disposition=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_eh_disposition" >&5 echo "${ECHO_T}$tcl_cv_eh_disposition" >&6 if test "$tcl_cv_eh_disposition" = "no" ; then cat >>confdefs.h <<\_ACEOF |
︙ | ︙ | |||
2549 2550 2551 2552 2553 2554 2555 | # echo "$as_me:$LINENO: checking for LPFN_ACCEPT support in winsock2.h" >&5 echo $ECHO_N "checking for LPFN_ACCEPT support in winsock2.h... $ECHO_C" >&6 if test "${tcl_cv_lpfn_decls+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 | # echo "$as_me:$LINENO: checking for LPFN_ACCEPT support in winsock2.h" >&5 echo $ECHO_N "checking for LPFN_ACCEPT support in winsock2.h... $ECHO_C" >&6 if test "${tcl_cv_lpfn_decls+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define WIN32_LEAN_AND_MEAN |
︙ | ︙ | |||
2573 2574 2575 2576 2577 2578 2579 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | | | 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 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_lpfn_decls=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_lpfn_decls=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_lpfn_decls" >&5 echo "${ECHO_T}$tcl_cv_lpfn_decls" >&6 if test "$tcl_cv_lpfn_decls" = "no" ; then cat >>confdefs.h <<\_ACEOF |
︙ | ︙ | |||
2613 2614 2615 2616 2617 2618 2619 | echo "$as_me:$LINENO: checking for winnt.h that ignores VOID define" >&5 echo $ECHO_N "checking for winnt.h that ignores VOID define... $ECHO_C" >&6 if test "${tcl_cv_winnt_ignore_void+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 | echo "$as_me:$LINENO: checking for winnt.h that ignores VOID define" >&5 echo $ECHO_N "checking for winnt.h that ignores VOID define... $ECHO_C" >&6 if test "${tcl_cv_winnt_ignore_void+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define VOID void |
︙ | ︙ | |||
2639 2640 2641 2642 2643 2644 2645 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | | | 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 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_winnt_ignore_void=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_winnt_ignore_void=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_winnt_ignore_void" >&5 echo "${ECHO_T}$tcl_cv_winnt_ignore_void" >&6 if test "$tcl_cv_winnt_ignore_void" = "yes" ; then cat >>confdefs.h <<\_ACEOF |
︙ | ︙ | |||
2685 2686 2687 2688 2689 2690 2691 | echo "$as_me:$LINENO: checking for alloca declaration in malloc.h" >&5 echo $ECHO_N "checking for alloca declaration in malloc.h... $ECHO_C" >&6 if test "${tcl_cv_malloc_decl_alloca+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 | echo "$as_me:$LINENO: checking for alloca declaration in malloc.h" >&5 echo $ECHO_N "checking for alloca declaration in malloc.h... $ECHO_C" >&6 if test "${tcl_cv_malloc_decl_alloca+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <malloc.h> |
︙ | ︙ | |||
2709 2710 2711 2712 2713 2714 2715 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | | | 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 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_malloc_decl_alloca=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_malloc_decl_alloca=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_malloc_decl_alloca" >&5 echo "${ECHO_T}$tcl_cv_malloc_decl_alloca" >&6 if test "$tcl_cv_malloc_decl_alloca" = "no" && test "${GCC}" = "yes" ; then |
︙ | ︙ | |||
2750 2751 2752 2753 2754 2755 2756 | echo "$as_me:$LINENO: checking for cast to union support" >&5 echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6 if test "${tcl_cv_cast_to_union+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | | 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 | echo "$as_me:$LINENO: checking for cast to union support" >&5 echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6 if test "${tcl_cv_cast_to_union+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { union foo { int i; double d; }; union foo f = (union foo) (int) 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_cast_to_union=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_cast_to_union=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5 echo "${ECHO_T}$tcl_cv_cast_to_union" >&6 if test "$tcl_cv_cast_to_union" = "yes"; then cat >>confdefs.h <<\_ACEOF |
︙ | ︙ | |||
2811 2812 2813 2814 2815 2816 2817 | echo "$as_me:$LINENO: checking for FINDEX_INFO_LEVELS in winbase.h" >&5 echo $ECHO_N "checking for FINDEX_INFO_LEVELS in winbase.h... $ECHO_C" >&6 if test "${tcl_cv_findex_enums+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 | echo "$as_me:$LINENO: checking for FINDEX_INFO_LEVELS in winbase.h" >&5 echo $ECHO_N "checking for FINDEX_INFO_LEVELS in winbase.h... $ECHO_C" >&6 if test "${tcl_cv_findex_enums+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define WIN32_LEAN_AND_MEAN |
︙ | ︙ | |||
2835 2836 2837 2838 2839 2840 2841 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | | | 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 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_findex_enums=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_findex_enums=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5 echo "${ECHO_T}$tcl_cv_findex_enums" >&6 if test "$tcl_cv_findex_enums" = "no"; then cat >>confdefs.h <<\_ACEOF |
︙ | ︙ | |||
2874 2875 2876 2877 2878 2879 2880 | echo "$as_me:$LINENO: checking for MWMO_ALERTABLE in winuser.h" >&5 echo $ECHO_N "checking for MWMO_ALERTABLE in winuser.h... $ECHO_C" >&6 if test "${tcl_cv_mwmo_alertable+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 | echo "$as_me:$LINENO: checking for MWMO_ALERTABLE in winuser.h" >&5 echo $ECHO_N "checking for MWMO_ALERTABLE in winuser.h... $ECHO_C" >&6 if test "${tcl_cv_mwmo_alertable+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define WIN32_LEAN_AND_MEAN |
︙ | ︙ | |||
2897 2898 2899 2900 2901 2902 2903 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 | | > > > > > > > > > > | | | 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 | ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_mwmo_alertable=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_mwmo_alertable=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_mwmo_alertable" >&5 echo "${ECHO_T}$tcl_cv_mwmo_alertable" >&6 if test "$tcl_cv_mwmo_alertable" = "no"; then cat >>confdefs.h <<\_ACEOF |
︙ | ︙ | |||
2963 2964 2965 2966 2967 2968 2969 | # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention cat >>confdefs.h <<\_ACEOF #define USE_THREAD_ALLOC 1 _ACEOF | < < < < < < | 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 | # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention cat >>confdefs.h <<\_ACEOF #define USE_THREAD_ALLOC 1 _ACEOF else TCL_THREADS=0 echo "$as_me:$LINENO: result: no (default)" >&5 echo "${ECHO_T}no (default)" >&6 fi |
︙ | ︙ | |||
3156 3157 3158 3159 3160 3161 3162 | if test "$do64bit" = "yes" ; then { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on Windows\"" >&5 echo "$as_me: WARNING: \"64bit mode not supported with GCC on Windows\"" >&2;} fi SHLIB_LD="" SHLIB_LD_LIBS="" LIBS="" | | | 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 | if test "$do64bit" = "yes" ; then { echo "$as_me:$LINENO: WARNING: \"64bit mode not supported with GCC on Windows\"" >&5 echo "$as_me: WARNING: \"64bit mode not supported with GCC on Windows\"" >&2;} fi SHLIB_LD="" SHLIB_LD_LIBS="" LIBS="" LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -lole32 -loleaut32 -luuid" STLIB_LD='${AR} cr' RC_OUT=-o RC_TYPE= RC_INCLUDE=--include RC_DEFINE=--define RES=res.o MAKE_LIB="\${STLIB_LD} \$@" |
︙ | ︙ | |||
3241 3242 3243 3244 3245 3246 3247 | # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" SHLIB_SUFFIX=.dll EXTRA_CFLAGS="${extra_cflags}" CFLAGS_DEBUG=-g | | | 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 | # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" SHLIB_SUFFIX=.dll EXTRA_CFLAGS="${extra_cflags}" CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" CFLAGS_WARNING="-Wall -Wconversion" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= # Specify the CC output file names based on the target name CC_OBJNAME="-o \$@" CC_EXENAME="-o \$@" |
︙ | ︙ | |||
3301 3302 3303 3304 3305 3306 3307 | # This is a 2-stage check to make sure we have the 64-bit SDK # We have to know where the SDK is installed. if test "$do64bit" = "yes" ; then if test "x${MSSDK}x" = "xx" ; then MSSDK="C:/Progra~1/Microsoft SDK" fi | < < | > > > | | | | | | > | | | < | > > > | | | < | > > > | | | 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 | # This is a 2-stage check to make sure we have the 64-bit SDK # We have to know where the SDK is installed. if test "$do64bit" = "yes" ; then if test "x${MSSDK}x" = "xx" ; then MSSDK="C:/Progra~1/Microsoft SDK" fi MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'` if test ! -d "${MSSDK}/bin/win64" ; then { echo "$as_me:$LINENO: WARNING: \"could not find 64-bit SDK to enable 64bit mode\"" >&5 echo "$as_me: WARNING: \"could not find 64-bit SDK to enable 64bit mode\"" >&2;} do64bit="no" fi fi if test "$do64bit" = "yes" ; then # All this magic is necessary for the Win64 SDK RC1 - hobbs # The space-based-path will work for the Makefile, but will # not work if AC_TRY_COMPILE is called. TEA has the # TEA_PATH_NOSPACE to avoid this issue. CC="\"${MSSDK}/Bin/Win64/cl.exe\" \ -I\"${MSSDK}/Include/prerelease\" \ -I\"${MSSDK}/Include/Win64/crt\" \ -I\"${MSSDK}/Include/Win64/crt/sys\" \ -I\"${MSSDK}/Include\"" RC="\"${MSSDK}/bin/rc.exe\"" CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d" # Do not use -O2 for Win64 - this has proved buggy in code gen. CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}" lflags="-MACHINE:IA64 -LIBPATH:\"${MSSDK}/Lib/IA64\" \ -LIBPATH:\"${MSSDK}/Lib/Prerelease/IA64\" -nologo" LINKBIN="\"${MSSDK}/bin/win64/link.exe\"" else RC="rc" # -Od - no optimization # -WX - warnings as errors CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d" # -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy) CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" lflags="-nologo" LINKBIN="link" fi LIBS="user32.lib advapi32.lib" LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib" SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" # link -lib only works when -lib is the first arg STLIB_LD="${LINKBIN} -lib ${lflags}" RC_OUT=-fo RC_TYPE=-r RC_INCLUDE=-i RC_DEFINE=-d RES=res MAKE_LIB="\${STLIB_LD} -out:\$@" POST_MAKE_LIB= MAKE_EXE="\${CC} -Fe\$@" LIBPREFIX="" EXTRA_CFLAGS="" CFLAGS_WARNING="-W3" LDFLAGS_DEBUG="-debug:full" LDFLAGS_OPTIMIZE="-release" # Specify the CC output file names based on the target name CC_OBJNAME="-Fo\$@" CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\$@')\"" # Specify linker flags depending on the type of app being |
︙ | ︙ | |||
3482 3483 3484 3485 3486 3487 3488 | # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since # <limits.h> exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF | < | > < > | 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 | # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since # <limits.h> exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif Syntax error _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then : else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <ac_nonexistent.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then |
︙ | ︙ | |||
3589 3590 3591 3592 3593 3594 3595 | # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since # <limits.h> exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF | < | > < > | 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 | # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since # <limits.h> exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include <limits.h> #else # include <assert.h> #endif Syntax error _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then : else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <ac_nonexistent.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then |
︙ | ︙ | |||
3710 3711 3712 3713 3714 3715 3716 | echo "$as_me:$LINENO: checking for ANSI C header files" >&5 echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 if test "${ac_cv_header_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < | 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 | echo "$as_me:$LINENO: checking for ANSI C header files" >&5 echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 if test "${ac_cv_header_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <stdlib.h> #include <stdarg.h> #include <string.h> #include <float.h> int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_header_stdc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_stdc=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <string.h> |
︙ | ︙ | |||
3775 3776 3777 3778 3779 3780 3781 | 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 <<_ACEOF | < | 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 | 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 <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <stdlib.h> |
︙ | ︙ | |||
3800 3801 3802 3803 3804 3805 3806 | 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 <<_ACEOF | < | | | | | 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 | 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 <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <ctype.h> #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #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); } _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 |
︙ | ︙ | |||
3850 3851 3852 3853 3854 3855 3856 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_header_stdc=no fi | | | 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 | echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_header_stdc=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi fi echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 echo "${ECHO_T}$ac_cv_header_stdc" >&6 if test $ac_cv_header_stdc = yes; then |
︙ | ︙ | |||
3875 3876 3877 3878 3879 3880 3881 | for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ | | < | > > > > > > > > > > | | | 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 | for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_Header=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_Header=no" fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF |
︙ | ︙ | |||
3940 3941 3942 3943 3944 3945 3946 | echo "$as_me:$LINENO: result: $ac_cv_header_errno_h" >&5 echo "${ECHO_T}$ac_cv_header_errno_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking errno.h usability" >&5 echo $ECHO_N "checking errno.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF | < | > > > > > > > > > > | | < > | | | | < < < < < < < < > | > > | | > > > > | | | | 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 | echo "$as_me:$LINENO: result: $ac_cv_header_errno_h" >&5 echo "${ECHO_T}$ac_cv_header_errno_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking errno.h usability" >&5 echo $ECHO_N "checking errno.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <errno.h> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking errno.h presence" >&5 echo $ECHO_N "checking errno.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <errno.h> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: errno.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: errno.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: errno.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: errno.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: errno.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: errno.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: errno.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: errno.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: errno.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: errno.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------ ## ## Report this to the AC_PACKAGE_NAME lists. ## ## ------------------------------------------ ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for errno.h" >&5 echo $ECHO_N "checking for errno.h... $ECHO_C" >&6 |
︙ | ︙ | |||
4259 4260 4261 4262 4263 4264 4265 | { (set) 2>&1 | case `(ac_space=' '; set | grep ac_space) 2>&1` in *ac_space=\ *) # `set' does not quote correctly, so add quotes (double-quote # substitution turns \\\\ into \\, and sed turns \\ into \). sed -n \ | | | | | 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 | { (set) 2>&1 | case `(ac_space=' '; set | grep ac_space) 2>&1` in *ac_space=\ *) # `set' does not quote correctly, so add quotes (double-quote # substitution turns \\\\ into \\, and sed turns \\ into \). sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n \ "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } | sed ' t clear : clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ |
︙ | ︙ | |||
4295 4296 4297 4298 4299 4300 4301 | test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # VPATH may cause trouble with some makes, so we remove $(srcdir), # ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then | | | | | | | | 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 | test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # VPATH may cause trouble with some makes, so we remove $(srcdir), # ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=/{ s/:*\$(srcdir):*/:/; s/:*\${srcdir}:*/:/; s/:*@srcdir@:*/:/; s/^\([^=]*=[ ]*\):*/\1/; s/:*$//; s/^[^=]*=[ ]*$//; }' fi # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then we branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. cat >confdef2opt.sed <<\_ACEOF t clear : clear s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g t quote s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g t quote d : quote s,[ `~#$^&*(){}\\|;'"<>?],\\&,g s,\[,\\&,g s,\],\\&,g s,\$,$$,g p _ACEOF # We use echo to avoid assuming a particular line-breaking character. # The extra dot is to prevent the shell from consuming trailing |
︙ | ︙ | |||
4343 4344 4345 4346 4347 4348 4349 | ac_libobjs= ac_ltlibobjs= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_i=`echo "$ac_i" | | | | 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 | ac_libobjs= ac_ltlibobjs= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_i=`echo "$ac_i" | sed 's/\$U\././;s/\.o$//;s/\.obj$//'` # 2. Add them. ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext" ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs |
︙ | ︙ | |||
4387 4388 4389 4390 4391 4392 4393 4394 4395 | NULLCMD=: # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi # Support unset when possible. | > | | | 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 | NULLCMD=: # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # Work around bugs in pre-3.0 UWIN ksh. $as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done # Required to use basename. |
︙ | ︙ | |||
4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 | as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. | > | | | 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 | as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' ' IFS=" $as_nl" |
︙ | ︙ | |||
4623 4624 4625 4626 4627 4628 4629 | sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX } >&5 cat >&5 <<_CSEOF This file was extended by $as_me, which was | | | 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 | sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX } >&5 cat >&5 <<_CSEOF This file was extended by $as_me, which was generated by GNU Autoconf 2.59. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ |
︙ | ︙ | |||
4667 4668 4669 4670 4671 4672 4673 | -h, --help print this help, then exit -V, --version print version number, then exit -q, --quiet do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] | | | < | | 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 | -h, --help print this help, then exit -V, --version print version number, then exit -q, --quiet do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to <[email protected]>." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.59, with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" Copyright (C) 2003 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." srcdir=$srcdir _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF # If no file are specified by the user, then we need to provide default |
︙ | ︙ | |||
4985 4986 4987 4988 4989 4990 4991 | # The purpose of the label and of the branching condition is to # speed up the sed processing (if there are no `@' at all, there # is no need to browse any of the substitutions). # These are the two extra sed commands mentioned above. (echo ':t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed if test -z "$ac_sed_cmds"; then | | | | | | | | | | | | | | | | 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 | # The purpose of the label and of the branching condition is to # speed up the sed processing (if there are no `@' at all, there # is no need to browse any of the substitutions). # These are the two extra sed commands mentioned above. (echo ':t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed if test -z "$ac_sed_cmds"; then ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" else ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" fi ac_sed_frag=`expr $ac_sed_frag + 1` ac_beg=$ac_end ac_end=`expr $ac_end + $ac_max_sed_lines` fi done if test -z "$ac_sed_cmds"; then ac_sed_cmds=cat fi fi # test -n "$CONFIG_FILES" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". case $ac_file in - | *:- | *:-:* ) # input from stdin cat >$tmp/stdin ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; * ) ac_file_in=$ac_file.in ;; esac # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. ac_dir=`(dirname "$ac_file") 2>/dev/null || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` { if $as_mkdir_p; then mkdir -p "$ac_dir" else as_dir="$ac_dir" as_dirs= while test ! -d "$as_dir"; do as_dirs="$as_dir $as_dirs" as_dir=`(dirname "$as_dir") 2>/dev/null || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` done |
︙ | ︙ | |||
5076 5077 5078 5079 5080 5081 5082 | [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac | | | > > > > > | > > > > > > > | > > > > > > | > > > > > > > > > > | > > > > > | | | | | | | | | | | | | | | 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 | [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac # Do not use `cd foo && pwd` to compute absolute paths, because # the directories may not exist. case `pwd` in .) ac_abs_builddir="$ac_dir";; *) case "$ac_dir" in .) ac_abs_builddir=`pwd`;; [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; *) ac_abs_builddir=`pwd`/"$ac_dir";; esac;; esac case $ac_abs_builddir in .) ac_abs_top_builddir=${ac_top_builddir}.;; *) case ${ac_top_builddir}. in .) ac_abs_top_builddir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; esac;; esac case $ac_abs_builddir in .) ac_abs_srcdir=$ac_srcdir;; *) case $ac_srcdir in .) ac_abs_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; esac;; esac case $ac_abs_builddir in .) ac_abs_top_srcdir=$ac_top_srcdir;; *) case $ac_top_srcdir in .) ac_abs_top_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; esac;; esac if test x"$ac_file" != x-; then { echo "$as_me:$LINENO: creating $ac_file" >&5 echo "$as_me: creating $ac_file" >&6;} rm -f "$ac_file" fi # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ if test x"$ac_file" = x-; then configure_input= else configure_input="$ac_file. " fi configure_input=$configure_input"Generated from `echo $ac_file_in | sed 's,.*/,,'` by configure." # First look for the input files in the build tree, otherwise in the # src tree. ac_file_inputs=`IFS=: for f in $ac_file_in; do case $f in -) echo $tmp/stdin ;; [\\/$]*) # Absolute (can't be DOS-style, as IFS=:) test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 echo "$as_me: error: cannot find input file: $f" >&2;} { (exit 1); exit 1; }; } echo "$f";; *) # Relative if test -f "$f"; then # Build tree echo "$f" elif test -f "$srcdir/$f"; then # Source tree echo "$srcdir/$f" else # /dev/null tree { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 echo "$as_me: error: cannot find input file: $f" >&2;} { (exit 1); exit 1; }; } fi;; esac done` || { (exit 1); exit 1; } _ACEOF cat >>$CONFIG_STATUS <<_ACEOF sed "$ac_vpsub $extrasub _ACEOF |
︙ | ︙ |
Changes to win/configure.in.
1 2 3 4 5 | #! /bin/bash -norc # This file is an input file used by the GNU "autoconf" program to # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. # | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | #! /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.81.2.5 2005/08/25 15:47:07 dgp Exp $ AC_INIT(../generic/tcl.h) AC_PREREQ(2.59) # The following define is needed when building with Cygwin since newer # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 TCL_PATCH_LEVEL="a4" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=3 TCL_DDE_PATCH_LEVEL="" DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION |
︙ | ︙ |
Changes to win/makefile.bc.
︙ | ︙ | |||
452 453 454 455 456 457 458 | -@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)" -@copy "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)" | < | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 | -@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)" -@copy "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)" -@copy "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)" |
︙ | ︙ |
Changes to win/makefile.vc.
1 2 3 4 5 6 7 8 9 10 | #------------------------------------------------------------------------------ # makefile.vc -- # # Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. | | | > > | | | > | | | | > | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | #------------------------------------------------------------------------------ # makefile.vc -- # # Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001-2005 ActiveState Corporation. # Copyright (c) 2001-2004 David Gravereaux. # #------------------------------------------------------------------------------ # RCS: @(#) $Id: makefile.vc,v 1.135.2.11 2005/09/23 16:47:35 dgp Exp $ #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) # or with the MS Platform SDK (MSSDK) !if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(MSSDK) MSG = ^ You need to run vcvars32.bat from Developer Studio or setenv.bat from the^ Platform SDK first to setup the environment. Jump to this line to read^ the build instructions. !error $(MSG) !endif #------------------------------------------------------------------------------ # HOW TO USE this makefile: # # 1) It is now necessary to have MSVCDir, MSDevDir or MSSDK set in the # environment. This is used as a check to see if vcvars32.bat had been # run prior to running nmake or during the installation of Microsoft # Visual C++, MSVCDir had been set globally and the PATH adjusted. # Either way is valid. # # You'll need to run vcvars32.bat contained in the MsDev's vc(98)/bin # directory to setup the proper environment, if needed, for your # current setup. This is a needed bootstrap requirement and allows the # swapping of different environments to be easier. # # 2) To use the Platform SDK (not expressly needed), run setenv.bat after # vcvars32.bat according to the instructions for it. This can also # turn on the 64-bit compiler, if your SDK has it. # # 3) Targets are: # release -- Builds the core, the shell and the dlls. (default) # dlls -- Just builds the windows extensions and the 16-bit DOS # pipe/thunk helper app. # shell -- Just builds the shell and the core. # core -- Only builds the core [tclXX.(dll|lib)]. |
︙ | ︙ | |||
276 277 278 279 280 281 282 283 284 285 286 287 288 289 | $(TMP_DIR)\tclIndexObj.obj \ $(TMP_DIR)\tclInterp.obj \ $(TMP_DIR)\tclIO.obj \ $(TMP_DIR)\tclIOCmd.obj \ $(TMP_DIR)\tclIOGT.obj \ $(TMP_DIR)\tclIOSock.obj \ $(TMP_DIR)\tclIOUtil.obj \ $(TMP_DIR)\tclLink.obj \ $(TMP_DIR)\tclListObj.obj \ $(TMP_DIR)\tclLiteral.obj \ $(TMP_DIR)\tclLoad.obj \ $(TMP_DIR)\tclMain.obj \ $(TMP_DIR)\tclNamesp.obj \ $(TMP_DIR)\tclNotify.obj \ | > | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 | $(TMP_DIR)\tclIndexObj.obj \ $(TMP_DIR)\tclInterp.obj \ $(TMP_DIR)\tclIO.obj \ $(TMP_DIR)\tclIOCmd.obj \ $(TMP_DIR)\tclIOGT.obj \ $(TMP_DIR)\tclIOSock.obj \ $(TMP_DIR)\tclIOUtil.obj \ $(TMP_DIR)\tclIORChan.obj \ $(TMP_DIR)\tclLink.obj \ $(TMP_DIR)\tclListObj.obj \ $(TMP_DIR)\tclLiteral.obj \ $(TMP_DIR)\tclLoad.obj \ $(TMP_DIR)\tclMain.obj \ $(TMP_DIR)\tclNamesp.obj \ $(TMP_DIR)\tclNotify.obj \ |
︙ | ︙ | |||
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 | $(TMP_DIR)\tclPreserve.obj \ $(TMP_DIR)\tclProc.obj \ $(TMP_DIR)\tclRegexp.obj \ $(TMP_DIR)\tclResolve.obj \ $(TMP_DIR)\tclResult.obj \ $(TMP_DIR)\tclScan.obj \ $(TMP_DIR)\tclStringObj.obj \ $(TMP_DIR)\tclStubInit.obj \ $(TMP_DIR)\tclStubLib.obj \ $(TMP_DIR)\tclThread.obj \ $(TMP_DIR)\tclThreadAlloc.obj \ $(TMP_DIR)\tclThreadJoin.obj \ $(TMP_DIR)\tclThreadStorage.obj \ $(TMP_DIR)\tclTimer.obj \ $(TMP_DIR)\tclTrace.obj \ $(TMP_DIR)\tclUtf.obj \ $(TMP_DIR)\tclUtil.obj \ $(TMP_DIR)\tclVar.obj \ $(TMP_DIR)\tclWin32Dll.obj \ $(TMP_DIR)\tclWinChan.obj \ $(TMP_DIR)\tclWinConsole.obj \ $(TMP_DIR)\tclWinSerial.obj \ $(TMP_DIR)\tclWinError.obj \ $(TMP_DIR)\tclWinFCmd.obj \ $(TMP_DIR)\tclWinFile.obj \ $(TMP_DIR)\tclWinInit.obj \ $(TMP_DIR)\tclWinLoad.obj \ $(TMP_DIR)\tclWinNotify.obj \ $(TMP_DIR)\tclWinPipe.obj \ $(TMP_DIR)\tclWinSock.obj \ $(TMP_DIR)\tclWinThrd.obj \ $(TMP_DIR)\tclWinTime.obj \ !if !$(STATIC_BUILD) $(TMP_DIR)\tcl.res !endif TCLSTUBOBJS = $(TMP_DIR)\tclStubLib.obj ### The following paths CANNOT have spaces in them. COMPATDIR = $(ROOT)\compat DOCDIR = $(ROOT)\doc GENERICDIR = $(ROOT)\generic TOOLSDIR = $(ROOT)\tools WINDIR = $(ROOT)\win #--------------------------------------------------------------------- # Compile flags #--------------------------------------------------------------------- | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | $(TMP_DIR)\tclPreserve.obj \ $(TMP_DIR)\tclProc.obj \ $(TMP_DIR)\tclRegexp.obj \ $(TMP_DIR)\tclResolve.obj \ $(TMP_DIR)\tclResult.obj \ $(TMP_DIR)\tclScan.obj \ $(TMP_DIR)\tclStringObj.obj \ $(TMP_DIR)\tclStrToD.obj \ $(TMP_DIR)\tclStubInit.obj \ $(TMP_DIR)\tclStubLib.obj \ $(TMP_DIR)\tclThread.obj \ $(TMP_DIR)\tclThreadAlloc.obj \ $(TMP_DIR)\tclThreadJoin.obj \ $(TMP_DIR)\tclThreadStorage.obj \ $(TMP_DIR)\tclTimer.obj \ $(TMP_DIR)\tclTomMathInterface.obj \ $(TMP_DIR)\tclTrace.obj \ $(TMP_DIR)\tclUtf.obj \ $(TMP_DIR)\tclUtil.obj \ $(TMP_DIR)\tclVar.obj \ $(TMP_DIR)\tclWin32Dll.obj \ $(TMP_DIR)\tclWinChan.obj \ $(TMP_DIR)\tclWinConsole.obj \ $(TMP_DIR)\tclWinSerial.obj \ $(TMP_DIR)\tclWinError.obj \ $(TMP_DIR)\tclWinFCmd.obj \ $(TMP_DIR)\tclWinFile.obj \ $(TMP_DIR)\tclWinInit.obj \ $(TMP_DIR)\tclWinLoad.obj \ $(TMP_DIR)\tclWinNotify.obj \ $(TMP_DIR)\tclWinPipe.obj \ $(TMP_DIR)\tclWinSock.obj \ $(TMP_DIR)\tclWinThrd.obj \ $(TMP_DIR)\tclWinTime.obj \ $(TMP_DIR)\bncore.obj \ $(TMP_DIR)\bn_reverse.obj \ $(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \ $(TMP_DIR)\bn_fast_s_mp_sqr.obj \ $(TMP_DIR)\bn_mp_add.obj \ $(TMP_DIR)\bn_mp_add_d.obj \ $(TMP_DIR)\bn_mp_and.obj \ $(TMP_DIR)\bn_mp_clamp.obj \ $(TMP_DIR)\bn_mp_clear.obj \ $(TMP_DIR)\bn_mp_clear_multi.obj \ $(TMP_DIR)\bn_mp_cmp.obj \ $(TMP_DIR)\bn_mp_cmp_d.obj \ $(TMP_DIR)\bn_mp_cmp_mag.obj \ $(TMP_DIR)\bn_mp_copy.obj \ $(TMP_DIR)\bn_mp_count_bits.obj \ $(TMP_DIR)\bn_mp_div.obj \ $(TMP_DIR)\bn_mp_div_d.obj \ $(TMP_DIR)\bn_mp_div_2.obj \ $(TMP_DIR)\bn_mp_div_2d.obj \ $(TMP_DIR)\bn_mp_div_3.obj \ $(TMP_DIR)\bn_mp_exch.obj \ $(TMP_DIR)\bn_mp_expt_d.obj \ $(TMP_DIR)\bn_mp_grow.obj \ $(TMP_DIR)\bn_mp_init.obj \ $(TMP_DIR)\bn_mp_init_copy.obj \ $(TMP_DIR)\bn_mp_init_multi.obj \ $(TMP_DIR)\bn_mp_init_set.obj \ $(TMP_DIR)\bn_mp_init_size.obj \ $(TMP_DIR)\bn_mp_karatsuba_mul.obj \ $(TMP_DIR)\bn_mp_karatsuba_sqr.obj \ $(TMP_DIR)\bn_mp_lshd.obj \ $(TMP_DIR)\bn_mp_mod.obj \ $(TMP_DIR)\bn_mp_mod_2d.obj \ $(TMP_DIR)\bn_mp_mul.obj \ $(TMP_DIR)\bn_mp_mul_2.obj \ $(TMP_DIR)\bn_mp_mul_2d.obj \ $(TMP_DIR)\bn_mp_mul_d.obj \ $(TMP_DIR)\bn_mp_neg.obj \ $(TMP_DIR)\bn_mp_or.obj \ $(TMP_DIR)\bn_mp_radix_size.obj \ $(TMP_DIR)\bn_mp_radix_smap.obj \ $(TMP_DIR)\bn_mp_read_radix.obj \ $(TMP_DIR)\bn_mp_rshd.obj \ $(TMP_DIR)\bn_mp_set.obj \ $(TMP_DIR)\bn_mp_shrink.obj \ $(TMP_DIR)\bn_mp_sqr.obj \ $(TMP_DIR)\bn_mp_sqrt.obj \ $(TMP_DIR)\bn_mp_sub.obj \ $(TMP_DIR)\bn_mp_sub_d.obj \ $(TMP_DIR)\bn_mp_to_unsigned_bin.obj \ $(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \ $(TMP_DIR)\bn_mp_toom_mul.obj \ $(TMP_DIR)\bn_mp_toom_sqr.obj \ $(TMP_DIR)\bn_mp_toradix_n.obj \ $(TMP_DIR)\bn_mp_unsigned_bin_size.obj \ $(TMP_DIR)\bn_mp_xor.obj \ $(TMP_DIR)\bn_mp_zero.obj \ $(TMP_DIR)\bn_s_mp_add.obj \ $(TMP_DIR)\bn_s_mp_mul_digs.obj \ $(TMP_DIR)\bn_s_mp_sqr.obj \ $(TMP_DIR)\bn_s_mp_sub.obj \ !if !$(STATIC_BUILD) $(TMP_DIR)\tcl.res !endif TCLSTUBOBJS = $(TMP_DIR)\tclStubLib.obj ### The following paths CANNOT have spaces in them. COMPATDIR = $(ROOT)\compat DOCDIR = $(ROOT)\doc GENERICDIR = $(ROOT)\generic TOMMATHDIR = $(ROOT)\libtommath TOOLSDIR = $(ROOT)\tools WINDIR = $(ROOT)\win #--------------------------------------------------------------------- # Compile flags #--------------------------------------------------------------------- |
︙ | ︙ | |||
388 389 390 391 392 393 394 | !if $(DEBUG) && !$(UNCHECKED) crt = -MTd !else crt = -MT !endif !endif | | | > | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 | !if $(DEBUG) && !$(UNCHECKED) crt = -MTd !else crt = -MT !endif !endif TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" -I"$(TOMMATHDIR)" BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) \ -DTCL_PIPE_DLL=\"$(TCLPIPEDLLNAME)\" -DTCL_TOMMATH \ -DMP_PREC=4 CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE TCL_CFLAGS = $(BASE_CFLAGS) $(OPTDEFINES) STUB_CFLAGS = $(cflags) $(cdebug) $(OPTDEFINES) #--------------------------------------------------------------------- # Link flags |
︙ | ︙ | |||
831 832 833 834 835 836 837 838 839 840 841 842 843 844 | # Implicit rules #--------------------------------------------------------------------- {$(WINDIR)}.c{$(TMP_DIR)}.obj:: $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< $< << {$(GENERICDIR)}.c{$(TMP_DIR)}.obj:: $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< $< << {$(COMPATDIR)}.c{$(TMP_DIR)}.obj:: | > > > > > | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 | # Implicit rules #--------------------------------------------------------------------- {$(WINDIR)}.c{$(TMP_DIR)}.obj:: $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< $< << {$(TOMMATHDIR)}.c{$(TMP_DIR)}.obj:: $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< $< << {$(GENERICDIR)}.c{$(TMP_DIR)}.obj:: $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< $< << {$(COMPATDIR)}.c{$(TMP_DIR)}.obj:: |
︙ | ︙ | |||
920 921 922 923 924 925 926 | @$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\clock.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\tm.tcl" "$(SCRIPT_INSTALL_DIR)\" | < | 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 | @$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\clock.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\tm.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)\" |
︙ | ︙ |
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-2003 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-2003 David Gravereaux. # #------------------------------------------------------------------------------ # RCS: @(#) $Id: rules.vc,v 1.19.2.3 2005/08/15 18:14:15 dgp Exp $ #------------------------------------------------------------------------------ !ifndef _RULES_VC _RULES_VC = 1 cc32 = $(CC) # built-in default. link32 = link |
︙ | ︙ | |||
175 176 177 178 179 180 181 | !endif !if [nmakehlp -f $(OPTS) "thrdalloc"] !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 !else USE_THREAD_ALLOC = 0 !endif | < < < < < < | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 | !endif !if [nmakehlp -f $(OPTS) "thrdalloc"] !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 !else USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "unchecked"] !message *** Doing unchecked UNCHECKED = 1 !else UNCHECKED = 0 !endif !endif |
︙ | ︙ | |||
325 326 327 328 329 330 331 | OPTDEFINES = $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS !endif !if $(TCL_THREADS) OPTDEFINES = $(OPTDEFINES) -DTCL_THREADS=1 !if $(USE_THREAD_ALLOC) OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_ALLOC=1 !endif | < < < | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 | OPTDEFINES = $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS !endif !if $(TCL_THREADS) OPTDEFINES = $(OPTDEFINES) -DTCL_THREADS=1 !if $(USE_THREAD_ALLOC) OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_ALLOC=1 !endif !endif !if $(STATIC_BUILD) OPTDEFINES = $(OPTDEFINES) -DSTATIC_BUILD !endif !if $(TCL_NO_DEPRECATED) OPTDEFINES = $(OPTDEFINES) -DTCL_NO_DEPRECATED !endif |
︙ | ︙ |
Changes to win/tcl.m4.
︙ | ︙ | |||
253 254 255 256 257 258 259 | if test "$tcl_ok" = "yes"; then AC_MSG_RESULT(yes) TCL_THREADS=1 AC_DEFINE(TCL_THREADS) # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention AC_DEFINE(USE_THREAD_ALLOC) | < < < | 253 254 255 256 257 258 259 260 261 262 263 264 265 266 | if test "$tcl_ok" = "yes"; then AC_MSG_RESULT(yes) TCL_THREADS=1 AC_DEFINE(TCL_THREADS) # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention AC_DEFINE(USE_THREAD_ALLOC) else TCL_THREADS=0 AC_MSG_RESULT([no (default)]) fi AC_SUBST(TCL_THREADS) ]) |
︙ | ︙ | |||
435 436 437 438 439 440 441 | if test "${GCC}" = "yes" ; then if test "$do64bit" = "yes" ; then AC_MSG_WARN("64bit mode not supported with GCC on Windows") fi SHLIB_LD="" SHLIB_LD_LIBS="" LIBS="" | | | 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 | if test "${GCC}" = "yes" ; then if test "$do64bit" = "yes" ; then AC_MSG_WARN("64bit mode not supported with GCC on Windows") fi SHLIB_LD="" SHLIB_LD_LIBS="" LIBS="" LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -lole32 -loleaut32 -luuid" STLIB_LD='${AR} cr' RC_OUT=-o RC_TYPE= RC_INCLUDE=--include RC_DEFINE=--define RES=res.o MAKE_LIB="\${STLIB_LD} \[$]@" |
︙ | ︙ | |||
515 516 517 518 519 520 521 | # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" SHLIB_SUFFIX=.dll EXTRA_CFLAGS="${extra_cflags}" CFLAGS_DEBUG=-g | | | 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 | # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" SHLIB_SUFFIX=.dll EXTRA_CFLAGS="${extra_cflags}" CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" CFLAGS_WARNING="-Wall -Wconversion" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= # Specify the CC output file names based on the target name CC_OBJNAME="-o \[$]@" CC_EXENAME="-o \[$]@" |
︙ | ︙ | |||
573 574 575 576 577 578 579 | # This is a 2-stage check to make sure we have the 64-bit SDK # We have to know where the SDK is installed. if test "$do64bit" = "yes" ; then if test "x${MSSDK}x" = "xx" ; then MSSDK="C:/Progra~1/Microsoft SDK" fi | < < | > > > | | | | | | > | | | < | > > > | | | < | > > > | | | 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 | # This is a 2-stage check to make sure we have the 64-bit SDK # We have to know where the SDK is installed. if test "$do64bit" = "yes" ; then if test "x${MSSDK}x" = "xx" ; then MSSDK="C:/Progra~1/Microsoft SDK" fi MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'` if test ! -d "${MSSDK}/bin/win64" ; then AC_MSG_WARN("could not find 64-bit SDK to enable 64bit mode") do64bit="no" fi fi if test "$do64bit" = "yes" ; then # All this magic is necessary for the Win64 SDK RC1 - hobbs # The space-based-path will work for the Makefile, but will # not work if AC_TRY_COMPILE is called. TEA has the # TEA_PATH_NOSPACE to avoid this issue. CC="\"${MSSDK}/Bin/Win64/cl.exe\" \ -I\"${MSSDK}/Include/prerelease\" \ -I\"${MSSDK}/Include/Win64/crt\" \ -I\"${MSSDK}/Include/Win64/crt/sys\" \ -I\"${MSSDK}/Include\"" RC="\"${MSSDK}/bin/rc.exe\"" CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d" # Do not use -O2 for Win64 - this has proved buggy in code gen. CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}" lflags="-MACHINE:IA64 -LIBPATH:\"${MSSDK}/Lib/IA64\" \ -LIBPATH:\"${MSSDK}/Lib/Prerelease/IA64\" -nologo" LINKBIN="\"${MSSDK}/bin/win64/link.exe\"" else RC="rc" # -Od - no optimization # -WX - warnings as errors CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d" # -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy) CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" lflags="-nologo" LINKBIN="link" fi LIBS="user32.lib advapi32.lib" LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib" SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" # link -lib only works when -lib is the first arg STLIB_LD="${LINKBIN} -lib ${lflags}" RC_OUT=-fo RC_TYPE=-r RC_INCLUDE=-i RC_DEFINE=-d RES=res MAKE_LIB="\${STLIB_LD} -out:\[$]@" POST_MAKE_LIB= MAKE_EXE="\${CC} -Fe\[$]@" LIBPREFIX="" EXTRA_CFLAGS="" CFLAGS_WARNING="-W3" LDFLAGS_DEBUG="-debug:full" LDFLAGS_OPTIMIZE="-release" # Specify the CC output file names based on the target name CC_OBJNAME="-Fo\[$]@" CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\[$]@')\"" # Specify linker flags depending on the type of app being |
︙ | ︙ | |||
680 681 682 683 684 685 686 | AC_MSG_ERROR(There is no Makefile in $TCL_BIN_DIR: perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?) else echo "building against Tcl binaries in: $TCL_BIN_DIR" fi AC_SUBST(TCL_BIN_DIR) ]) | < < < < | > > > > | | | < | | | | < | | < < > > > > > > > > > > > > > > > > > > > > > > > > | 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 | AC_MSG_ERROR(There is no Makefile in $TCL_BIN_DIR: perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?) else echo "building against Tcl binaries in: $TCL_BIN_DIR" fi AC_SUBST(TCL_BIN_DIR) ]) #------------------------------------------------------------------------ # SC_PROG_TCLSH # Locate a tclsh shell installed on the system path. This macro # will only find a Tcl shell that already exists on the system. # It will not find a Tcl shell in the Tcl build directory or # a Tcl shell that has been installed from the Tcl build directory. # If a Tcl shell can't be located on the PATH, then TCLSH_PROG will # be set to "". Extensions should take care not to create Makefile # rules that are run by default and depend on TCLSH_PROG. An # extension can't assume that an executable Tcl shell exists at # build time. # # Arguments # none # # Results # Subst's the following values: # TCLSH_PROG #------------------------------------------------------------------------ AC_DEFUN(SC_PROG_TCLSH, [ AC_MSG_CHECKING([for tclsh]) AC_CACHE_VAL(ac_cv_path_tclsh, [ search_path=`echo ${PATH} | sed -e 's/:/ /g'` for dir in $search_path ; do for j in `ls -r $dir/tclsh[[8-9]]*.exe 2> /dev/null` \ `ls -r $dir/tclsh* 2> /dev/null` ; do if test x"$ac_cv_path_tclsh" = x ; then if test -f "$j" ; then ac_cv_path_tclsh=$j break fi fi done done ]) if test -f "$ac_cv_path_tclsh" ; then TCLSH_PROG="$ac_cv_path_tclsh" AC_MSG_RESULT($TCLSH_PROG) else # It is not an error if an installed version of Tcl can't be located. TCLSH_PROG="" AC_MSG_RESULT([No tclsh found on PATH]) fi AC_SUBST(TCLSH_PROG) ]) #------------------------------------------------------------------------ # SC_BUILD_TCLSH # Determine the fully qualified path name of the tclsh executable # in the Tcl build directory. This macro will correctly determine # the name of the tclsh executable even if tclsh has not yet # been built in the build directory. The build tclsh must be used # when running tests from an extension build directory. It is not # correct to use the TCLSH_PROG in cases like this. # # Arguments # none # # Results # Subst's the following values: # BUILD_TCLSH #------------------------------------------------------------------------ AC_DEFUN(SC_BUILD_TCLSH, [ AC_MSG_CHECKING([for tclsh in Tcl build directory]) BUILD_TCLSH=${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT} AC_MSG_RESULT($BUILD_TCLSH) AC_SUBST(BUILD_TCLSH) ]) #-------------------------------------------------------------------- # SC_TCL_CFG_ENCODING TIP #59 # # Declare the encoding to use for embedded configuration information. # # Arguments: |
︙ | ︙ |
Changes to win/tclAppInit.c.
1 2 3 4 | /* * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit | | | | | | | | | | | | | | | | | | | 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 | /* * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit * function for Tcl applications (without Tk). Note that this program * must be built in Win32 console mode to work properly. * * Copyright (c) 1996-1997 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclAppInit.c,v 1.21.2.1 2005/08/02 18:17:00 dgp Exp $ */ #include "tcl.h" #include <windows.h> #include <locale.h> #ifdef TCL_TEST extern Tcl_PackageInitProc Procbodytest_Init; extern Tcl_PackageInitProc Procbodytest_SafeInit; extern Tcl_PackageInitProc Tcltest_Init; extern Tcl_PackageInitProc TclObjTest_Init; #endif /* TCL_TEST */ #if defined(__GNUC__) static void setargv(int *argcPtr, char ***argvPtr); #endif /* __GNUC__ */ static BOOL WINAPI sigHandler(DWORD fdwCtrlType); static Tcl_AsyncProc asyncExit; static void AppInitExitHandler(ClientData clientData); static Tcl_AsyncHandler exitToken = NULL; static DWORD exitErrorCode = 0; /* *---------------------------------------------------------------------- * * main -- * * This is the main program for the application. * * Results: * None: Tcl_Main never returns here, so this function never returns * either. * * Side effects: * Whatever the application does. * *---------------------------------------------------------------------- */ int main(int argc, char *argv[]) { /* * The following #if block allows you to change the AppInit function by * using a #define of TCL_LOCAL_APPINIT instead of rewriting this entire * file. The #if checks for that #define and uses Tcl_AppInit if it * doesn't exist. */ #ifndef TCL_LOCAL_APPINIT #define TCL_LOCAL_APPINIT Tcl_AppInit #endif extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp)); /* * The following #if block allows you to change how Tcl finds the startup * script, prime the library or encoding paths, fiddle with the argv, * etc., without needing to rewrite Tcl_Main() */ #ifdef TCL_LOCAL_MAIN_HOOK extern int TCL_LOCAL_MAIN_HOOK _ANSI_ARGS_((int *argc, char ***argv)); #endif char *p; /* * Set up the default locale to be standard "C" locale so parsing is * performed correctly. */ #if defined(__GNUC__) setargv( &argc, &argv ); #endif setlocale(LC_ALL, "C"); |
︙ | ︙ | |||
110 111 112 113 114 115 116 | } /* *---------------------------------------------------------------------- * * Tcl_AppInit -- * | | | | | | > | | > | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_AppInit -- * * This function performs application-specific initialization. Most * applications, especially those that incorporate additional packages, * will have their own version of this function. * * Results: * Returns a standard Tcl completion code, and leaves an error message in * the interp's result if an error occurs. * * Side effects: * Depends on the startup script. * *---------------------------------------------------------------------- */ int Tcl_AppInit(interp) Tcl_Interp *interp; /* Interpreter for application. */ { if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } /* * Install a signal handler to the win32 console tclsh is running in. */ SetConsoleCtrlHandler(sigHandler, TRUE); exitToken = Tcl_AsyncCreate(asyncExit, NULL); /* * This exit handler will be used to free the resources allocated in this * file. */ Tcl_CreateExitHandler(AppInitExitHandler, NULL); #ifdef TCL_TEST if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, NULL); if (TclObjTest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (Procbodytest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init, Procbodytest_SafeInit); #endif /* TCL_TEST */ #if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES { extern Tcl_PackageInitProc Registry_Init; extern Tcl_PackageInitProc Dde_Init; extern Tcl_PackageInitProc Dde_SafeInit; |
︙ | ︙ | |||
178 179 180 181 182 183 184 | return TCL_ERROR; } Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit); } #endif /* | | | | | | | | | | | | | | | > | | | | | | | | | | | 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 | return TCL_ERROR; } Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit); } #endif /* * Call the init functions for included packages. Each call should look * like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * where "Mod" is the name of the module. */ /* * Call Tcl_CreateCommand for application-specific commands, if they * weren't already created by the init functions called above. */ /* * Specify a user-specific startup file to invoke if the application is * run interactively. Typically the startup file is "~/.apprc" where "app" * is the name of the application. If this line is deleted then no * user-specific startup file will be run under any conditions. */ Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY); return TCL_OK; } /* *---------------------------------------------------------------------- * * AppInitExitHandler -- * * This function is called to cleanup the app init resources before Tcl * is unloaded. * * Results: * None. * * Side effects: * Frees the saved argv and deletes the async exit handler. * *---------------------------------------------------------------------- */ static void AppInitExitHandler( ClientData clientData) /* Not Used. */ { if (exitToken != NULL) { /* * This should be safe to do even if we are in an async exit right * now. */ Tcl_AsyncDelete(exitToken); exitToken = NULL; } } /* *------------------------------------------------------------------------- * * setargv -- * * Parse the Windows command line string into argc/argv. Done here * because we don't trust the builtin argument parser in crt0. Windows * applications are responsible for breaking their command line into * arguments. * * 2N backslashes + quote -> N backslashes + begin quoted string * 2N + 1 backslashes + quote -> literal * N backslashes + non-quote -> literal * quote + quote in a quoted string -> single quote * quote + quote not in quoted string -> empty string * quote -> begin quoted string * * Results: * Fills argcPtr with the number of arguments and argvPtr with the array * of arguments. * * Side effects: * Memory allocated. * *-------------------------------------------------------------------------- */ #if defined(__GNUC__) static void setargv(argcPtr, argvPtr) int *argcPtr; /* Filled with number of argument strings. */ char ***argvPtr; /* Filled with argument strings (malloc'd). */ { char *cmdLine, *p, *arg, *argSpace; char **argv; int argc, size, inquote, copy, slashes; cmdLine = GetCommandLine(); /* INTL: BUG */ /* * Precompute an overly pessimistic guess at the number of arguments in * the command line by counting non-space spans. */ size = 2; for (p = cmdLine; *p != '\0'; p++) { if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ size++; while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ |
︙ | ︙ | |||
324 325 326 327 328 329 330 | copy = 0; if ((inquote) && (p[1] == '"')) { p++; copy = 1; } else { inquote = !inquote; } | | | | | | | | | 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 | copy = 0; if ((inquote) && (p[1] == '"')) { p++; copy = 1; } else { inquote = !inquote; } } slashes >>= 1; } while (slashes) { *arg = '\\'; arg++; slashes--; } if ((*p == '\0') || (!inquote && ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */ break; } if (copy != 0) { *arg = *p; arg++; } p++; } *arg = '\0'; argSpace = arg + 1; } argv[argc] = NULL; *argcPtr = argc; *argvPtr = argv; |
︙ | ︙ | |||
371 372 373 374 375 376 377 | * Side effects: * tclsh cleanly exits. * *---------------------------------------------------------------------- */ int | | | | | | | | > | > | | < > | | | > > | > > > > > > > > > > | 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 | * Side effects: * tclsh cleanly exits. * *---------------------------------------------------------------------- */ int asyncExit( ClientData clientData, /* Not Used. */ Tcl_Interp *interp, /* interp in context, if any. */ int code) /* result of last command, if any. */ { Tcl_Exit((int)exitErrorCode); /* NOTREACHED */ return code; } /* *---------------------------------------------------------------------- * * sigHandler -- * * Signal handler for the Win32 OS. Catches Ctrl+C, Ctrl+Break and other * exits. This is needed so tclsh can do it's real clean-up and not an * unclean crash terminate. * * Results: * TRUE. * * Side effects: * Effects the way the app exits from a signal. This is an operating * system supplied thread and unsafe to call ANY Tcl commands except for * Tcl_AsyncMark. * *---------------------------------------------------------------------- */ BOOL WINAPI sigHandler( DWORD fdwCtrlType) /* One of the CTRL_*_EVENT constants. */ { HANDLE hStdIn; if (!exitToken) { /* * Async token must have been destroyed, punt gracefully. */ return FALSE; } /* * If Tcl is currently executing some bytecode or in the eventloop, this * will cause Tcl to enter asyncExit at the next command boundry. */ exitErrorCode = fdwCtrlType; Tcl_AsyncMark(exitToken); /* * This will cause Tcl_Gets in Tcl_Main() to drop-out with an <EOF> should * it be blocked on input and our Tcl_AsyncMark didn't grab the attention * of the interpreter. */ hStdIn = GetStdHandle(STD_INPUT_HANDLE); if (hStdIn) { CloseHandle(hStdIn); } /* * Indicate to the OS not to call the default terminator. */ return TRUE; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWin32Dll.c.
1 2 3 | /* * tclWin32Dll.c -- * | | > | | | | | | | | < < < < < < < < < | < < < | > | < < < > > | < | < | | < | < | < | < < < < < < | < | < > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | /* * tclWin32Dll.c -- * * This file contains the DLL entry point and other low-level bit bashing * code that needs inline assembly. * * 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.40.2.6 2005/08/02 18:17:00 dgp Exp $ */ #include "tclWinInt.h" /* * The following data structures are used when loading the thunking library * for execing child processes under Win32s. */ typedef DWORD (WINAPI UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined, LPVOID *lpTranslationList); typedef BOOL (WINAPI UTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL, LPCSTR InitName, LPCSTR ProcName, UT32PROC **ThirtyTwoBitThunk, FARPROC UT32Callback, LPVOID Buff); typedef VOID (WINAPI UTUNREGISTER)(HANDLE hModule); /* * The following variables keep track of information about this DLL on a * per-instance basis. Each time this DLL is loaded, it gets its own new data * segment with its own copy of all static and global information. */ static HINSTANCE hInstance; /* HINSTANCE of this DLL. */ static int platformId; /* Running under NT, or 95/98? */ #ifdef HAVE_NO_SEH /* * Unlike Borland and Microsoft, we don't register exception handlers by * pushing registration records onto the runtime stack. Instead, we register * them by creating an EXCEPTION_REGISTRATION within the activation record. */ typedef struct EXCEPTION_REGISTRATION { struct EXCEPTION_REGISTRATION *link; EXCEPTION_DISPOSITION (*handler)( struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); void *ebp; void *esp; int status; } EXCEPTION_REGISTRATION; #endif /* * VC++ 5.x has no 'cpuid' assembler instruction, so we must emulate it */ #if defined(_MSC_VER) && (_MSC_VER <= 1100) #define cpuid __asm __emit 0fh __asm __emit 0a2h #endif /* * The following function tables are used to dispatch to either the * wide-character or multi-byte versions of the operating system calls, * depending on whether the Unicode calls are available. */ |
︙ | ︙ | |||
123 124 125 126 127 128 129 130 131 | (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyA, (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA, (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA, (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, WCHAR *, TCHAR **)) SearchPathA, (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA, (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA, /* * The three NULL function pointers will only be set when | > | | | | > | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyA, (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA, (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA, (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, WCHAR *, TCHAR **)) SearchPathA, (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA, (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA, /* * The three NULL function pointers will only be set when * Tcl_FindExecutable is called. If you don't ever call that function, the * application will crash whenever WinTcl tries to call functions through * these null pointers. That is not a bug in Tcl - Tcl_FindExecutable is * mandatory in recent Tcl releases. */ NULL, NULL, /* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _utime, */ NULL, NULL, /* Security SDK - not available on 95,98,ME */ NULL, NULL, NULL, NULL, NULL, NULL |
︙ | ︙ | |||
174 175 176 177 178 179 180 181 182 | (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, /* * The three NULL function pointers will only be set when | > | | | | > < | | | | | < < < | < | | > | | | > | | | | > > | > > < | | < | 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 | (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, /* * The three NULL function pointers will only be set when * Tcl_FindExecutable is called. If you don't ever call that function, the * application will crash whenever WinTcl tries to call functions through * these null pointers. That is not a bug in Tcl - Tcl_FindExecutable is * mandatory in recent Tcl releases. */ NULL, NULL, /* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _wutime, */ NULL, NULL, /* Security SDK - will be filled in on NT,XP,2000,2003 */ NULL, NULL, NULL, NULL, NULL, NULL }; TclWinProcs *tclWinProcs; static Tcl_Encoding tclWinTCharEncoding; #ifdef HAVE_NO_SEH /* * Need to add noinline flag to DllMain declaration so that gcc -O3 does not * inline asm code into DllEntryPoint and cause a compile time error because * of redefined local labels. */ BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, LPVOID reserved) __attribute__ ((noinline)); #else /* * The following declaration is for the VC++ DLL entry point. */ BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, LPVOID reserved); #endif /* HAVE_NO_SEH */ /* * The following structure and linked list is to allow us to map between * volume mount points and drive letters on the fly (no Win API exists for * this). */ typedef struct MountPointMap { CONST WCHAR *volumeName; /* Native wide string volume name. */ char driveLetter; /* Drive letter corresponding to the volume * name. */ struct MountPointMap *nextPtr; /* Pointer to next structure in list, or * NULL. */ } MountPointMap; /* * This is the head of the linked list, which is protected by the mutex which * follows, for thread-enabled builds. */ MountPointMap *driveLetterLookup = NULL; TCL_DECLARE_MUTEX(mountPointMap) /* * We will need this below. */ extern Tcl_FSDupInternalRepProc TclNativeDupInternalRep; #ifdef __WIN32__ #ifndef STATIC_BUILD /* *---------------------------------------------------------------------- * * DllEntryPoint -- * * This wrapper function is used by Borland to invoke the initialization * code for Tcl. It simply calls the DllMain routine. * * Results: * See DllMain. * * Side effects: * See DllMain. * |
︙ | ︙ | |||
275 276 277 278 279 280 281 | } /* *---------------------------------------------------------------------- * * DllMain -- * | | | | | | | | > > > > > | | < > < | | > | < < < < | > | | > | > | | > | > > > | > | < | | > | > | > > > > | < | | > | | > > > > | > | | | | < > > > > < < > | | > | | < < | > > > > | > > | | < < < < | > > | > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | } /* *---------------------------------------------------------------------- * * DllMain -- * * This routine is called by the VC++ C run time library init code, or * the DllEntryPoint routine. It is responsible for initializing various * dynamically loaded libraries. * * Results: * TRUE on sucess, FALSE on failure. * * Side effects: * Establishes 32-to-16 bit thunk and initializes sockets library. This * might call some sycronization functions, but MSDN documentation * states: "Waiting on synchronization objects in DllMain can cause a * deadlock." * *---------------------------------------------------------------------- */ BOOL APIENTRY DllMain(hInst, reason, reserved) HINSTANCE hInst; /* Library instance handle. */ DWORD reason; /* Reason this function is being called. */ LPVOID reserved; /* Not used. */ { #ifdef HAVE_NO_SEH EXCEPTION_REGISTRATION registration; #endif switch (reason) { case DLL_PROCESS_ATTACH: DisableThreadLibraryCalls(hInst); TclWinInit(hInst); return TRUE; case DLL_PROCESS_DETACH: /* * Protect the call to Tcl_Finalize. The OS could be unloading us from * an exception handler and the state of the stack might be unstable. */ #ifdef HAVE_NO_SEH __asm__ __volatile__ ( /* * Construct an EXCEPTION_REGISTRATION to protect the call to * Tcl_Finalize */ "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ "movl %[error], 0x10(%%edx)" "\n\t" /* status */ /* * Link the EXCEPTION_REGISTRATION on the chain */ "movl %%edx, %%fs:0" "\n\t" /* * Call Tcl_Finalize */ "call _Tcl_Finalize" "\n\t" /* * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION * and store a TCL_OK status */ "movl %%fs:0, %%edx" "\n\t" "movl %[ok], %%eax" "\n\t" "movl %%eax, 0x10(%%edx)" "\n\t" "jmp 2f" "\n" /* * Come here on an exception. Get the EXCEPTION_REGISTRATION that * we previously put on the chain. */ "1:" "\t" "movl %%fs:0, %%edx" "\n\t" "movl 0x8(%%edx), %%edx" "\n" /* * Come here however we exited. Restore context from the * EXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xc(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : [registration] "m" (registration), [ok] "i" (TCL_OK), [error] "i" (TCL_ERROR) : "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory" ); #else /* HAVE_NO_SEH */ __try { Tcl_Finalize(); } __except (EXCEPTION_EXECUTE_HANDLER) { /* empty handler body. */ } #endif break; } return TRUE; } #endif /* !STATIC_BUILD */ #endif /* __WIN32__ */ /* *---------------------------------------------------------------------- * * TclWinGetTclInstance -- |
︙ | ︙ | |||
457 458 459 460 461 462 463 | hInstance = hInst; os.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); GetVersionEx(&os); platformId = os.dwPlatformId; /* | | | | | | 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 | hInstance = hInst; os.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); GetVersionEx(&os); platformId = os.dwPlatformId; /* * We no longer support Win32s, so just in case someone manages to get a * runtime there, make sure they know that. */ if (platformId == VER_PLATFORM_WIN32s) { Tcl_Panic("Win32s is not a supported platform"); } tclWinProcs = &asciiProcs; } /* *---------------------------------------------------------------------- * * TclWinGetPlatformId -- * * Determines whether running under NT, 95, or Win32s, to allow runtime * conditional code. * * Results: * The return value is one of: * VER_PLATFORM_WIN32s Win32s on Windows 3.1. (not supported) * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95, 98, ME. * VER_PLATFORM_WIN32_NT Win32 on Windows NT, 2000, XP * |
︙ | ︙ | |||
530 531 532 533 534 535 536 | } /* *---------------------------------------------------------------------- * * TclpCheckStackSpace -- * | | | > > > > | | | | < | > > > | > > > > > > > > | > > > | > | > > > > | > > > | > > > > > > > > > > > > > | > | > | > > > > | > > > > > | | > > > > > > > > > > | | < | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TclpCheckStackSpace -- * * Detect if we are about to blow the stack. Called before an evaluation * can happen when nesting depth is checked. * * Results: * 1 if there is enough stack space to continue; 0 if not. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclpCheckStackSpace() { #ifdef HAVE_NO_SEH EXCEPTION_REGISTRATION registration; #endif int retval = 0; /* * We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD bytes * of stack space left. alloca() is cheap on windows; basically it just * subtracts from the stack pointer causing the OS to throw an exception * if the stack pointer is set below the bottom of the stack. */ #ifdef HAVE_NO_SEH __asm__ __volatile__ ( /* * Construct an EXCEPTION_REGISTRATION to protect the call to __alloca */ "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ "movl %[error], 0x10(%%edx)" "\n\t" /* status */ /* * Link the EXCEPTION_REGISTRATION on the chain */ "movl %%edx, %%fs:0" "\n\t" /* * Attempt a call to __alloca, to determine whether there's sufficient * memory to be had. */ "movl %[size], %%eax" "\n\t" "pushl %%eax" "\n\t" "call __alloca" "\n\t" /* * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION and * store a TCL_OK status */ "movl %%fs:0, %%edx" "\n\t" "movl %[ok], %%eax" "\n\t" "movl %%eax, 0x10(%%edx)" "\n\t" "jmp 2f" "\n" /* * Come here on an exception. Get the EXCEPTION_REGISTRATION that we * previously put on the chain. */ "1:" "\t" "movl %%fs:0, %%edx" "\n\t" "movl 0x8(%%edx), %%edx" "\n\t" /* * Come here however we exited. Restore context from the * EXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xc(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : [registration] "m" (registration), [ok] "i" (TCL_OK), [error] "i" (TCL_ERROR), [size] "i" (TCL_WIN_STACK_THRESHOLD) : "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory" ); retval = (registration.status == TCL_OK); #else /* !HAVE_NO_SEH */ __try { #ifdef HAVE_ALLOCA_GCC_INLINE __asm__ __volatile__ ( "movl %0, %%eax" "\n\t" "call __alloca" "\n\t" : : "i"(TCL_WIN_STACK_THRESHOLD) : "%eax"); #else alloca(TCL_WIN_STACK_THRESHOLD); #endif /* HAVE_ALLOCA_GCC_INLINE */ retval = 1; } __except (EXCEPTION_EXECUTE_HANDLER) {} #endif /* HAVE_NO_SEH */ return retval; } /* *--------------------------------------------------------------------------- * * TclWinSetInterfaces -- * * A helper proc that allows the test library to change the tclWinProcs * structure to dispatch to either the wide-character or multi-byte * versions of the operating system calls, depending on whether Unicode * is the system encoding. * * As well as this, we can also try to load in some additional procs * which may/may not be present depending on the current Windows version * (e.g. Win95 will not have the procs below). * * Results: * None. * * Side effects: * None. * |
︙ | ︙ | |||
718 719 720 721 722 723 724 | if (wide) { tclWinProcs = &unicodeProcs; tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); if (tclWinProcs->getFileAttributesExProc == NULL) { HINSTANCE hInstance = LoadLibraryA("kernel32"); if (hInstance != NULL) { | | | | > | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | < | | | | > | | | | | | | | | | | | | | | | | < | > > > | > > | | | | | | | | | | > | | > | | | | | < | | > > > | > > | > | > > > | | > | > > | > > > | | | > > | > > | > > | > | | > > | > > | > | | < > | | | | | | | | < | | | | | | < | | | | | | < | | | < | | | | | | | | | | > | | | > > | | | > > | < | > > > > | > | > | > > | > | > > > | > | > > | > | > > > > > > > | | | < | | | | < < | < < < < > > | < < > > > > < | > | | | | < < < < | | | | < | | | > | < | > > > > | > > | | > > | > | | | | | | | | > | > | | | | | > > | | > < | < | < < | < < | < | < < < < < < < < < < < < < < < < < < | 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 | if (wide) { tclWinProcs = &unicodeProcs; 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"); tclWinProcs->findFirstFileExProc = (HANDLE (WINAPI *)(CONST TCHAR*, UINT, LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance, "FindFirstFileExW"); tclWinProcs->getVolumeNameForVMPProc = (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, DWORD)) GetProcAddress(hInstance, "GetVolumeNameForVolumeMountPointW"); tclWinProcs->getLongPathNameProc = (DWORD (WINAPI *)(CONST TCHAR*, TCHAR*, DWORD)) GetProcAddress(hInstance, "GetLongPathNameW"); FreeLibrary(hInstance); } hInstance = LoadLibraryA("advapi32"); if (hInstance != NULL) { tclWinProcs->getFileSecurityProc = (BOOL (WINAPI *)( LPCTSTR lpFileName, SECURITY_INFORMATION RequestedInformation, PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD nLength, LPDWORD lpnLengthNeeded)) GetProcAddress(hInstance, "GetFileSecurityW"); tclWinProcs->impersonateSelfProc = (BOOL (WINAPI *) ( SECURITY_IMPERSONATION_LEVEL ImpersonationLevel)) GetProcAddress(hInstance, "ImpersonateSelf"); tclWinProcs->openThreadTokenProc = (BOOL (WINAPI *) ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL OpenAsSelf, PHANDLE TokenHandle)) GetProcAddress(hInstance, "OpenThreadToken"); tclWinProcs->revertToSelfProc = (BOOL (WINAPI *) (void)) GetProcAddress(hInstance, "RevertToSelf"); tclWinProcs->mapGenericMaskProc = (VOID (WINAPI *) ( PDWORD AccessMask, PGENERIC_MAPPING GenericMapping)) GetProcAddress(hInstance, "MapGenericMask"); tclWinProcs->accessCheckProc = (BOOL (WINAPI *)( PSECURITY_DESCRIPTOR pSecurityDescriptor, HANDLE ClientToken, DWORD DesiredAccess, PGENERIC_MAPPING GenericMapping, PPRIVILEGE_SET PrivilegeSet, LPDWORD PrivilegeSetLength, LPDWORD GrantedAccess, LPBOOL AccessStatus)) GetProcAddress(hInstance, "AccessCheck"); FreeLibrary(hInstance); } } } else { tclWinProcs = &asciiProcs; tclWinTCharEncoding = NULL; if (tclWinProcs->getFileAttributesExProc == NULL) { HINSTANCE hInstance = LoadLibraryA("kernel32"); if (hInstance != NULL) { tclWinProcs->getFileAttributesExProc = (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExA"); tclWinProcs->createHardLinkProc = (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, "CreateHardLinkA"); tclWinProcs->findFirstFileExProc = NULL; tclWinProcs->getLongPathNameProc = NULL; /* * The 'findFirstFileExProc' function exists on some of * 95/98/ME, but it seems not to work as anticipated. * Therefore we don't set this function pointer. The relevant * code will fall back on a slower approach using the normal * findFirstFileProc. * * (HANDLE (WINAPI *)(CONST TCHAR*, UINT, * LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance, * "FindFirstFileExA"); */ tclWinProcs->getVolumeNameForVMPProc = (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, DWORD)) GetProcAddress(hInstance, "GetVolumeNameForVolumeMountPointA"); FreeLibrary(hInstance); } } } } /* *--------------------------------------------------------------------------- * * TclWinResetInterfaceEncodings -- * * Called during finalization to free up any encodings we use. The * tclWinProcs-> look up table is still ok to use after this call, * provided no encoding conversion is required. * * We also clean up any memory allocated in our mount point map which is * used to follow certain kinds of symlinks. That code should never be * used once encodings are taken down. * * Results: * None. * * Side effects: * None. * *--------------------------------------------------------------------------- */ void TclWinResetInterfaceEncodings() { MountPointMap *dlIter, *dlIter2; if (tclWinTCharEncoding != NULL) { Tcl_FreeEncoding(tclWinTCharEncoding); tclWinTCharEncoding = NULL; } /* * Clean up the mount point map. */ Tcl_MutexLock(&mountPointMap); dlIter = driveLetterLookup; while (dlIter != NULL) { dlIter2 = dlIter->nextPtr; ckfree((char*)dlIter->volumeName); ckfree((char*)dlIter); dlIter = dlIter2; } Tcl_MutexUnlock(&mountPointMap); } /* *--------------------------------------------------------------------------- * * TclWinResetInterfaces -- * * Called during finalization to reset us to a safe state for reuse. * After this call, it is best not to use the tclWinProcs-> look up table * since it is likely to be different to what is expected. * * Results: * None. * * Side effects: * None. * *--------------------------------------------------------------------------- */ void TclWinResetInterfaces() { tclWinProcs = &asciiProcs; } /* *-------------------------------------------------------------------- * * TclWinDriveLetterForVolMountPoint * * Unfortunately, Windows provides no easy way at all to get hold of the * drive letter for a volume mount point, but we need that information to * understand paths correctly. So, we have to build an associated array * to find these correctly, and allow quick and easy lookup from volume * mount points to drive letters. * * We assume here that we are running on a system for which the wide * character interfaces are used, which is valid for Win 2000 and WinXP * which are the only systems on which this function will ever be called. * * Result: * The drive letter, or -1 if no drive letter corresponds to the given * mount point. * *-------------------------------------------------------------------- */ char TclWinDriveLetterForVolMountPoint(CONST WCHAR *mountPoint) { MountPointMap *dlIter, *dlPtr2; WCHAR Target[55]; /* Target of mount at mount point */ WCHAR drive[4] = { L'A', L':', L'\\', L'\0' }; /* * Detect the volume mounted there. Unfortunately, there is no simple way * to map a unique volume name to a DOS drive letter. So, we have to build * an associative array. */ Tcl_MutexLock(&mountPointMap); dlIter = driveLetterLookup; while (dlIter != NULL) { if (wcscmp(dlIter->volumeName, mountPoint) == 0) { /* * We need to check whether this information is still valid, since * either the user or various programs could have adjusted the * mount points on the fly. */ drive[0] = L'A' + (dlIter->driveLetter - 'A'); /* * Try to read the volume mount point and see where it points. */ if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, (TCHAR*)Target, 55) != 0) { if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) { /* * Nothing has changed. */ Tcl_MutexUnlock(&mountPointMap); return dlIter->driveLetter; } } /* * If we reach here, unfortunately, this mount point is no longer * valid at all. */ if (driveLetterLookup == dlIter) { dlPtr2 = dlIter; driveLetterLookup = dlIter->nextPtr; } else { for (dlPtr2 = driveLetterLookup; dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) { if (dlPtr2->nextPtr == dlIter) { dlPtr2->nextPtr = dlIter->nextPtr; dlPtr2 = dlIter; break; } } } /* * Now dlPtr2 points to the structure to free. */ ckfree((char*)dlPtr2->volumeName); ckfree((char*)dlPtr2); /* * Restart the loop - we could try to be clever and continue half * way through, but the logic is a bit messy, so it's cleanest * just to restart. */ dlIter = driveLetterLookup; continue; } dlIter = dlIter->nextPtr; } /* * We couldn't find it, so we must iterate over the letters. */ for (drive[0] = L'A'; drive[0] <= L'Z'; drive[0]++) { /* * Try to read the volume mount point and see where it points. */ if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, (TCHAR*)Target, 55) != 0) { int alreadyStored = 0; for (dlIter = driveLetterLookup; dlIter != NULL; dlIter = dlIter->nextPtr) { if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) { alreadyStored = 1; break; } } if (!alreadyStored) { dlPtr2 = (MountPointMap *) ckalloc(sizeof(MountPointMap)); dlPtr2->volumeName = TclNativeDupInternalRep(Target); dlPtr2->driveLetter = 'A' + (drive[0] - L'A'); dlPtr2->nextPtr = driveLetterLookup; driveLetterLookup = dlPtr2; } } } /* * Try again. */ for (dlIter = driveLetterLookup; dlIter != NULL; dlIter = dlIter->nextPtr) { if (wcscmp(dlIter->volumeName, mountPoint) == 0) { Tcl_MutexUnlock(&mountPointMap); return dlIter->driveLetter; } } /* * The volume doesn't appear to correspond to a drive letter - we remember * that fact and store '-1' so we don't have to look it up each time. */ dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap)); dlPtr2->volumeName = TclNativeDupInternalRep((ClientData)mountPoint); dlPtr2->driveLetter = -1; dlPtr2->nextPtr = driveLetterLookup; driveLetterLookup = dlPtr2; Tcl_MutexUnlock(&mountPointMap); return -1; } /* *--------------------------------------------------------------------------- * * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf -- * * Convert between UTF-8 and Unicode when running Windows NT or the * current ANSI code page when running Windows 95. * * On Mac, Unix, and Windows 95, all strings exchanged between Tcl and * the OS are "char" oriented. We need only one Tcl_Encoding to convert * between UTF-8 and the system's native encoding. We use NULL to * represent that encoding. * * On NT, some strings exchanged between Tcl and the OS are "char" * oriented, while others are in Unicode. We need two Tcl_Encoding APIs * depending on whether we are targeting a "char" or Unicode interface. * * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an encoding of * NULL should always used to convert between UTF-8 and the system's * "char" oriented encoding. The following two functions are used in * Windows-specific code to convert between UTF-8 and Unicode strings * (NT) or "char" strings(95). This saves you the trouble of writing the * following type of fragment over and over: * * if (running NT) { * encoding <- Tcl_GetEncoding("unicode"); * nativeBuffer <- UtfToExternal(encoding, utfBuffer); * Tcl_FreeEncoding(encoding); * } else { * nativeBuffer <- UtfToExternal(NULL, utfBuffer); * } * * By convention, in Windows a TCHAR is a character in the ANSI code page * on Windows 95, a Unicode character on Windows NT. If you plan on * targeting a Unicode interfaces when running on NT and a "char" * oriented interface while running on 95, these functions should be * used. If you plan on targetting the same "char" oriented function on * both 95 and NT, use Tcl_UtfToExternal() with an encoding of NULL. * * Results: * The result is a pointer to the string in the desired target encoding. * Storage for the result string is allocated in dsPtr; the caller must * call Tcl_DStringFree() when the result is no longer needed. * * Side effects: * None. * *--------------------------------------------------------------------------- */ TCHAR * Tcl_WinUtfToTChar(string, len, dsPtr) CONST char *string; /* Source string in UTF-8. */ int len; /* Source string length in bytes, or < 0 for * strlen(). */ Tcl_DString *dsPtr; /* Uninitialized or free DString in which the * converted string is stored. */ { return (TCHAR *) Tcl_UtfToExternalDString(tclWinTCharEncoding, string, len, dsPtr); } char * Tcl_WinTCharToUtf(string, len, dsPtr) CONST TCHAR *string; /* Source string in Unicode when running NT, * ANSI when running 95. */ int len; /* Source string length in bytes, or < 0 for * platform-specific string length. */ Tcl_DString *dsPtr; /* Uninitialized or free DString in which the * converted string is stored. */ { return Tcl_ExternalToUtfDString(tclWinTCharEncoding, (CONST char *) string, len, dsPtr); } /* *------------------------------------------------------------------------ * * TclWinCPUID -- * * Get CPU ID information on an Intel box under Windows * * Results: * Returns TCL_OK if successful, TCL_ERROR if CPUID is not supported or * fails. * * Side effects: * If successful, stores EAX, EBX, ECX and EDX registers after the CPUID * instruction in the four integers designated by 'regsPtr' * *---------------------------------------------------------------------- */ int TclWinCPUID( unsigned int index, /* Which CPUID value to retrieve. */ unsigned int *regsPtr) /* Registers after the CPUID. */ { #ifdef HAVE_NO_SEH EXCEPTION_REGISTRATION registration; #endif int status = TCL_ERROR; #if defined(__GNUC__) && !defined(_WIN64) /* * Execute the CPUID instruction with the given index, and store results * off 'regPtr'. */ __asm__ __volatile__( /* * Construct an EXCEPTION_REGISTRATION to protect the CPUID * instruction (early 486's don't have CPUID) */ "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ "movl %[error], 0x10(%%edx)" "\n\t" /* status */ /* * Link the EXCEPTION_REGISTRATION on the chain */ "movl %%edx, %%fs:0" "\n\t" /* * Do the CPUID instruction, and save the results in the 'regsPtr' * area. */ "movl %[rptr], %%edi" "\n\t" "movl %[index], %%eax" "\n\t" "cpuid" "\n\t" "movl %%eax, 0x0(%%edi)" "\n\t" "movl %%ebx, 0x4(%%edi)" "\n\t" "movl %%ecx, 0x8(%%edi)" "\n\t" "movl %%edx, 0xc(%%edi)" "\n\t" /* * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION and * store a TCL_OK status. */ "movl %%fs:0, %%edx" "\n\t" "movl %[ok], %%eax" "\n\t" "movl %%eax, 0x10(%%edx)" "\n\t" "jmp 2f" "\n" /* * Come here on an exception. Get the EXCEPTION_REGISTRATION that we * previously put on the chain. */ "1:" "\t" "movl %%fs:0, %%edx" "\n\t" "movl 0x8(%%edx), %%edx" "\n\t" /* * Come here however we exited. Restore context from the * EXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xc(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : [index] "m" (index), [rptr] "m" (regsPtr), [registration] "m" (registration), [ok] "i" (TCL_OK), [error] "i" (TCL_ERROR) : "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"); status = registration.status; #elif defined(_MSC_VER) && !defined(_WIN64) /* * Define a structure in the stack frame to hold the registers. */ struct { DWORD dw0; DWORD dw1; DWORD dw2; DWORD dw3; } regs; regs.dw0 = index; /* * Execute the CPUID instruction and save regs in the stack frame. */ _try { _asm { push ebx push ecx push edx mov eax, regs.dw0 cpuid mov regs.dw0, eax mov regs.dw1, ebx mov regs.dw2, ecx mov regs.dw3, edx pop edx pop ecx pop ebx } /* * Copy regs back out to the caller. */ regsPtr[0] = regs.dw0; regsPtr[1] = regs.dw1; regsPtr[2] = regs.dw2; regsPtr[3] = regs.dw3; status = TCL_OK; } __except(EXCEPTION_EXECUTE_HANDLER) { /* do nothing */ } #else /* * Don't know how to do assembly code for this compiler and/or * architecture. */ #endif return status; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinChan.c.
1 2 3 | /* * tclWinChan.c * | | | | | | | 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.37.2.4 2005/08/02 18:17:00 dgp Exp $ */ #include "tclWinInt.h" #include "tclIO.h" /* * State flags used in the info structures below. |
︙ | ︙ | |||
38 39 40 41 42 43 44 | int watchMask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which events should be reported. */ int flags; /* State flags, see above for a list. */ HANDLE handle; /* Input/output file. */ struct FileInfo *nextPtr; /* Pointer to next registered file. */ int dirty; /* Boolean flag. Set if the OS may have data | | | | | | | | | | < | | < < | | | < | | | | | | | | | | | | > > | | | | > > | < < | > > > > | > | | | | > > | 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 | int watchMask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which events should be reported. */ int flags; /* State flags, see above for a list. */ HANDLE handle; /* Input/output file. */ struct FileInfo *nextPtr; /* Pointer to next registered file. */ int dirty; /* Boolean flag. Set if the OS may have data * pending on the channel. */ } FileInfo; typedef struct ThreadSpecificData { /* * List of all file channels currently open. */ FileInfo *firstFilePtr; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * The following structure is what is added to the Tcl event queue when file * events are generated. */ typedef struct FileEvent { Tcl_Event header; /* Information that is standard for all * events. */ FileInfo *infoPtr; /* Pointer to file info structure. Note that * we still have to verify that the file * exists before dereferencing this * pointer. */ } FileEvent; /* * Static routines for this file: */ static int FileBlockProc(ClientData instanceData, int mode); static void FileChannelExitHandler(ClientData clientData); static void FileCheckProc(ClientData clientData, int flags); static int FileCloseProc(ClientData instanceData, Tcl_Interp *interp); static int FileEventProc(Tcl_Event *evPtr, int flags); static int FileGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static ThreadSpecificData *FileInit(void); static int FileInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int FileOutputProc(ClientData instanceData, CONST char *buf, int toWrite, int *errorCode); static int FileSeekProc(ClientData instanceData, long offset, int mode, int *errorCode); static Tcl_WideInt FileWideSeekProc(ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode); static void FileSetupProc(ClientData clientData, int flags); static void FileWatchProc(ClientData instanceData, int mask); static void FileThreadActionProc(ClientData instanceData, int action); static int FileTruncateProc(ClientData instanceData, Tcl_WideInt length); /* * This structure describes the channel type structure for file based IO. */ static Tcl_ChannelType fileChannelType = { "file", /* Type name. */ TCL_CHANNEL_VERSION_4, /* v4 channel */ FileCloseProc, /* Close proc. */ FileInputProc, /* Input proc. */ FileOutputProc, /* Output proc. */ FileSeekProc, /* Seek proc. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ FileWatchProc, /* Set up the notifier to watch the channel. */ FileGetHandleProc, /* Get an OS handle from channel. */ NULL, /* close2proc. */ FileBlockProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ FileWideSeekProc, /* Wide seek proc. */ FileThreadActionProc, /* Thread action proc. */ FileTruncateProc, /* Truncate proc. */ }; #ifdef HAVE_NO_SEH /* * Unlike Borland and Microsoft, we don't register exception handlers by * pushing registration records onto the runtime stack. Instead, we register * them by creating an EXCEPTION_REGISTRATION within the activation record. */ typedef struct EXCEPTION_REGISTRATION { struct EXCEPTION_REGISTRATION* link; EXCEPTION_DISPOSITION (*handler)( struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); void* ebp; void* esp; int status; } EXCEPTION_REGISTRATION; #endif /* *---------------------------------------------------------------------- * * FileInit -- * |
︙ | ︙ | |||
165 166 167 168 169 170 171 | } /* *---------------------------------------------------------------------- * * FileChannelExitHandler -- * | | | | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 | } /* *---------------------------------------------------------------------- * * FileChannelExitHandler -- * * This function is called to cleanup the channel driver before Tcl is * unloaded. * * Results: * None. * * Side effects: * Destroys the communication window. * |
︙ | ︙ | |||
189 190 191 192 193 194 195 | } /* *---------------------------------------------------------------------- * * FileSetupProc -- * | | | | | < | | | | | < | | < | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * FileSetupProc -- * * This function is invoked before Tcl_DoOneEvent blocks waiting for an * event. * * Results: * None. * * Side effects: * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void FileSetupProc(data, flags) ClientData data; /* Not used. */ int flags; /* Event flags as passed to Tcl_DoOneEvent. */ { FileInfo *infoPtr; Tcl_Time blockTime = { 0, 0 }; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } /* * Check to see if there is a ready file. If so, poll. */ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->watchMask) { Tcl_SetMaxBlockTime(&blockTime); break; } } } /* *---------------------------------------------------------------------- * * FileCheckProc -- * * This function is called by Tcl_DoOneEvent to check the file event * source for events. * * Results: * None. * * Side effects: * May queue an event. * *---------------------------------------------------------------------- */ static void FileCheckProc(data, flags) ClientData data; /* Not used. */ int flags; /* Event flags as passed to Tcl_DoOneEvent. */ { FileEvent *evPtr; FileInfo *infoPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } /* * Queue events for any ready files that don't already have events queued * (caused by persistent states that won't generate WinSock events). */ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) { infoPtr->flags |= FILE_PENDING; evPtr = (FileEvent *) ckalloc(sizeof(FileEvent)); evPtr->header.proc = FileEventProc; evPtr->infoPtr = infoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); } } } /* *---------------------------------------------------------------------- * * FileEventProc -- * * This function is invoked by Tcl_ServiceEvent when a file event reaches * the front of the event queue. This function invokes Tcl_NotifyChannel * on the file. * * Results: * Returns 1 if the event was handled, meaning it should be removed from * the queue. Returns 0 if the event was not handled, meaning it should * stay on the queue. The only time the event isn't handled is if the * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the notifier callback does. * *---------------------------------------------------------------------- */ static int FileEventProc(evPtr, flags) Tcl_Event *evPtr; /* Event to service. */ int flags; /* Flags that indicate what events to handle, * such as TCL_FILE_EVENTS. */ { FileEvent *fileEvPtr = (FileEvent *)evPtr; FileInfo *infoPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return 0; } /* * Search through the list of watched files for the one whose handle * matches the event. We do this rather than simply dereferencing the * handle in the event so that files can be deleted while the event is in * the queue. */ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (fileEvPtr->infoPtr == infoPtr) { infoPtr->flags &= ~(FILE_PENDING); Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask); |
︙ | ︙ | |||
348 349 350 351 352 353 354 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int FileBlockProc(instanceData, mode) | | | | | 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int FileBlockProc(instanceData, mode) ClientData instanceData; /* Instance data for channel. */ int mode; /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { FileInfo *infoPtr = (FileInfo *) instanceData; /* * Files on Windows can not be switched between blocking and nonblocking, * hence we have to emulate the behavior. This is done in the input * function by checking against a bit in the state. We set or unset the |
︙ | ︙ | |||
387 388 389 390 391 392 393 | * Closes the physical channel * *---------------------------------------------------------------------- */ static int FileCloseProc(instanceData, interp) | | | > > | | | > > > > > > > > > > > > > > > > > > > | | | | | | | | > | 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 | * Closes the physical channel * *---------------------------------------------------------------------- */ static int FileCloseProc(instanceData, interp) ClientData instanceData; /* Pointer to FileInfo structure. */ Tcl_Interp *interp; /* Not used. */ { FileInfo *fileInfoPtr = (FileInfo *) instanceData; FileInfo *infoPtr; ThreadSpecificData *tsdPtr; int errorCode = 0; /* * Remove the file from the watch list. */ FileWatchProc(instanceData, 0); /* * Don't close the Win32 handle if the handle is a standard channel during * the thread exit process. Otherwise, one thread may kill the stdio of * another. */ if (!TclInThreadExit() || ((GetStdHandle(STD_INPUT_HANDLE) != fileInfoPtr->handle) && (GetStdHandle(STD_OUTPUT_HANDLE) != fileInfoPtr->handle) && (GetStdHandle(STD_ERROR_HANDLE) != fileInfoPtr->handle))) { if (CloseHandle(fileInfoPtr->handle) == FALSE) { TclWinConvertError(GetLastError()); errorCode = errno; } } /* * See if this FileInfo* is still on the thread local list. */ tsdPtr = TCL_TSD_INIT(&dataKey); for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr == fileInfoPtr) { /* * This channel exists on the thread local list. It should have * been removed by an earlier Threadaction call, but do that now * since just deallocating fileInfoPtr would leave an deallocated * pointer on the thread local list. */ FileThreadActionProc(fileInfoPtr,TCL_CHANNEL_THREAD_REMOVE); break; } } ckfree((char *)fileInfoPtr); return errorCode; } /* *---------------------------------------------------------------------- * * FileSeekProc -- * * Seeks on a file-based channel. Returns the new position. * * Results: * -1 if failed, the new position if successful. If failed, it also sets * *errorCodePtr to the error code. * * Side effects: * Moves the location at which the channel will be accessed in future * operations. * *---------------------------------------------------------------------- */ static int FileSeekProc(instanceData, offset, mode, errorCodePtr) ClientData instanceData; /* File state. */ long offset; /* Offset to seek to. */ int mode; /* Relative to where should we seek? */ int *errorCodePtr; /* To store error code. */ { FileInfo *infoPtr = (FileInfo *) instanceData; LONG newPos, newPosHigh, oldPos, oldPosHigh; DWORD moveMethod; *errorCodePtr = 0; if (mode == SEEK_SET) { moveMethod = FILE_BEGIN; } else if (mode == SEEK_CUR) { moveMethod = FILE_CURRENT; } else { moveMethod = FILE_END; } /* * Save our current place in case we need to roll-back the seek. */ oldPosHigh = 0; oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT); if (oldPos == INVALID_SET_FILE_POINTER) { DWORD winError = GetLastError(); if (winError != NO_ERROR) { TclWinConvertError(winError); |
︙ | ︙ | |||
487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 | return -1; } } /* * Check for expressability in our return type, and roll-back otherwise. */ if (newPosHigh != 0) { *errorCodePtr = EOVERFLOW; SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN); return -1; } return (int) newPos; } /* *---------------------------------------------------------------------- * * FileWideSeekProc -- * * Seeks on a file-based channel. Returns the new position. * * Results: | > | | | | | | | | | 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 | return -1; } } /* * Check for expressability in our return type, and roll-back otherwise. */ if (newPosHigh != 0) { *errorCodePtr = EOVERFLOW; SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN); return -1; } return (int) newPos; } /* *---------------------------------------------------------------------- * * FileWideSeekProc -- * * Seeks on a file-based channel. Returns the new position. * * Results: * -1 if failed, the new position if successful. If failed, it also sets * *errorCodePtr to the error code. * * Side effects: * Moves the location at which the channel will be accessed in future * operations. * *---------------------------------------------------------------------- */ static Tcl_WideInt FileWideSeekProc(instanceData, offset, mode, errorCodePtr) ClientData instanceData; /* File state. */ Tcl_WideInt offset; /* Offset to seek to. */ int mode; /* Relative to where should we seek? */ int *errorCodePtr; /* To store error code. */ { FileInfo *infoPtr = (FileInfo *) instanceData; DWORD moveMethod; LONG newPos, newPosHigh; *errorCodePtr = 0; if (mode == SEEK_SET) { |
︙ | ︙ | |||
551 552 553 554 555 556 557 558 559 | } return (Tcl_LongAsWide(newPos) | (Tcl_LongAsWide(newPosHigh) << 32)); } /* *---------------------------------------------------------------------- * * FileInputProc -- * | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | 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 | } return (Tcl_LongAsWide(newPos) | (Tcl_LongAsWide(newPosHigh) << 32)); } /* *---------------------------------------------------------------------- * * FileTruncateProc -- * * Truncates a file-based channel. Returns the error code. * * Results: * 0 if successful, POSIX-y error code if it failed. * * Side effects: * Truncates the file, may move file pointers too. * *---------------------------------------------------------------------- */ static int FileTruncateProc(instanceData, length) ClientData instanceData; /* File state. */ Tcl_WideInt length; /* Length to truncate at. */ { FileInfo *infoPtr = (FileInfo *) instanceData; LONG newPos, newPosHigh, oldPos, oldPosHigh; /* * Save where we were... */ oldPosHigh = 0; oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT); if (oldPos == INVALID_SET_FILE_POINTER) { DWORD winError = GetLastError(); if (winError != NO_ERROR) { TclWinConvertError(winError); return errno; } } /* * Move to where we want to truncate */ newPosHigh = Tcl_WideAsLong(length >> 32); newPos = SetFilePointer(infoPtr->handle, Tcl_WideAsLong(length), &newPosHigh, FILE_BEGIN); if (newPos == INVALID_SET_FILE_POINTER) { DWORD winError = GetLastError(); if (winError != NO_ERROR) { TclWinConvertError(winError); return errno; } } /* * Perform the truncation (unlike POSIX ftruncate(), we needed to move to * the location to truncate at first). */ if (!SetEndOfFile(infoPtr->handle)) { TclWinConvertError(GetLastError()); return errno; } /* * Move back. If this last step fails, we don't care; it's just a "best * effort" attempt to restore our file pointer to where it was. */ SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN); return 0; } /* *---------------------------------------------------------------------- * * FileInputProc -- * * Reads input from the IO channel into the buffer given. Returns count * of how many bytes were actually read, and an error indication. * * Results: * A count of how many bytes were read is returned and an error * indication is returned in an output argument. * * Side effects: * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int FileInputProc(instanceData, buf, bufSize, errorCode) ClientData instanceData; /* File state. */ char *buf; /* Where to store data read. */ int bufSize; /* Num bytes available in buffer. */ int *errorCode; /* Where to store error code. */ { FileInfo *infoPtr; DWORD bytesRead; *errorCode = 0; infoPtr = (FileInfo *) instanceData; /* * Note that we will block on reads from a console buffer until a full * line has been entered. The only way I know of to get around this is to * write a console driver. We should probably do this at some point, but * for now, we just block. The same problem exists for files being read * over the network. */ if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead, (LPOVERLAPPED) NULL) != FALSE) { return bytesRead; } TclWinConvertError(GetLastError()); *errorCode = errno; if (errno == EPIPE) { return 0; } return -1; } /* *---------------------------------------------------------------------- * * FileOutputProc -- * * Writes the given output on the IO channel. Returns count of how many * characters were actually written, and an error indication. * * Results: * A count of how many characters were written is returned and an error * indication is returned in an output argument. * * Side effects: * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int FileOutputProc(instanceData, buf, toWrite, errorCode) ClientData instanceData; /* File state. */ CONST char *buf; /* The data buffer. */ int toWrite; /* How many bytes to write? */ int *errorCode; /* Where to store error code. */ { FileInfo *infoPtr = (FileInfo *) instanceData; DWORD bytesWritten; *errorCode = 0; /* |
︙ | ︙ | |||
654 655 656 657 658 659 660 | } /* *---------------------------------------------------------------------- * * FileWatchProc -- * | | < | | | | | | | | | | | | | | | | | | | | | | | < | 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 | } /* *---------------------------------------------------------------------- * * FileWatchProc -- * * Called by the notifier to set up to watch for events on this channel. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void FileWatchProc(instanceData, mask) ClientData instanceData; /* File state. */ int mask; /* What events to watch for; OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { FileInfo *infoPtr = (FileInfo *) instanceData; Tcl_Time blockTime = { 0, 0 }; /* * Since the file is always ready for events, we set the block time to * zero so we will poll. */ infoPtr->watchMask = mask & infoPtr->validMask; if (infoPtr->watchMask) { Tcl_SetMaxBlockTime(&blockTime); } } /* *---------------------------------------------------------------------- * * FileGetHandleProc -- * * Called from Tcl_GetChannelHandle to retrieve OS handles from a file * based channel. * * Results: * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int FileGetHandleProc(instanceData, direction, handlePtr) ClientData instanceData; /* The file state. */ int direction; /* TCL_READABLE or TCL_WRITABLE */ ClientData *handlePtr; /* Where to store the handle. */ { FileInfo *infoPtr = (FileInfo *) instanceData; if (direction & infoPtr->validMask) { *handlePtr = (ClientData) infoPtr->handle; return TCL_OK; } else { return TCL_ERROR; } } /* *---------------------------------------------------------------------- * * TclpOpenFileChannel -- * * Open an File based channel on Unix 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(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; HANDLE handle; char channelName[16 + TCL_INTEGER_SPACE]; |
︙ | ︙ | |||
832 833 834 835 836 837 838 | shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE; /* * Now we get to create the file. */ | | | | | | | > | 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 | shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE; /* * Now we get to create the file. */ handle = (*tclWinProcs->createFileProc)(nativeName, accessMode, shareMode, NULL, createMode, flags, (HANDLE) NULL); if (handle == INVALID_HANDLE_VALUE) { DWORD err = GetLastError(); if ((err & 0xffffL) == ERROR_OPEN_FAILED) { err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; } TclWinConvertError(err); if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); } return NULL; } type = GetFileType(handle); /* * If the file is a character device, we need to try to figure out whether * it is a serial port, a console, or something else. We test for the * console case first because this is more common. */ if (type == FILE_TYPE_CHAR) { if (GetConsoleMode(handle, &consoleParams)) { type = FILE_TYPE_CONSOLE; } else { DCB dcb; dcb.DCBlength = sizeof(DCB); if (GetCommState(handle, &dcb)) { type = FILE_TYPE_SERIAL; } } } channel = NULL; switch (type) { case FILE_TYPE_SERIAL: /* * Reopen channel for OVERLAPPED operation. Normally this shouldn't * fail, because the channel exists. */ handle = TclWinSerialReopen(handle, nativeName, accessMode); if (handle == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "couldn't reopen serial \"", TclGetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); |
︙ | ︙ | |||
913 914 915 916 917 918 919 | case FILE_TYPE_UNKNOWN: channel = TclWinOpenFileChannel(handle, channelName, channelPermissions, (mode & O_APPEND) ? FILE_APPEND : 0); break; default: /* | | | | < | | | < > > > | | | | 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 | case FILE_TYPE_UNKNOWN: channel = TclWinOpenFileChannel(handle, channelName, channelPermissions, (mode & O_APPEND) ? FILE_APPEND : 0); break; default: /* * The handle is of an unknown type, probably /dev/nul equivalent or * possibly a closed handle. */ channel = NULL; Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), "\": bad file type", (char *) NULL); break; } return channel; } /* *---------------------------------------------------------------------- * * Tcl_MakeFileChannel -- * * Creates a Tcl_Channel from an existing platform specific file handle. * * Results: * The Tcl_Channel created around the preexisting file. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_MakeFileChannel(rawHandle, mode) ClientData rawHandle; /* OS level handle */ int mode; /* ORed combination of TCL_READABLE and * TCL_WRITABLE to indicate file mode. */ { #ifdef HAVE_NO_SEH EXCEPTION_REGISTRATION registration; #endif char channelName[16 + TCL_INTEGER_SPACE]; Tcl_Channel channel = NULL; HANDLE handle = (HANDLE) rawHandle; HANDLE dupedHandle; DWORD consoleParams, type; TclFile readFile = NULL, writeFile = NULL; BOOL result; if (mode == 0) { return NULL; } /* * GetFileType() returns FILE_TYPE_UNKNOWN for invalid handles. */ type = GetFileType(handle); /* * If the file is a character device, we need to try to figure out whether * it is a serial port, a console, or something else. We test for the * console case first because this is more common. */ if (type == FILE_TYPE_CHAR) { if (GetConsoleMode(handle, &consoleParams)) { type = FILE_TYPE_CONSOLE; } else { DCB dcb; |
︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 | case FILE_TYPE_CHAR: channel = TclWinOpenFileChannel(handle, channelName, mode, 0); break; case FILE_TYPE_UNKNOWN: default: /* | | | | | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 | case FILE_TYPE_CHAR: channel = TclWinOpenFileChannel(handle, channelName, mode, 0); break; case FILE_TYPE_UNKNOWN: default: /* * The handle is of an unknown type. Test the validity of this OS * handle by duplicating it, then closing the dupe. The Win32 API * doesn't provide an IsValidHandle() function, so we have to emulate * it here. This test will not work on a console handle reliably, * which is why we can't test every handle that comes into this * function in this way. */ result = DuplicateHandle(GetCurrentProcess(), handle, GetCurrentProcess(), &dupedHandle, 0, FALSE, DUPLICATE_SAME_ACCESS); |
︙ | ︙ | |||
1038 1039 1040 1041 1042 1043 1044 | } /* * Use structured exception handling (Win32 SEH) to protect the close * of this duped handle which might throw EXCEPTION_INVALID_HANDLE. */ | > | < | > | < < < < | > | > > > > | > > > | < | | < > > | > | < | | | | | < | | | < | < > > > | | > > > | | | < < < < > | > > | < < > > > > | < < > > > | < > > > < < < > > > | | > > > | | | < > > | < < < < < | > > > > > > < > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | | | 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 | } /* * Use structured exception handling (Win32 SEH) to protect the close * of this duped handle which might throw EXCEPTION_INVALID_HANDLE. */ result = 0; #ifndef HAVE_NO_SEH __try { CloseHandle(dupedHandle); result = 1; } __except (EXCEPTION_EXECUTE_HANDLER) {} #else /* * Don't have SEH available, do things the hard way. Note that this * needs to be one block of asm, to avoid stack imbalance; also, it is * illegal for one asm block to contain a jump to another. */ __asm__ __volatile__ ( /* * Pick up parameters before messing with the stack */ "movl %[dupedHandle], %%ebx" "\n\t" /* * Construct an EXCEPTION_REGISTRATION to protect the call to * CloseHandle. */ "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the EXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" /* * Call CloseHandle(dupedHandle). */ "pushl %%ebx" "\n\t" "call _CloseHandle@4" "\n\t" /* * Come here on normal exit. Recover the EXCEPTION_REGISTRATION * and put a TRUE status return into it. */ "movl %%fs:0, %%edx" "\n\t" "movl $1, %%eax" "\n\t" "movl %%eax, 0x10(%%edx)" "\n\t" "jmp 2f" "\n" /* * Come here on an exception. Recover the EXCEPTION_REGISTRATION */ "1:" "\t" "movl %%fs:0, %%edx" "\n\t" "movl 0x8(%%edx), %%edx" "\n\t" /* * Come here however we exited. Restore context from the * EXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xc(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : [registration] "m" (registration), [dupedHandle] "m" (dupedHandle) : "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory" ); result = registration.status; #endif if (result == FALSE) { return NULL; } /* * Fall through, the handle is valid. * * Create the undefined channel, anyways, because we know the handle * is valid to something. */ channel = TclWinOpenFileChannel(handle, channelName, mode, 0); } return channel; } /* *---------------------------------------------------------------------- * * TclpGetDefaultStdChannel -- * * Constructs a channel for the specified standard OS handle. * * Results: * Returns the specified default standard channel, or NULL. * * Side effects: * May cause the creation of a standard channel and the underlying file. * *---------------------------------------------------------------------- */ Tcl_Channel TclpGetDefaultStdChannel(type) int type; /* One of TCL_STDIN, TCL_STDOUT, or * TCL_STDERR. */ { Tcl_Channel channel; HANDLE handle; int mode; char *bufMode; DWORD handleId; /* Standard handle to retrieve. */ |
︙ | ︙ | |||
1243 1244 1245 1246 1247 1248 1249 | } /* *---------------------------------------------------------------------- * * TclWinOpenFileChannel -- * | | | | | | | | | | < | | | | > > > > > > > | < | | | | | | < | | | | | | < | | < | | < | > > > > > | | < < < < < < | | | | | | | | | | | | | | | | | | < < | < < < < < < < < < < < < | | | < < < | < < < < | < < < | < | < < < | 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 | } /* *---------------------------------------------------------------------- * * TclWinOpenFileChannel -- * * Constructs a File channel for the specified standard OS handle. This * is a helper function to break up the construction of channels into * File, Console, or Serial. * * Results: * Returns the new channel, or NULL. * * Side effects: * May open the channel and may cause creation of a file on the file * system. * *---------------------------------------------------------------------- */ Tcl_Channel TclWinOpenFileChannel(handle, channelName, permissions, appendMode) HANDLE handle; /* Win32 HANDLE to swallow */ char *channelName; /* Buffer to receive channel name */ int permissions; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION, indicating * which operations are valid on the file. */ int appendMode; /* OR'ed combination of bits indicating what * additional configuration of the channel is * present. */ { FileInfo *infoPtr; ThreadSpecificData *tsdPtr = FileInit(); /* * See if a channel with this handle already exists. */ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->handle == (HANDLE) handle) { return (permissions==infoPtr->validMask) ? infoPtr->channel : NULL; } } infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo)); /* * TIP #218. Removed the code inserting the new structure into the global * list. This is now handled in the thread action callbacks, and only * there. */ infoPtr->nextPtr = NULL; infoPtr->validMask = permissions; infoPtr->watchMask = 0; infoPtr->flags = appendMode; infoPtr->handle = handle; infoPtr->dirty = 0; wsprintfA(channelName, "file%lx", (int) infoPtr); infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName, (ClientData) infoPtr, permissions); /* * Files have default translation of AUTO and ^Z eof char, which means * that a ^Z will be accepted as EOF when reading. */ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); return infoPtr->channel; } /* *---------------------------------------------------------------------- * * TclWinFlushDirtyChannels -- * * Flush all dirty channels to disk, so that requesting the size of any * file returns the correct value. * * Results: * None. * * Side effects: * Information is actually written to disk now, rather than later. Don't * call this too often, or there will be a performance hit (i.e. only * call when we need to ask for the size of a file). * *---------------------------------------------------------------------- */ void TclWinFlushDirtyChannels() { FileInfo *infoPtr; ThreadSpecificData *tsdPtr = FileInit(); /* * Flush all channels which are dirty, i.e. may have data pending in the * OS. */ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->dirty) { FlushFileBuffers(infoPtr->handle); infoPtr->dirty = 0; } } } /* *---------------------------------------------------------------------- * * FileThreadActionProc -- * * Insert or remove any thread local refs to this channel. * * Results: * None. * * Side effects: * Changes thread local list of valid channels. * *---------------------------------------------------------------------- */ static void FileThreadActionProc(instanceData, action) ClientData instanceData; int action; { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileInfo *infoPtr = (FileInfo *) instanceData; if (action == TCL_CHANNEL_THREAD_INSERT) { infoPtr->nextPtr = tsdPtr->firstFilePtr; tsdPtr->firstFilePtr = infoPtr; } else { FileInfo **nextPtrPtr; int removed = 0; for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL; nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { if ((*nextPtrPtr) == infoPtr) { (*nextPtrPtr) = infoPtr->nextPtr; removed = 1; break; } } /* * This could happen if the channel was created in one thread and then * moved to another without updating the thread local data in each * thread. */ if (!removed) { Tcl_Panic("file info ptr not on thread channel list"); } } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinConsole.c.
1 2 3 | /* * tclWinConsole.c -- * | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclWinConsole.c -- * * This file implements the Windows-specific console functions, and the * "console" channel driver. * * Copyright (c) 1999 by Scriptics Corp. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinConsole.c,v 1.12.2.2 2005/08/02 18:17:00 dgp Exp $ */ #include "tclWinInt.h" #include <fcntl.h> #include <io.h> #include <sys/stat.h> |
︙ | ︙ | |||
41 42 43 44 45 46 47 | #define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ /* * Bit masks used in the sharedFlags field of the ConsoleInfo structure below. */ #define CONSOLE_EOF (1<<2) /* Console has reached EOF. */ | | | > | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | #define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ /* * Bit masks used in the sharedFlags field of the ConsoleInfo structure below. */ #define CONSOLE_EOF (1<<2) /* Console has reached EOF. */ #define CONSOLE_BUFFERED (1<<3) /* Data was read into a buffer by the reader * thread. */ #define CONSOLE_BUFFER_SIZE (8*1024) /* * This structure describes per-instance data for a console based channel. */ typedef struct ConsoleInfo { HANDLE handle; int type; |
︙ | ︙ | |||
67 68 69 70 71 72 73 | int flags; /* State flags, see above for a list. */ Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer * threads. */ HANDLE writeThread; /* Handle to writer thread. */ HANDLE readThread; /* Handle to reader thread. */ HANDLE writable; /* Manual-reset event to signal when the | | | | | | | | | | | < | | < | | | | | | | | | | | | > > | > > | | | < | | | 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 | int flags; /* State flags, see above for a list. */ Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer * threads. */ HANDLE writeThread; /* Handle to writer thread. */ HANDLE readThread; /* Handle to reader thread. */ HANDLE writable; /* Manual-reset event to signal when the * writer thread has finished waiting for the * current buffer to be written. */ HANDLE readable; /* Manual-reset event to signal when the * reader thread has finished waiting for * input. */ HANDLE startWriter; /* Auto-reset event used by the main thread to * signal when the writer thread should * attempt to write to the console. */ HANDLE stopWriter; /* Auto-reset event used by the main thread to * signal when the writer thread should exit. */ HANDLE startReader; /* Auto-reset event used by the main thread to * signal when the reader thread should * attempt to read from the console. */ HANDLE stopReader; /* Auto-reset event used by the main thread to * signal when the reader thread should exit. */ DWORD writeError; /* An error caused by the last background * write. Set to 0 if no error has been * detected. This word is shared with the * writer thread so access must be * synchronized with the writable object. */ char *writeBuf; /* Current background output buffer. Access is * synchronized with the writable object. */ int writeBufLen; /* Size of write buffer. Access is * synchronized with the writable object. */ int toWrite; /* Current amount to be written. Access is * synchronized with the writable object. */ int readFlags; /* Flags that are shared with the reader * thread. Access is synchronized with the * readable object. */ int bytesRead; /* number of bytes in the buffer */ int offset; /* number of bytes read out of the buffer */ char buffer[CONSOLE_BUFFER_SIZE]; /* Data consumed by reader thread. */ } ConsoleInfo; typedef struct ThreadSpecificData { /* * The following pointer refers to the head of the list of consoles that * are being watched for file events. */ ConsoleInfo *firstConsolePtr; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * The following structure is what is added to the Tcl event queue when * console events are generated. */ typedef struct ConsoleEvent { Tcl_Event header; /* Information that is standard for all * events. */ ConsoleInfo *infoPtr; /* Pointer to console info structure. Note * that we still have to verify that the * console exists before dereferencing this * pointer. */ } ConsoleEvent; /* * Declarations for functions used only in this file. */ static int ConsoleBlockModeProc(ClientData instanceData, int mode); static void ConsoleCheckProc(ClientData clientData, int flags); static int ConsoleCloseProc(ClientData instanceData, Tcl_Interp *interp); static int ConsoleEventProc(Tcl_Event *evPtr, int flags); static void ConsoleExitHandler(ClientData clientData); static int ConsoleGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static void ConsoleInit(void); static int ConsoleInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int ConsoleOutputProc(ClientData instanceData, CONST char *buf, int toWrite, int *errorCode); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); static void ConsoleSetupProc(ClientData clientData, int flags); static void ConsoleWatchProc(ClientData instanceData, int mask); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); static void ProcExitHandler(ClientData clientData); static int WaitForRead(ConsoleInfo *infoPtr, int blocking); static void ConsoleThreadActionProc(ClientData instanceData, int action); /* * This structure describes the channel type structure for command console * based IO. */ static Tcl_ChannelType consoleChannelType = { "console", /* Type name. */ TCL_CHANNEL_VERSION_4, /* v4 channel */ ConsoleCloseProc, /* Close proc. */ ConsoleInputProc, /* Input proc. */ ConsoleOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ ConsoleWatchProc, /* Set up notifier to watch the channel. */ ConsoleGetHandleProc, /* Get an OS handle from channel. */ NULL, /* close2proc. */ ConsoleBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc */ ConsoleThreadActionProc, /* thread action proc */ }; /* *---------------------------------------------------------------------- * * ConsoleInit -- * * This function initializes the static variables for this file. * * Results: * None. * * Side effects: * Creates a new event source. * *---------------------------------------------------------------------- */ static void ConsoleInit() { ThreadSpecificData *tsdPtr; /* * Check the initialized flag first, then check again in the mutex. This * is a speed enhancement. */ if (!initialized) { Tcl_MutexLock(&consoleMutex); if (!initialized) { initialized = 1; Tcl_CreateExitHandler(ProcExitHandler, NULL); } Tcl_MutexUnlock(&consoleMutex); } tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->firstConsolePtr = NULL; Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL); } } /* *---------------------------------------------------------------------- * * ConsoleExitHandler -- * * This function is called to cleanup the console module before Tcl is * unloaded. * * Results: * None. * * Side effects: * Removes the console event source. * |
︙ | ︙ | |||
252 253 254 255 256 257 258 | } /* *---------------------------------------------------------------------- * * ProcExitHandler -- * | | | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 | } /* *---------------------------------------------------------------------- * * ProcExitHandler -- * * This function is called to cleanup the process list before Tcl is * unloaded. * * Results: * None. * * Side effects: * Resets the process list. * |
︙ | ︙ | |||
278 279 280 281 282 283 284 | } /* *---------------------------------------------------------------------- * * ConsoleSetupProc -- * | | | | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 | } /* *---------------------------------------------------------------------- * * ConsoleSetupProc -- * * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an * event. * * Results: * None. * * Side effects: * Adjusts the block time if needed. * |
︙ | ︙ | |||
305 306 307 308 309 310 311 | ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } /* | | | 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 | ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } /* * Look to see if any events are already pending. If they are, poll. */ for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->watchMask & TCL_WRITABLE) { if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { block = 0; |
︙ | ︙ | |||
331 332 333 334 335 336 337 | } /* *---------------------------------------------------------------------- * * ConsoleCheckProc -- * | | | | 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 | } /* *---------------------------------------------------------------------- * * ConsoleCheckProc -- * * This procedure is called by Tcl_DoOneEvent to check the console event * source for events. * * Results: * None. * * Side effects: * May queue an event. * |
︙ | ︙ | |||
416 417 418 419 420 421 422 | *---------------------------------------------------------------------- */ static int ConsoleBlockModeProc( ClientData instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or | | | | | | > | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 | *---------------------------------------------------------------------- */ static int ConsoleBlockModeProc( ClientData instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; /* * Consoles on Windows can not be switched between blocking and * nonblocking, hence we have to emulate the behavior. This is done in the * input function by checking against a bit in the state. We set or unset * the bit here to cause the input function to emulate the correct * behavior. */ if (mode == TCL_MODE_NONBLOCKING) { infoPtr->flags |= CONSOLE_ASYNC; } else { infoPtr->flags &= ~(CONSOLE_ASYNC); } |
︙ | ︙ | |||
465 466 467 468 469 470 471 | ConsoleInfo *infoPtr, **nextPtrPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); DWORD exitCode; errorCode = 0; /* | | | | < | | < | | | | | < | | | | | | > | | | | | | | | < | | | | | 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 | ConsoleInfo *infoPtr, **nextPtrPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); DWORD exitCode; errorCode = 0; /* * Clean up the background thread if necessary. Note that this must be * done before we can close the file, since the thread may be blocking * trying to read from the console. */ if (consolePtr->readThread) { /* * The thread may already have closed on it's own. Check it's exit * code. */ GetExitCodeThread(consolePtr->readThread, &exitCode); if (exitCode == STILL_ACTIVE) { /* * Set the stop event so that if the reader thread is blocked in * ConsoleReaderThread on WaitForMultipleEvents, it will exit * cleanly. */ SetEvent(consolePtr->stopReader); /* * Wait at most 20 milliseconds for the reader thread to close. */ if (WaitForSingleObject(consolePtr->readThread, 20) == WAIT_TIMEOUT) { /* * Forcibly terminate the background thread as a last resort. * Note that we need to guard against terminating the thread * while it is in the middle of Tcl_ThreadAlert because it * won't be able to release the notifier lock. */ Tcl_MutexLock(&consoleMutex); /* BUG: this leaks memory. */ TerminateThread(consolePtr->readThread, 0); Tcl_MutexUnlock(&consoleMutex); } } CloseHandle(consolePtr->readThread); CloseHandle(consolePtr->readable); CloseHandle(consolePtr->startReader); CloseHandle(consolePtr->stopReader); consolePtr->readThread = NULL; } consolePtr->validMask &= ~TCL_READABLE; /* * Wait for the writer thread to finish the current buffer, then terminate * the thread and close the handles. If the channel is nonblocking, there * should be no pending write operations. */ if (consolePtr->writeThread) { if (consolePtr->toWrite) { /* * We only need to wait if there is something to write. This may * prevent infinite wait on exit. [python bug 216289] */ WaitForSingleObject(consolePtr->writable, INFINITE); } /* * The thread may already have closed on it's own. Check it's exit * code. */ GetExitCodeThread(consolePtr->writeThread, &exitCode); if (exitCode == STILL_ACTIVE) { /* * Set the stop event so that if the reader thread is blocked in * ConsoleWriterThread on WaitForMultipleEvents, it will exit * cleanly. */ SetEvent(consolePtr->stopWriter); /* * Wait at most 20 milliseconds for the writer thread to close. */ if (WaitForSingleObject(consolePtr->writeThread, 20) == WAIT_TIMEOUT) { /* * Forcibly terminate the background thread as a last resort. * Note that we need to guard against terminating the thread * while it is in the middle of Tcl_ThreadAlert because it * won't be able to release the notifier lock. */ Tcl_MutexLock(&consoleMutex); /* BUG: this leaks memory. */ TerminateThread(consolePtr->writeThread, 0); Tcl_MutexUnlock(&consoleMutex); } } CloseHandle(consolePtr->writeThread); CloseHandle(consolePtr->writable); CloseHandle(consolePtr->startWriter); CloseHandle(consolePtr->stopWriter); consolePtr->writeThread = NULL; } consolePtr->validMask &= ~TCL_WRITABLE; /* * Don't close the Win32 handle if the handle is a standard channel during * the thread exit process. Otherwise, one thread may kill the stdio of * another. */ if (!TclInThreadExit() || ((GetStdHandle(STD_INPUT_HANDLE) != consolePtr->handle) && (GetStdHandle(STD_OUTPUT_HANDLE) != consolePtr->handle) && (GetStdHandle(STD_ERROR_HANDLE) != consolePtr->handle))) { if (CloseHandle(consolePtr->handle) == FALSE) { |
︙ | ︙ | |||
625 626 627 628 629 630 631 | } /* *---------------------------------------------------------------------- * * ConsoleInputProc -- * | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * ConsoleInputProc -- * * Reads input from the IO channel into the buffer given. Returns count * of how many bytes were actually read, and an error indication. * * Results: * A count of how many bytes were read is returned and an error * indication is returned in an output argument. * * Side effects: * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int ConsoleInputProc( ClientData instanceData, /* Console state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ int *errorCode) /* Where to store error code. */ { ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; DWORD count, bytesRead = 0; int result; *errorCode = 0; |
︙ | ︙ | |||
692 693 694 695 696 697 698 | infoPtr->offset = 0; } return bytesRead; } /* | | | | | | | | | | 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 | infoPtr->offset = 0; } return bytesRead; } /* * Attempt to read bufSize bytes. The read will return immediately if * there is any data available. Otherwise it will block until at least one * byte is available or an EOF occurs. */ if (ReadConsole(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &count, (LPOVERLAPPED) NULL) == TRUE) { buf[count] = '\0'; return count; } return -1; } /* *---------------------------------------------------------------------- * * ConsoleOutputProc -- * * Writes the given output on the IO channel. Returns count of how many * characters were actually written, and an error indication. * * Results: * A count of how many characters were written is returned and an error * indication is returned in an output argument. * * Side effects: * Writes output on the actual channel. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
738 739 740 741 742 743 744 | ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; DWORD bytesWritten, timeout; *errorCode = 0; timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 0 : INFINITE; if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) { /* | | | | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 | ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; DWORD bytesWritten, timeout; *errorCode = 0; timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 0 : INFINITE; if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) { /* * The writer thread is blocked waiting for a write to complete and * the channel is in non-blocking mode. */ errno = EAGAIN; goto error; } /* |
︙ | ︙ | |||
780 781 782 783 784 785 786 | memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; ResetEvent(infoPtr->writable); SetEvent(infoPtr->startWriter); bytesWritten = toWrite; } else { /* | | | | | | | | | | | | | | | | | | | | 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 | memcpy(infoPtr->writeBuf, buf, toWrite); infoPtr->toWrite = toWrite; ResetEvent(infoPtr->writable); SetEvent(infoPtr->startWriter); bytesWritten = toWrite; } else { /* * In the blocking case, just try to write the buffer directly. This * avoids an unnecessary copy. */ if (WriteConsole(infoPtr->handle, buf, toWrite, &bytesWritten, NULL) == FALSE) { TclWinConvertError(GetLastError()); goto error; } } return bytesWritten; error: *errorCode = errno; return -1; } /* *---------------------------------------------------------------------- * * ConsoleEventProc -- * * This function is invoked by Tcl_ServiceEvent when a file event reaches * the front of the event queue. This procedure invokes Tcl_NotifyChannel * on the console. * * Results: * Returns 1 if the event was handled, meaning it should be removed from * the queue. Returns 0 if the event was not handled, meaning it should * stay on the queue. The only time the event isn't handled is if the * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the notifier callback does. * *---------------------------------------------------------------------- */ static int ConsoleEventProc( Tcl_Event *evPtr, /* Event to service. */ int flags) /* Flags that indicate what events to handle, * such as TCL_FILE_EVENTS. */ { ConsoleEvent *consoleEvPtr = (ConsoleEvent *)evPtr; ConsoleInfo *infoPtr; int mask; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return 0; } /* * Search through the list of watched consoles for the one whose handle * matches the event. We do this rather than simply dereferencing the * handle in the event so that consoles can be deleted while the event is * in the queue. */ for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (consoleEvPtr->infoPtr == infoPtr) { infoPtr->flags &= ~(CONSOLE_PENDING); break; } } /* * Remove stale events. */ if (!infoPtr) { return 1; } /* * Check to see if the console is readable. Note that we can't tell if a * console is writable, so we always report it as being writable unless we * have detected EOF. */ mask = 0; if (infoPtr->watchMask & TCL_WRITABLE) { if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { mask = TCL_WRITABLE; } |
︙ | ︙ | |||
892 893 894 895 896 897 898 | } /* *---------------------------------------------------------------------- * * ConsoleWatchProc -- * | | < | | | | | | < < | | | | | | | | | | < | | | | | | | | | | | < | | < | > | | | | 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 | } /* *---------------------------------------------------------------------- * * ConsoleWatchProc -- * * Called by the notifier to set up to watch for events on this channel. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void ConsoleWatchProc( ClientData instanceData, /* Console state. */ int mask) /* What events to watch for, OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { ConsoleInfo **nextPtrPtr, *ptr; ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; int oldMask = infoPtr->watchMask; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Since most of the work is handled by the background threads, we just * need to update the watchMask and then force the notifier to poll once. */ infoPtr->watchMask = mask & infoPtr->validMask; if (infoPtr->watchMask) { Tcl_Time blockTime = { 0, 0 }; if (!oldMask) { infoPtr->nextPtr = tsdPtr->firstConsolePtr; tsdPtr->firstConsolePtr = infoPtr; } Tcl_SetMaxBlockTime(&blockTime); } else if (oldMask) { /* * Remove the console from the list of watched consoles. */ for (nextPtrPtr = &(tsdPtr->firstConsolePtr), ptr = *nextPtrPtr; ptr != NULL; nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { if (infoPtr == ptr) { *nextPtrPtr = ptr->nextPtr; break; } } } } /* *---------------------------------------------------------------------- * * ConsoleGetHandleProc -- * * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a * command consoleline based channel. * * Results: * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ConsoleGetHandleProc( ClientData instanceData, /* The console state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ ClientData *handlePtr) /* Where to store the handle. */ { ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; *handlePtr = (ClientData) infoPtr->handle; return TCL_OK; } /* *---------------------------------------------------------------------- * * WaitForRead -- * * Wait until some data is available, the console is at EOF or the reader * thread is blocked waiting for data (if the channel is in non-blocking * mode). * * Results: * Returns 1 if console is readable. Returns 0 if there is no data on the * console, but there is buffered data. Returns -1 if an error occurred. * If an error occurred, the threads may not be synchronized. * * Side effects: * Updates the shared state flags. If no error occurred, the reader * thread is blocked waiting for a signal from the main thread. * *---------------------------------------------------------------------- */ static int WaitForRead( ConsoleInfo *infoPtr, /* Console state. */ int blocking) /* Indicates whether call should be * blocking or not. */ { DWORD timeout, count; HANDLE *handle = infoPtr->handle; INPUT_RECORD input; while (1) { /* * Synchronize with the reader thread. */ timeout = blocking ? INFINITE : 0; if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) { /* * The reader thread is blocked waiting for data and the channel * is in non-blocking mode. */ errno = EAGAIN; return -1; } /* * At this point, the two threads are synchronized, so it is safe to * access shared state. */ /* * If the console has hit EOF, it is always readable. */ if (infoPtr->readFlags & CONSOLE_EOF) { return 1; } if (PeekConsoleInput(handle, &input, 1, &count) == FALSE) { /* * Check to see if the peek failed because of EOF. */ TclWinConvertError(GetLastError()); if (errno == EOF) { infoPtr->readFlags |= CONSOLE_EOF; |
︙ | ︙ | |||
1063 1064 1065 1066 1067 1068 1069 | return 0; } else { return -1; } } /* | | | < | < | | | | | | 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 | return 0; } else { return -1; } } /* * If there is data in the buffer, the console must be readable (since * it is a line-oriented device). */ if (infoPtr->readFlags & CONSOLE_BUFFERED) { return 1; } /* * There wasn't any data available, so reset the thread and try again. */ ResetEvent(infoPtr->readable); SetEvent(infoPtr->startReader); } } /* *---------------------------------------------------------------------- * * ConsoleReaderThread -- * * This function runs in a separate thread and waits for input to become * available on a console. * * Results: * None. * * Side effects: * Signals the main thread when input become available. May cause the * main thread to wake up by posting a message. May one line from the * console for each wait operation. * *---------------------------------------------------------------------- */ static DWORD WINAPI ConsoleReaderThread(LPVOID arg) { |
︙ | ︙ | |||
1122 1123 1124 1125 1126 1127 1128 | * Wait for the main thread to signal before attempting to wait. */ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); if (waitResult != (WAIT_OBJECT_0 + 1)) { /* | | | | | > | | | | | > > > > > | > | | > | | | 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 | * Wait for the main thread to signal before attempting to wait. */ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); if (waitResult != (WAIT_OBJECT_0 + 1)) { /* * The start event was not signaled. It must be the stop event or * an error, so exit this thread. */ break; } count = 0; /* * Look for data on the console, but first ignore any events that are * not KEY_EVENTs. */ if (ReadConsoleA(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE, (LPDWORD) &infoPtr->bytesRead, NULL) != FALSE) { /* * Data was stored in the buffer. */ infoPtr->readFlags |= CONSOLE_BUFFERED; } else { DWORD err; err = GetLastError(); if (err == EOF) { infoPtr->readFlags = CONSOLE_EOF; } } /* * Signal the main thread by signalling the readable event and then * waking up the notifier thread. */ SetEvent(infoPtr->readable); /* * Alert the foreground thread. Note that we need to treat this like a * critical section so the foreground thread does not terminate this * thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&consoleMutex); if (infoPtr->threadId != NULL) { /* * TIP #218. When in flight ignore the event, no one will receive * it anyway. */ Tcl_ThreadAlert(infoPtr->threadId); } Tcl_MutexUnlock(&consoleMutex); } return 0; } /* *---------------------------------------------------------------------- * * ConsoleWriterThread -- * * This function runs in a separate thread and writes data onto a * console. * * Results: * Always returns 0. * * Side effects: * Signals the main thread when an output operation is completed. May * cause the main thread to wake up by posting a message. * *---------------------------------------------------------------------- */ static DWORD WINAPI ConsoleWriterThread(LPVOID arg) { |
︙ | ︙ | |||
1213 1214 1215 1216 1217 1218 1219 | * Wait for the main thread to signal before attempting to write. */ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); if (waitResult != (WAIT_OBJECT_0 + 1)) { /* | | | | 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 | * Wait for the main thread to signal before attempting to write. */ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); if (waitResult != (WAIT_OBJECT_0 + 1)) { /* * The start event was not signaled. It must be the stop event or * an error, so exit this thread. */ break; } buf = infoPtr->writeBuf; toWrite = infoPtr->toWrite; |
︙ | ︙ | |||
1238 1239 1240 1241 1242 1243 1244 | } else { toWrite -= count; buf += count; } } /* | | | | | | > > > > > | > | | < | > > > | | | | < < | | < > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } else { toWrite -= count; buf += count; } } /* * Signal the main thread by signalling the writable event and then * waking up the notifier thread. */ SetEvent(infoPtr->writable); /* * Alert the foreground thread. Note that we need to treat this like a * critical section so the foreground thread does not terminate this * thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&consoleMutex); if (infoPtr->threadId != NULL) { /* * TIP #218. When in flight ignore the event, no one will receive * it anyway. */ Tcl_ThreadAlert(infoPtr->threadId); } Tcl_MutexUnlock(&consoleMutex); } return 0; } /* *---------------------------------------------------------------------- * * TclWinOpenConsoleChannel -- * * Constructs a Console channel for the specified standard OS handle. * This is a helper function to break up the construction of channels * into File, Console, or Serial. * * Results: * Returns the new channel, or NULL. * * Side effects: * May open the channel * *---------------------------------------------------------------------- */ Tcl_Channel TclWinOpenConsoleChannel(handle, channelName, permissions) HANDLE handle; char *channelName; int permissions; { char encoding[4 + TCL_INTEGER_SPACE]; ConsoleInfo *infoPtr; DWORD id, modes; ConsoleInit(); /* * See if a channel with this handle already exists. */ infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo)); memset(infoPtr, 0, sizeof(ConsoleInfo)); infoPtr->validMask = permissions; infoPtr->handle = handle; infoPtr->channel = (Tcl_Channel) NULL; wsprintfA(encoding, "cp%d", GetConsoleCP()); infoPtr->threadId = Tcl_GetCurrentThread(); /* * Use the pointer for the name of the result channel. This keeps the * channel names unique, since some may share handles (stdin/stdout/stderr * for instance). */ wsprintfA(channelName, "file%lx", (int) infoPtr); infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName, (ClientData) infoPtr, permissions); if (permissions & TCL_READABLE) { /* * Make sure the console input buffer is ready for only character * input notifications and the buffer is set for line buffering. IOW, * we only want to catch when complete lines are ready for reading. */ GetConsoleMode(infoPtr->handle, &modes); modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); modes |= ENABLE_LINE_INPUT; SetConsoleMode(infoPtr->handle, modes); infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL); infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->stopReader = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->readThread = CreateThread(NULL, 256, ConsoleReaderThread, infoPtr, 0, &id); SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); } if (permissions & TCL_WRITABLE) { infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL); infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->stopWriter = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->writeThread = CreateThread(NULL, 256, ConsoleWriterThread, infoPtr, 0, &id); SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST); } /* * Files have default translation of AUTO and ^Z eof char, which means * that a ^Z will be accepted as EOF when reading. */ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding); return infoPtr->channel; } /* *---------------------------------------------------------------------- * * ConsoleThreadActionProc -- * * Insert or remove any thread local refs to this channel. * * Results: * None. * * Side effects: * Changes thread local list of valid channels. * *---------------------------------------------------------------------- */ static void ConsoleThreadActionProc (instanceData, action) ClientData instanceData; int action; { ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; /* We do not access firstConsolePtr in the thread structures. This is not * for all serials managed by the thread, but only those we are watching. * Removal of the filevent handlers before transfer thus takes care of * this structure. */ Tcl_MutexLock(&consoleMutex); if (action == TCL_CHANNEL_THREAD_INSERT) { /* * We can't copy the thread information from the channel when the * channel is created. At this time the channel back pointer has not * been set yet. However in that case the threadId has already been * set by TclpCreateCommandChannel itself, so the structure is still * good. */ ConsoleInit(); if (infoPtr->channel != NULL) { infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel); } } else { infoPtr->threadId = NULL; } Tcl_MutexUnlock(&consoleMutex); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinDde.c.
1 2 3 | /* * tclWinDde.c -- * | | | < | | | | | | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | /* * tclWinDde.c -- * * This file provides functions that implement the "send" command, * allowing commands to be passed from interpreter to interpreter. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinDde.c,v 1.26.2.1 2005/08/02 18:17:01 dgp Exp $ */ #include "tclInt.h" #include <dde.h> #include <ddeml.h> #include <tchar.h> /* * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init * declaration is in the source file itself, which is only accessed when we * are building a library. DO NOT MOVE BEFORE ANY #include LINES. ONLY USE * EXTERN TO INDICATE EXPORTED FUNCTIONS FROM NOW ON. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLEXPORT /* * The following structure is used to keep track of the interpreters |
︙ | ︙ | |||
61 62 63 64 65 66 67 | ATOM service; ATOM topic; HWND hwnd; }; typedef struct ThreadSpecificData { Conversation *currentConversations; | | | | | | | | | | | | 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 | ATOM service; ATOM topic; HWND hwnd; }; typedef struct ThreadSpecificData { Conversation *currentConversations; /* A list of conversations currently being * processed. */ RegisteredInterp *interpListPtr; /* List of all interpreters registered in the * current process. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * The following variables cannot be placed in thread-local storage. The Mutex * ddeMutex guards access to the ddeInstance. */ static HSZ ddeServiceGlobal = 0; static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; #define TCL_DDE_VERSION "1.3.1" #define TCL_DDE_PACKAGE_NAME "dde" #define TCL_DDE_SERVICE_NAME "TclEval" #define TCL_DDE_EXECUTE_RESULT "$TCLEVAL$EXECUTE$RESULT" TCL_DECLARE_MUTEX(ddeMutex) /* * Forward declarations for functions defined later in this file. */ static LRESULT CALLBACK DdeClientWindowProc _ANSI_ARGS_(( HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam)); static int DdeCreateClient _ANSI_ARGS_(( struct DdeEnumServices *es)); static BOOL CALLBACK DdeEnumWindowsCallback _ANSI_ARGS_(( HWND hwndTarget, LPARAM lParam)); static void DdeExitProc _ANSI_ARGS_((ClientData clientData)); static int DdeGetServicesList _ANSI_ARGS_((Tcl_Interp *interp, char *serviceName, char *topicName)); static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType, UINT uFmt, HCONV hConv, HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData, DWORD dwData1, DWORD dwData2)); static LRESULT DdeServicesOnAck _ANSI_ARGS_((HWND hwnd, WPARAM wParam, LPARAM lParam)); |
︙ | ︙ | |||
125 126 127 128 129 130 131 | EXTERN int Dde_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); /* *---------------------------------------------------------------------- * * Dde_Init -- * | | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | EXTERN int Dde_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); /* *---------------------------------------------------------------------- * * Dde_Init -- * * This function initializes the dde command. * * Results: * A standard Tcl result. * * Side effects: * None. * |
︙ | ︙ | |||
157 158 159 160 161 162 163 | } /* *---------------------------------------------------------------------- * * Dde_SafeInit -- * | | | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | } /* *---------------------------------------------------------------------- * * Dde_SafeInit -- * * This function initializes the dde command within a safe interp * * Results: * A standard Tcl result. * * Side effects: * None. * |
︙ | ︙ | |||
202 203 204 205 206 207 208 | static void Initialize(void) { int nameFound = 0; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* | | | | | | | 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 | static void Initialize(void) { int nameFound = 0; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * See if the application is already registered; if so, remove its current * name from the registry. The deletion of the command will take care of * disposing of this entry. */ if (tsdPtr->interpListPtr != NULL) { nameFound = 1; } /* * Make sure that the DDE server is there. This is done only once, add an * exit handler tear it down. */ if (ddeInstance == 0) { Tcl_MutexLock(&ddeMutex); if (ddeInstance == 0) { if (DdeInitialize(&ddeInstance, DdeServerProc, CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS |
︙ | ︙ | |||
247 248 249 250 251 252 253 | } /* *---------------------------------------------------------------------- * * DdeSetServerName -- * | | | | | | | | | | | | | | | | | | | | | < | | > | | | < > | > > | 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 | } /* *---------------------------------------------------------------------- * * DdeSetServerName -- * * This function is called to associate an ASCII name with a Dde server. * If the interpreter has already been named, the name replaces the old * one. * * Results: * The return value is the name actually given to the interp. This will * normally be the same as name, but if name was already in use for a Dde * Server then a name of the form "name #2" will be chosen, with a high * enough number to make the name unique. * * Side effects: * Registration info is saved, thereby allowing the "send" command to be * used later to invoke commands in the application. In addition, the * "send" command is created in the application's interpreter. The * registration will be removed automatically if the interpreter is * deleted or the "send" command is removed. * *---------------------------------------------------------------------- */ static char * DdeSetServerName(interp, name, exactName, handlerPtr) Tcl_Interp *interp; char *name; /* The name that will be used to refer to the * interpreter in later "send" commands. Must * be globally unique. */ int exactName; /* Should we make a unique name? 0 = unique */ Tcl_Obj *handlerPtr; /* Name of the optional proc/command to handle * incoming Dde eval's */ { int suffix, offset; RegisteredInterp *riPtr, *prevPtr; Tcl_DString dString; char *actualName; Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; int n, srvCount = 0, lastSuffix, r = TCL_OK; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * See if the application is already registered; if so, remove its current * name from the registry. The deletion of the command will take care of * disposing of this entry. */ for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL; prevPtr = riPtr, riPtr = riPtr->nextPtr) { if (riPtr->interp == interp) { if (name != NULL) { if (prevPtr == NULL) { tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr; } else { prevPtr->nextPtr = riPtr->nextPtr; } break; } else { /* * The name was NULL, so the caller is asking for the name of * the current interp. */ return riPtr->name; } } } if (name == NULL) { /* * The name was NULL, so the caller is asking for the name of the * current interp, but it doesn't have a name. */ return ""; } /* * Get the list of currently registered Tcl interpreters by calling the * internal implementation of the 'dde services' command. */ Tcl_DStringInit(&dString); actualName = name; if (!exactName) { r = DdeGetServicesList(interp, TCL_DDE_SERVICE_NAME, NULL); if (r == TCL_OK) { srvListPtr = Tcl_GetObjResult(interp); } if (r == TCL_OK) { r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount, &srvPtrPtr); } if (r != TCL_OK) { OutputDebugString(Tcl_GetStringResult(interp)); return NULL; } /* * Pick a name to use for the application. Use "name" if it's not * already in use. Otherwise add a suffix such as " #2", trying larger * and larger numbers until we eventually find one that is unique. */ offset = lastSuffix = 0; suffix = 1; while (suffix != lastSuffix) { lastSuffix = suffix; if (suffix > 1) { if (suffix == 2) { Tcl_DStringAppend(&dString, name, -1); Tcl_DStringAppend(&dString, " #", 2); offset = Tcl_DStringLength(&dString); Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE); actualName = Tcl_DStringValue(&dString); } sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix); } /* * See if the name is already in use, if so increment suffix. */ for (n = 0; n < srvCount; ++n) { Tcl_Obj* namePtr; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) { suffix++; break; |
︙ | ︙ | |||
406 407 408 409 410 411 412 | (ClientData) riPtr, DeleteProc); if (Tcl_IsSafe(interp)) { Tcl_HideCommand(interp, "dde", "dde"); } Tcl_DStringFree(&dString); /* | | > | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 | (ClientData) riPtr, DeleteProc); if (Tcl_IsSafe(interp)) { Tcl_HideCommand(interp, "dde", "dde"); } Tcl_DStringFree(&dString); /* * Re-initialize with the new name. */ Initialize(); return riPtr->name; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
450 451 452 453 454 455 456 | } /* *---------------------------------------------------------------------- * * DeleteProc * | | | | | 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 | } /* *---------------------------------------------------------------------- * * DeleteProc * * This function is called when the command "dde" is destroyed. * * Results: * none * * Side effects: * The interpreter given by riPtr is unregistered. * *---------------------------------------------------------------------- */ static void DeleteProc(clientData) ClientData clientData; /* The interp we are deleting passed as * ClientData. */ { RegisteredInterp *riPtr = (RegisteredInterp *) clientData; RegisteredInterp *searchPtr, *prevPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL; searchPtr != NULL && searchPtr != riPtr; |
︙ | ︙ | |||
497 498 499 500 501 502 503 | } /* *---------------------------------------------------------------------- * * ExecuteRemoteObject -- * | | | | | | < | | | | | > | > > | 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 | } /* *---------------------------------------------------------------------- * * ExecuteRemoteObject -- * * Takes the package delivered by DDE and executes it in the server's * interpreter. * * Results: * A list Tcl_Obj * that describes what happened. The first element is * the numerical return code (TCL_ERROR, etc.). The second element is the * result of the script. If the return result was TCL_ERROR, then the * third element will be the value of the global "errorCode", and the * fourth will be the value of the global "errorInfo". The return result * will have a refCount of 0. * * Side effects: * A Tcl script is run, which can cause all kinds of other things to * happen. * *---------------------------------------------------------------------- */ static Tcl_Obj * ExecuteRemoteObject(riPtr, ddeObjectPtr) RegisteredInterp *riPtr; /* Info about this server. */ Tcl_Obj *ddeObjectPtr; /* The object to execute. */ { Tcl_Obj *returnPackagePtr; int result = TCL_OK; if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: " "a handler procedure must be defined for use in a safe " "interp", -1)); result = TCL_ERROR; } if (riPtr->handlerPtr != NULL) { /* * Add the dde request data to the handler proc list. */ Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr); result = Tcl_ListObjAppendElement(riPtr->interp, cmdPtr, ddeObjectPtr); if (result == TCL_OK) { ddeObjectPtr = cmdPtr; } } |
︙ | ︙ | |||
572 573 574 575 576 577 578 | } /* *---------------------------------------------------------------------- * * DdeServerProc -- * | | | | | | | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 | } /* *---------------------------------------------------------------------- * * DdeServerProc -- * * Handles all transactions for this server. Can handle execute, request, * and connect protocols. Dde will call this routine when a client * attempts to run a dde command using this server. * * Results: * A DDE Handle with the result of the dde command. * * Side effects: * Depending on which command is executed, arbitrary Tcl scripts can be * run. * *---------------------------------------------------------------------- */ static HDDEDATA CALLBACK DdeServerProc(uType, uFmt, hConv, ddeTopic, ddeItem, hData, dwData1, dwData2) UINT uType; /* The type of DDE transaction we are |
︙ | ︙ | |||
610 611 612 613 614 615 616 | HDDEDATA ddeReturn = NULL; RegisteredInterp *riPtr; Conversation *convPtr, *prevConvPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); switch(uType) { case XTYP_CONNECT: | < | | | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 | HDDEDATA ddeReturn = NULL; RegisteredInterp *riPtr; Conversation *convPtr, *prevConvPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); switch(uType) { case XTYP_CONNECT: /* * Dde is trying to initialize a conversation with us. Check and make * sure we have a valid topic. */ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); Tcl_DStringInit(&dString); Tcl_DStringSetLength(&dString, len); utilString = Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, |
︙ | ︙ | |||
635 636 637 638 639 640 641 | } } Tcl_DStringFree(&dString); return (HDDEDATA) FALSE; case XTYP_CONNECT_CONFIRM: | < | | | < | 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 | } } Tcl_DStringFree(&dString); return (HDDEDATA) FALSE; case XTYP_CONNECT_CONFIRM: /* * Dde has decided that we can connect, so it gives us a conversation * handle. We need to keep track of it so we know which execution * result to return in an XTYP_REQUEST. */ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); Tcl_DStringInit(&dString); Tcl_DStringSetLength(&dString, len); utilString = Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, |
︙ | ︙ | |||
665 666 667 668 669 670 671 | break; } } Tcl_DStringFree(&dString); return (HDDEDATA) TRUE; case XTYP_DISCONNECT: | < | 665 666 667 668 669 670 671 672 673 674 675 676 677 678 | break; } } Tcl_DStringFree(&dString); return (HDDEDATA) TRUE; case XTYP_DISCONNECT: /* * The client has disconnected from our server. Forget this * conversation. */ for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL; convPtr != NULL; |
︙ | ︙ | |||
690 691 692 693 694 695 696 | ckfree((char *) convPtr); break; } } return (HDDEDATA) TRUE; case XTYP_REQUEST: | < | | | | 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 | ckfree((char *) convPtr); break; } } return (HDDEDATA) TRUE; case XTYP_REQUEST: /* * This could be either a request for a value of a Tcl variable, or it * could be the send command requesting the results of the last * execute. */ if (uFmt != CF_TEXT) { return (HDDEDATA) FALSE; } ddeReturn = (HDDEDATA) FALSE; |
︙ | ︙ | |||
746 747 748 749 750 751 752 | } } Tcl_DStringFree(&dString); } return ddeReturn; case XTYP_EXECUTE: { | < | | < | 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 | } } Tcl_DStringFree(&dString); } return ddeReturn; case XTYP_EXECUTE: { /* * Execute this script. The results will be saved into a list object * which will be retreived later. See ExecuteRemoteObject. */ Tcl_Obj *returnPackagePtr; for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { /* |
︙ | ︙ | |||
797 798 799 800 801 802 803 | return (HDDEDATA) DDE_FNOTPROCESSED; } else { return (HDDEDATA) DDE_FACK; } } case XTYP_WILDCONNECT: { | < | 793 794 795 796 797 798 799 800 801 802 803 804 805 806 | return (HDDEDATA) DDE_FNOTPROCESSED; } else { return (HDDEDATA) DDE_FACK; } } case XTYP_WILDCONNECT: { /* * Dde wants a list of services and topics that we support. */ HSZPAIR *returnPtr; int i; int numItems; |
︙ | ︙ | |||
866 867 868 869 870 871 872 | } /* *---------------------------------------------------------------------- * * MakeDdeConnection -- * | | | | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 | } /* *---------------------------------------------------------------------- * * MakeDdeConnection -- * * This function is a utility used to connect to a DDE server when given * a server name and a topic name. * * Results: * A standard Tcl result. * * Side effects: * Passes back a conversation through ddeConvPtr * |
︙ | ︙ | |||
911 912 913 914 915 916 917 | } /* *---------------------------------------------------------------------- * * DdeGetServicesList -- * | | | | | < | 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 | } /* *---------------------------------------------------------------------- * * DdeGetServicesList -- * * This function obtains the list of DDE services. * * The functions between here and this function are all involved with * handling the DDE callbacks for this. They are: DdeCreateClient, * DdeClientWindowProc, DdeServicesOnAck, and DdeEnumWindowsCallback * * Results: * A standard Tcl result. * * Side effects: * Sets the services list into the interp result. * |
︙ | ︙ | |||
941 942 943 944 945 946 947 | memset(&wc, 0, sizeof(wc)); wc.cbSize = sizeof(wc); wc.lpfnWndProc = DdeClientWindowProc; wc.lpszClassName = szDdeClientClassName; wc.cbWndExtra = sizeof(struct DdeEnumServices *); | > | > > | 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 | memset(&wc, 0, sizeof(wc)); wc.cbSize = sizeof(wc); wc.lpfnWndProc = DdeClientWindowProc; wc.lpszClassName = szDdeClientClassName; wc.cbWndExtra = sizeof(struct DdeEnumServices *); /* * Register and create the callback window. */ RegisterClassEx(&wc); es->hwnd = CreateWindowEx(0, szDdeClientClassName, szDdeClientWindowName, WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es); return TCL_OK; } static LRESULT CALLBACK |
︙ | ︙ | |||
1026 1027 1028 1029 1030 1031 1032 | } if (Tcl_ListObjAppendElement(es->interp, resultPtr, matchPtr) == TCL_OK) { Tcl_SetObjResult(es->interp, resultPtr); } } | > | > > | | | 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 | } if (Tcl_ListObjAppendElement(es->interp, resultPtr, matchPtr) == TCL_OK) { Tcl_SetObjResult(es->interp, resultPtr); } } /* * Tell the server we are no longer interested. */ PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L); return 0L; } static BOOL CALLBACK DdeEnumWindowsCallback(hwndTarget, lParam) HWND hwndTarget; LPARAM lParam; { LRESULT dwResult = 0; struct DdeEnumServices *es = (struct DdeEnumServices *) lParam; SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000, &dwResult); return TRUE; } static int DdeGetServicesList(interp, serviceName, topicName) Tcl_Interp *interp; char *serviceName, *topicName; { struct DdeEnumServices es; |
︙ | ︙ | |||
1079 1080 1081 1082 1083 1084 1085 | } /* *---------------------------------------------------------------------- * * SetDdeError -- * | | | | 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 | } /* *---------------------------------------------------------------------- * * SetDdeError -- * * Sets the interp result to a cogent error message describing the last * DDE error. * * Results: * None. * * Side effects: * The interp's result object is changed. * |
︙ | ︙ | |||
1121 1122 1123 1124 1125 1126 1127 | } /* *---------------------------------------------------------------------- * * Tcl_DdeObjCmd -- * | | | | 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 | } /* *---------------------------------------------------------------------- * * Tcl_DdeObjCmd -- * * This function is invoked to process the "dde" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
1192 1193 1194 1195 1196 1197 1198 | switch ((enum DdeSubcommands) index) { case DDE_SERVERNAME: for (i = 2; i < objc; i++) { enum DdeSrvOptions argIndex; if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions, "option", 0, (int *) &argIndex) != TCL_OK) { /* | | | > | > | 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 | switch ((enum DdeSubcommands) index) { case DDE_SERVERNAME: for (i = 2; i < objc; i++) { enum DdeSrvOptions argIndex; if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions, "option", 0, (int *) &argIndex) != TCL_OK) { /* * If it is the last argument, it might be a server name * instead of a bad argument. */ if (i != objc-1) { return TCL_ERROR; } Tcl_ResetResult(interp); break; } if (argIndex == DDE_SERVERNAME_EXACT) { exact = 1; } else if (argIndex == DDE_SERVERNAME_HANDLER) { if ((objc - i) == 1) { /* return current handler */ RegisteredInterp *riPtr = DdeGetRegistrationPtr(interp); if (riPtr && riPtr->handlerPtr) { Tcl_SetObjResult(interp, riPtr->handlerPtr); } else { Tcl_ResetResult(interp); } return TCL_OK; } |
︙ | ︙ | |||
1267 1268 1269 1270 1271 1272 1273 | if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0, &dummy) == TCL_OK) { binary = 1; firstArg = 3; break; } } | > > | > > | > | 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 | if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0, &dummy) == TCL_OK) { binary = 1; firstArg = 3; break; } } /* * Otherwise ... */ Tcl_WrongNumArgs(interp, 2, objv, "?-binary? serviceName topicName value"); return TCL_ERROR; case DDE_SERVICES: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "serviceName topicName"); return TCL_ERROR; } firstArg = 2; break; case DDE_EVAL: if (objc < 4) { wrongDdeEvalArgs: Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args"); return TCL_ERROR; } else { int dummy; firstArg = 2; if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0, &dummy) == TCL_OK) { if (objc < 5) { goto wrongDdeEvalArgs; } async = 1; |
︙ | ︙ | |||
1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 | SetDdeError(interp); result = TCL_ERROR; } break; } case DDE_REQUEST: { char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length); if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot request value of null data", -1)); result = TCL_ERROR; goto cleanup; } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); | > | 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 | SetDdeError(interp); result = TCL_ERROR; } break; } case DDE_REQUEST: { char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length); if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot request value of null data", -1)); result = TCL_ERROR; goto cleanup; } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); |
︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 | goto cleanup; } objc -= (async + 3); ((Tcl_Obj **) objv) += (async + 3); /* | | | | | | | < | | | | | | | | 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 | goto cleanup; } objc -= (async + 3); ((Tcl_Obj **) objv) += (async + 3); /* * See if the target interpreter is local. If so, execute the command * directly without going through the DDE server. Don't exchange * objects between interps. The target interp could compile an object, * producing a bytecode structure that refers to other objects owned * by the target interp. If the target interp is then deleted, the * bytecode structure would be referring to deallocated objects. */ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { if (stricmp(serviceName, riPtr->name) == 0) { break; } } if (riPtr != NULL) { Tcl_Interp *sendInterp; /* * This command is to a local interp. No need to go through the * server. */ Tcl_Preserve((ClientData) riPtr); sendInterp = riPtr->interp; Tcl_Preserve((ClientData) sendInterp); /* * Don't exchange objects between interps. The target interp would * compile an object, producing a bytecode structure that refers * to other objects owned by the target interp. If the target * interp is then deleted, the bytecode structure would be * referring to deallocated objects. */ if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) { Tcl_SetResult(riPtr->interp, "permission denied: " "a handler procedure must be defined for use in " "a safe interp", TCL_STATIC); result = TCL_ERROR; |
︙ | ︙ | |||
1550 1551 1552 1553 1554 1555 1556 | Tcl_IncrRefCount(objPtr); result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(objPtr); } if (interp != sendInterp) { if (result == TCL_ERROR) { /* | | | < | 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 | Tcl_IncrRefCount(objPtr); result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(objPtr); } if (interp != sendInterp) { if (result == TCL_ERROR) { /* * An error occurred, so transfer error information from * the destination interpreter back to our interpreter. */ Tcl_ResetResult(interp); objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, TCL_GLOBAL_ONLY); if (objPtr) { string = Tcl_GetStringFromObj(objPtr, &length); |
︙ | ︙ | |||
1575 1576 1577 1578 1579 1580 1581 | } Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp)); } Tcl_Release((ClientData) riPtr); Tcl_Release((ClientData) sendInterp); } else { /* | | | | | 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 | } Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp)); } Tcl_Release((ClientData) riPtr); Tcl_Release((ClientData) sendInterp); } else { /* * This is a non-local request. Send the script to the server and * poll it for a result. */ if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { invalidServerResponse: Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid data returned from server", -1)); result = TCL_ERROR; goto cleanup; } |
︙ | ︙ | |||
1621 1622 1623 1624 1625 1626 1627 | result = TCL_ERROR; } if (async == 0) { Tcl_Obj *resultPtr; /* | | | | | | | | 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 | result = TCL_ERROR; } if (async == 0) { Tcl_Obj *resultPtr; /* * The return handle has a two or four element list in it. The * first element is the return code (TCL_OK, TCL_ERROR, etc.). * The second is the result of the script. If the return code * is TCL_ERROR, then the third element is the value of the * variable "errorCode", and the fourth is the value of the * variable "errorInfo". */ resultPtr = Tcl_NewObj(); length = DdeGetData(ddeData, NULL, 0, 0); Tcl_SetObjLength(resultPtr, length); string = Tcl_GetString(resultPtr); DdeGetData(ddeData, string, (DWORD) length, 0); |
︙ | ︙ | |||
1688 1689 1690 1691 1692 1693 1694 | DdeFreeDataHandle(ddeData); } if (hConv != NULL) { DdeDisconnect(hConv); } return result; } | | > > | 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 | DdeFreeDataHandle(ddeData); } if (hConv != NULL) { DdeDisconnect(hConv); } return result; } /* * Local variables: * mode: c * indent-tabs-mode: t * tab-width: 8 * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinFCmd.c.
1 2 3 | /* * tclWinFCmd.c * | | | | | | | | | | | < | | < | | < | | < | | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | /* * 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.43.2.4 2005/08/15 18:14:15 dgp Exp $ */ #include "tclWinInt.h" /* * The following constants specify the type of callback when * TraverseWinTree() calls the traverseProc() */ #define DOTREE_PRED 1 /* pre-order directory */ #define DOTREE_POSTD 2 /* post-order directory */ #define DOTREE_F 3 /* regular file */ #define DOTREE_LINK 4 /* symbolic link */ /* * Callbacks for file attributes code. */ static int GetWinFileAttributes(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); static int GetWinFileLongName(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); static int GetWinFileShortName(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); static int SetWinFileAttributes(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); static int CannotSetAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* * Constants and variables necessary for file attributes subcommand. */ enum { WIN_ARCHIVE_ATTRIBUTE, |
︙ | ︙ | |||
70 71 72 73 74 75 76 | {GetWinFileAttributes, SetWinFileAttributes}, {GetWinFileAttributes, SetWinFileAttributes}, {GetWinFileLongName, CannotSetAttribute}, {GetWinFileAttributes, SetWinFileAttributes}, {GetWinFileShortName, CannotSetAttribute}, {GetWinFileAttributes, SetWinFileAttributes}}; | | | < > | | | | < | | < | < | | < | < | < | < < < < < | | | | | | | > | | > | | < | | | | | < | | | | | | | | | | | | | | | | | > > > | | | | | < < < < < < < < < < < < < < < < < < < < > > | > > > > > > > > > | | | | > > > > | > | > | | | > > | > > > | > | > > > < < | | > | < < < < > | > > | < < > > > | < < > > > | < < < < > > > | < > > | > > > > > > > > > > > > > > > > > > > > > > | | > | > | | | > | > | | | < | | | < | | | | | | | | | | | | > | | | 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 | {GetWinFileAttributes, SetWinFileAttributes}, {GetWinFileAttributes, SetWinFileAttributes}, {GetWinFileLongName, CannotSetAttribute}, {GetWinFileAttributes, SetWinFileAttributes}, {GetWinFileShortName, CannotSetAttribute}, {GetWinFileAttributes, SetWinFileAttributes}}; #ifdef HAVE_NO_SEH /* * Unlike Borland and Microsoft, we don't register exception handlers by * pushing registration records onto the runtime stack. Instead, we register * them by creating an EXCEPTION_REGISTRATION within the activation record. */ typedef struct EXCEPTION_REGISTRATION { struct EXCEPTION_REGISTRATION *link; EXCEPTION_DISPOSITION (*handler)( struct _EXCEPTION_RECORD *, void *, struct _CONTEXT *, void *); void *ebp; void *esp; int status; } EXCEPTION_REGISTRATION; #endif /* * Prototype for the TraverseWinTree callback function. */ typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, int type, Tcl_DString *errorPtr); /* * Declarations for local functions defined in this file: */ static void StatError(Tcl_Interp *interp, Tcl_Obj *fileName); static int ConvertFileNameFormat(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, int longShort, Tcl_Obj **attributePtrPtr); static int DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr); static int DoCreateDirectory(CONST TCHAR *pathPtr); static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc, int ignoreError, Tcl_DString *errorPtr); static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive, Tcl_DString *errorPtr); static int DoRenameFile(CONST TCHAR *nativeSrc, CONST TCHAR *dstPtr); static int TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, int type, Tcl_DString *errorPtr); static int TraversalDelete(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, int type, Tcl_DString *errorPtr); static int TraverseWinTree(TraversalProc *traverseProc, Tcl_DString *sourcePtr, Tcl_DString *dstPtr, Tcl_DString *errorPtr); /* *--------------------------------------------------------------------------- * * TclpObjRenameFile, DoRenameFile -- * * Changes the name of an existing file or directory, from src to dst. * If src and dst refer to the same file or directory, does nothing and * returns success. Otherwise if dst already exists, it will be deleted * and replaced by src subject to the following conditions: * If src is a directory, dst may be an empty directory. * If src is a file, dst may be a file. * In any other situation where dst already exists, the rename will fail. * * Results: * If the file or directory was successfully renamed, returns TCL_OK. * Otherwise the return value is TCL_ERROR and errno is set to indicate * the error. Some possible values for errno are: * * ENAMETOOLONG: src or dst names are too long. * EACCES: src or dst parent directory can't be read and/or written. * EEXIST: dst is a non-empty directory. * EINVAL: src is a root directory or dst is a subdirectory of src. * EISDIR: dst is a directory, but src is not. * ENOENT: src doesn't exist. src or dst is "". * ENOTDIR: src is a directory, but dst is not. * EXDEV: src and dst are on different filesystems. * * EACCES: exists an open file already referring to src or dst. * EACCES: src or dst specify the current working directory (NT). * EACCES: src specifies a char device (nul:, com1:, etc.) * EEXIST: dst specifies a char device (nul:, com1:, etc.) (NT) * EACCES: dst specifies a char device (nul:, com1:, etc.) (95) * * Side effects: * The implementation supports cross-filesystem renames of files, but the * caller should be prepared to emulate cross-filesystem renames of * directories if errno is EXDEV. * *--------------------------------------------------------------------------- */ int TclpObjRenameFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), Tcl_FSGetNativePath(destPathPtr)); } static int DoRenameFile( CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed * (native). */ CONST TCHAR *nativeDst) /* New pathname for file or directory * (native). */ { #ifdef HAVE_NO_SEH EXCEPTION_REGISTRATION registration; #endif DWORD srcAttr, dstAttr; int retval = -1; /* * The MoveFile API acts differently under Win95/98 and NT WRT NULL and * "". Avoid passing these values. */ if (nativeSrc == NULL || nativeSrc[0] == '\0' || nativeDst == NULL || nativeDst[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; } /* * The MoveFile API would throw an exception under NT if one of the * arguments is a char block device. */ #ifndef HAVE_NO_SEH __try { if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { retval = TCL_OK; } } __except (EXCEPTION_EXECUTE_HANDLER) {} #else /* * Don't have SEH available, do things the hard way. Note that this needs * to be one block of asm, to avoid stack imbalance; also, it is illegal * for one asm block to contain a jump to another. */ __asm__ __volatile__ ( /* * Pick up params before messing with the stack. */ "movl %[nativeDst], %%ebx" "\n\t" "movl %[nativeSrc], %%ecx" "\n\t" /* * Construct an EXCEPTION_REGISTRATION to protect the call to * MoveFile. */ "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the EXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" /* * Call MoveFile(nativeSrc, nativeDst) */ "pushl %%ebx" "\n\t" "pushl %%ecx" "\n\t" "movl %[moveFile], %%eax" "\n\t" "call *%%eax" "\n\t" /* * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and * put the status return from MoveFile into it. */ "movl %%fs:0, %%edx" "\n\t" "movl %%eax, 0x10(%%edx)" "\n\t" "jmp 2f" "\n" /* * Come here on an exception. Recover the EXCEPTION_REGISTRATION */ "1:" "\t" "movl %%fs:0, %%edx" "\n\t" "movl 0x8(%%edx), %%edx" "\n\t" /* * Come here however we exited. Restore context from the * EXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xc(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), [moveFile] "r" (tclWinProcs->moveFileProc) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); if (registration.status != FALSE) { retval = TCL_OK; } #endif if (retval != -1) { return retval; } TclWinConvertError(GetLastError()); srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst); if (srcAttr == 0xffffffff) { if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) { errno = ENAMETOOLONG; return TCL_ERROR; } srcAttr = 0; } if (dstAttr == 0xffffffff) { if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, NULL) >= MAX_PATH) { errno = ENAMETOOLONG; return TCL_ERROR; } dstAttr = 0; } if (errno == EBADF) { errno = EACCES; return TCL_ERROR; } if (errno == EACCES) { decode: if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { TCHAR *nativeSrcRest, *nativeDstRest; CONST char **srcArgv, **dstArgv; int size, srcArgc, dstArgc; WCHAR nativeSrcPath[MAX_PATH]; WCHAR nativeDstPath[MAX_PATH]; Tcl_DString srcString, dstString; CONST char *src, *dst; size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH, nativeSrcPath, &nativeSrcRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, nativeDstPath, &nativeDstRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath); (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath); src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString); dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString); /* * Check whether the destination path is actually inside the * source path. This is true if the prefix matches, and the next * character is either end-of-string or a directory separator */ if ((strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString))==0) && (dst[Tcl_DStringLength(&srcString)] == '\\' || dst[Tcl_DStringLength(&srcString)] == '/' || dst[Tcl_DStringLength(&srcString)] == '\0')) { /* * Trying to move a directory into itself. */ errno = EINVAL; Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); return TCL_ERROR; } Tcl_SplitPath(src, &srcArgc, &srcArgv); Tcl_SplitPath(dst, &dstArgc, &dstArgv); Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); if (srcArgc == 1) { /* * They are trying to move a root directory. Whether or not it * is across filesystems, this cannot be done. */ Tcl_SetErrno(EINVAL); } else if ((srcArgc > 0) && (dstArgc > 0) && (strcmp(srcArgv[0], dstArgv[0]) != 0)) { /* * If src is a directory and dst filesystem != src filesystem, * errno should be EXDEV. It is very important to get this * behavior, so that the caller can respond to a cross * filesystem rename by simulating it with copy and delete. * The MoveFile system call already handles the case of moving * a file between filesystems. */ Tcl_SetErrno(EXDEV); } ckfree((char *) srcArgv); ckfree((char *) dstArgv); } /* * Other types of access failure is that dst is a read-only * filesystem, that an open file referred to src or dest, or that src * or dest specified the current working directory on the current * filesystem. EACCES is returned for those cases. */ } else if (Tcl_GetErrno() == EEXIST) { /* * Reports EEXIST any time the target already exists. If it makes * sense, remove the old file and try renaming again. */ if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { /* * Overwrite empty dst directory with src directory. The * following call will remove an empty directory. If it fails, * it's because it wasn't empty. */ if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) { /* * Now that that empty directory is gone, we can try * renaming again. If that fails, we'll put this empty * directory back, for completeness. */ if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { return TCL_OK; } /* * Some new error has occurred. Don't know what it could * be, but report this one. */ TclWinConvertError(GetLastError()); (*tclWinProcs->createDirectoryProc)(nativeDst, NULL); (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); if (Tcl_GetErrno() == EACCES) { /* |
︙ | ︙ | |||
434 435 436 437 438 439 440 | } } else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { Tcl_SetErrno(EISDIR); } else { /* * Overwrite existing file by: | | | | | | | | | | > | > | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | | > > > | | | | | | < < < < < < < < < < < < < < < < < < < < > > | > > > > > > | > > > | | > | > > > > | > | > | | | > > | > > > | > | > > > < < > | | | < < < | < < | > > | < > | | | > | | < | > | > > > | < > > | > > > > > > > > > > > > > > > > > > > > > > | | | | | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | > | > | | | | | > | | | | | 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 | } } else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { Tcl_SetErrno(EISDIR); } else { /* * Overwrite existing file by: * * 1. Rename existing file to temp name. * 2. Rename old file to new name. * 3. If success, delete temp file. If failure, put temp file * back to old name. */ TCHAR *nativeRest, *nativeTmp, *nativePrefix; int result, size; WCHAR tempBuf[MAX_PATH]; size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, tempBuf, &nativeRest); if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) { return TCL_ERROR; } nativeTmp = (TCHAR *) tempBuf; ((char *) nativeRest)[0] = '\0'; ((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */ result = TCL_ERROR; nativePrefix = (tclWinProcs->useWide) ? (TCHAR *) L"tclr" : (TCHAR *) "tclr"; if ((*tclWinProcs->getTempFileNameProc)(nativeTmp, nativePrefix, 0, tempBuf) != 0) { /* * Strictly speaking, need the following DeleteFile and * MoveFile to be joined as an atomic operation so no * other app comes along in the meantime and creates the * same temp file. */ nativeTmp = (TCHAR *) tempBuf; (*tclWinProcs->deleteFileProc)(nativeTmp); if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) { if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { (*tclWinProcs->setFileAttributesProc)(nativeTmp, FILE_ATTRIBUTE_NORMAL); (*tclWinProcs->deleteFileProc)(nativeTmp); return TCL_OK; } else { (*tclWinProcs->deleteFileProc)(nativeDst); (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst); } } /* * Can't backup dst file or move src file. Return that * error. Could happen if an open file refers to dst. */ TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { /* * Decode the EACCES to a more meaningful error. */ goto decode; } } return result; } } } return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * TclpObjCopyFile, DoCopyFile -- * * Copy a single file (not a directory). If dst already exists and is not * a directory, it is removed. * * Results: * If the file was successfully copied, returns TCL_OK. Otherwise the * return value is TCL_ERROR and errno is set to indicate the error. * Some possible values for errno are: * * EACCES: src or dst parent directory can't be read and/or written. * EISDIR: src or dst is a directory. * ENOENT: src doesn't exist. src or dst is "". * * EACCES: exists an open file already referring to dst (95). * EACCES: src specifies a char device (nul:, com1:, etc.) (NT) * ENOENT: src specifies a char device (nul:, com1:, etc.) (95) * * Side effects: * It is not an error to copy to a char device. * *--------------------------------------------------------------------------- */ int TclpObjCopyFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), Tcl_FSGetNativePath(destPathPtr)); } static int DoCopyFile( CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */ CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */ { #ifdef HAVE_NO_SEH EXCEPTION_REGISTRATION registration; #endif int retval = -1; /* * The CopyFile API acts differently under Win95/98 and NT WRT NULL and * "". Avoid passing these values. */ if (nativeSrc == NULL || nativeSrc[0] == '\0' || nativeDst == NULL || nativeDst[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; } /* * The CopyFile API would throw an exception under NT if one of the * arguments is a char block device. */ #ifndef HAVE_NO_SEH __try { if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) { retval = TCL_OK; } } __except (EXCEPTION_EXECUTE_HANDLER) {} #else /* * Don't have SEH available, do things the hard way. Note that this needs * to be one block of asm, to avoid stack imbalance; also, it is illegal * for one asm block to contain a jump to another. */ __asm__ __volatile__ ( /* * Pick up parameters before messing with the stack */ "movl %[nativeDst], %%ebx" "\n\t" "movl %[nativeSrc], %%ecx" "\n\t" /* * Construct an EXCEPTION_REGISTRATION to protect the call to * CopyFile. */ "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the EXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" /* * Call CopyFile(nativeSrc, nativeDst, 0) */ "movl %[copyFile], %%eax" "\n\t" "pushl $0" "\n\t" "pushl %%ebx" "\n\t" "pushl %%ecx" "\n\t" "call *%%eax" "\n\t" /* * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and * put the status return from CopyFile into it. */ "movl %%fs:0, %%edx" "\n\t" "movl %%eax, 0x10(%%edx)" "\n\t" "jmp 2f" "\n" /* * Come here on an exception. Recover the EXCEPTION_REGISTRATION */ "1:" "\t" "movl %%fs:0, %%edx" "\n\t" "movl 0x8(%%edx), %%edx" "\n\t" /* * Come here however we exited. Restore context from the * EXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xc(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), [copyFile] "r" (tclWinProcs->copyFileProc) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); if (registration.status != FALSE) { retval = TCL_OK; } #endif if (retval != -1) { return retval; } TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EBADF) { Tcl_SetErrno(EACCES); return TCL_ERROR; } if (Tcl_GetErrno() == EACCES) { DWORD srcAttr, dstAttr; srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); 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 & ~((DWORD)FILE_ATTRIBUTE_READONLY)); if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) { return TCL_OK; } /* * Still can't copy onto dst. Return that error, and restore * attributes of dst. */ TclWinConvertError(GetLastError()); (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); } } } return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * TclpObjDeleteFile, TclpDeleteFile -- * * Removes a single file (not a directory). * * Results: * If the file was successfully deleted, returns TCL_OK. Otherwise the * return value is TCL_ERROR and errno is set to indicate the error. * Some possible values for errno are: * * EACCES: a parent directory can't be read and/or written. * EISDIR: path is a directory. * ENOENT: path doesn't exist or is "". * * EACCES: exists an open file already referring to path. * EACCES: path is a char device (nul:, com1:, etc.) * * Side effects: * The file is deleted, even if it is read-only. * *--------------------------------------------------------------------------- */ int TclpObjDeleteFile(pathPtr) Tcl_Obj *pathPtr; { return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr)); } int TclpDeleteFile( CONST TCHAR *nativePath) /* Pathname of file to be removed (native). */ { DWORD attr; /* * The DeleteFile API acts differently under Win95/98 and NT WRT NULL and * "". Avoid passing these values. */ if (nativePath == NULL || nativePath[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; } if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) { return TCL_OK; } 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, attr & ~((DWORD)FILE_ATTRIBUTE_READONLY)); if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE)) { return TCL_OK; } TclWinConvertError(GetLastError()); if (res != 0) { (*tclWinProcs->setFileAttributesProc)(nativePath, attr); } } } } else if (Tcl_GetErrno() == ENOENT) { attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr != 0xffffffff) { if (attr & FILE_ATTRIBUTE_DIRECTORY) { /* * Windows 95 reports removing a directory as ENOENT instead * of EISDIR. */ Tcl_SetErrno(EISDIR); } } } else if (Tcl_GetErrno() == EINVAL) { /* |
︙ | ︙ | |||
849 850 851 852 853 854 855 | } /* *--------------------------------------------------------------------------- * * TclpObjCreateDirectory -- * | | | | | | | | | | | | | | | < | | | | | | | | < | | 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 | } /* *--------------------------------------------------------------------------- * * TclpObjCreateDirectory -- * * Creates the specified directory. All parent directories of the * specified directory must already exist. The directory is automatically * created with permissions so that user can access the new directory and * create new files or subdirectories in it. * * Results: * If the directory was successfully created, returns TCL_OK. Otherwise * the return value is TCL_ERROR and errno is set to indicate the error. * Some possible values for errno are: * * EACCES: a parent directory can't be read and/or written. * EEXIST: path already exists. * ENOENT: a parent directory doesn't exist. * * Side effects: * A directory is created. * *--------------------------------------------------------------------------- */ int TclpObjCreateDirectory(pathPtr) Tcl_Obj *pathPtr; { return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr)); } static int DoCreateDirectory( CONST TCHAR *nativePath) /* Pathname of directory to create (native). */ { DWORD error; if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) { error = GetLastError(); TclWinConvertError(error); return TCL_ERROR; } return TCL_OK; } /* *--------------------------------------------------------------------------- * * TclpObjCopyDirectory -- * * Recursively copies a directory. The target directory dst must not * already exist. Note that this function does not merge two directory * hierarchies, even if the target directory is an an empty directory. * * Results: * If the directory was successfully copied, returns TCL_OK. Otherwise * the return value is TCL_ERROR, errno is set to indicate the error, and * the pathname of the file that caused the error is stored in errorPtr. * See TclpCreateDirectory and TclpCopyFile for a description of possible * values for errno. * * Side effects: * An exact copy of the directory hierarchy src will be created with the * name dst. If an error occurs, the error will be returned immediately, * and remaining files will not be processed. * *--------------------------------------------------------------------------- */ int TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; Tcl_Obj **errorPtr; { Tcl_DString ds; Tcl_DString srcString, dstString; |
︙ | ︙ | |||
937 938 939 940 941 942 943 | ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds); Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); if (ret != TCL_OK) { | | | | | | | | | | | | > | | | > | < > > | | < | | | > | | > | > > | > > | | | | > | > > | | > | | | | | < | 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 | ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds); Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); if (ret != TCL_OK) { if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normSrcPtr))) { *errorPtr = srcPathPtr; } else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) { *errorPtr = destPathPtr; } else { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); } Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); } return ret; } /* *---------------------------------------------------------------------- * * TclpObjRemoveDirectory, DoRemoveDirectory -- * * Removes directory (and its contents, if the recursive flag is set). * * Results: * If the directory was successfully removed, returns TCL_OK. Otherwise * the return value is TCL_ERROR, errno is set to indicate the error, and * the pathname of the file that caused the error is stored in errorPtr. * Some possible values for errno are: * * EACCES: path directory can't be read and/or written. * EEXIST: path is a non-empty directory. * EINVAL: path is root directory or current directory. * ENOENT: path doesn't exist or is "". * ENOTDIR: path is not a directory. * * EACCES: path is a char device (nul:, com1:, etc.) (95) * EINVAL: path is a char device (nul:, com1:, etc.) (NT) * * Side effects: * Directory removed. If an error occurs, the error will be returned * immediately, and remaining files will not be deleted. * *---------------------------------------------------------------------- */ int TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_Obj *pathPtr; int recursive; Tcl_Obj **errorPtr; { Tcl_DString ds; Tcl_Obj *normPtr = NULL; int ret; if (recursive) { /* * In the recursive case, the string rep is used to construct a * Tcl_DString which may be used extensively, so we can't optimize * this case easily. */ Tcl_DString native; normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native); ret = DoRemoveDirectory(&native, recursive, &ds); Tcl_DStringFree(&native); } else { ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 0, &ds); } if (ret != TCL_OK) { int len = Tcl_DStringLength(&ds); if (len > 0) { if (normPtr != NULL && !strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) { *errorPtr = pathPtr; } else { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); } Tcl_IncrRefCount(*errorPtr); } Tcl_DStringFree(&ds); } return ret; } static int DoRemoveJustDirectory( CONST TCHAR *nativePath, /* Pathname of directory to be removed * (native). */ int ignoreError, /* If non-zero, don't initialize the errorPtr * under some circumstances on return. */ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString * filled with UTF-8 name of file causing * error. */ { DWORD attr; /* * The RemoveDirectory API acts differently under Win95/98 and NT WRT NULL * and "". Avoid passing these values. */ if (nativePath == NULL || nativePath[0] == '\0') { Tcl_SetErrno(ENOENT); goto end; } attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { /* * It is a symbolic link - remove it. */ if (TclWinSymLinkDelete(nativePath, 0) == 0) { return TCL_OK; } } else { /* * Ordinary directory. */ if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { return TCL_OK; } } TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr != 0xffffffff) { if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { /* * Windows 95 reports calling RemoveDirectory on a file as an * 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; } TclWinConvertError(GetLastError()); (*tclWinProcs->setFileAttributesProc)(nativePath, attr | FILE_ATTRIBUTE_READONLY); } /* * Windows 95 and Win32s report removing a non-empty directory as * EACCES, not EEXIST. If the directory is not empty, change errno * so caller knows what's going on. */ if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) { CONST char *path, *find; HANDLE handle; WIN32_FIND_DATAA data; Tcl_DString buffer; |
︙ | ︙ | |||
1135 1136 1137 1138 1139 1140 1141 1142 | } FindClose(handle); } Tcl_DStringFree(&buffer); } } } if (Tcl_GetErrno() == ENOTEMPTY) { | > | | | > | | | < | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | > | | | > | 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 | } FindClose(handle); } Tcl_DStringFree(&buffer); } } } if (Tcl_GetErrno() == ENOTEMPTY) { /* * The caller depends on EEXIST to signify that the directory is not * empty, not ENOTEMPTY. */ Tcl_SetErrno(EEXIST); } if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) { /* * If we're being recursive, this error may actually be ok, so we * don't want to initialise the errorPtr yet. */ return TCL_ERROR; } end: if (errorPtr != NULL) { Tcl_WinTCharToUtf(nativePath, -1, errorPtr); } return TCL_ERROR; } static int DoRemoveDirectory( Tcl_DString *pathPtr, /* Pathname of directory to be removed * (native). */ int recursive, /* If non-zero, removes directories that are * nonempty. Otherwise, will only remove empty * directories. */ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString * filled with UTF-8 name of file causing * error. */ { int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive, errorPtr); if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) { /* * The directory is nonempty, but the recursive flag has been * specified, so we recursively remove all the files in the directory. */ return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr); } else { return res; } } /* *--------------------------------------------------------------------------- * * TraverseWinTree -- * * Traverse directory tree specified by sourcePtr, calling the function * traverseProc for each file and directory encountered. If destPtr is * non-null, each of name in the sourcePtr directory is appended to the * directory specified by destPtr and passed as the second argument to * traverseProc(). * * Results: * Standard Tcl result. * * Side effects: * None caused by TraverseWinTree, however the user specified * traverseProc() may change state. If an error occurs, the error will be * returned immediately, and remaining files will not be processed. * *--------------------------------------------------------------------------- */ static int TraverseWinTree( TraversalProc *traverseProc,/* Function to call for every file and * directory in source hierarchy. */ Tcl_DString *sourcePtr, /* Pathname of source directory to be * traversed (native). */ Tcl_DString *targetPtr, /* Pathname of directory to traverse in * parallel with source directory (native), * may be NULL. */ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString * filled with UTF-8 name of file causing * error. */ { DWORD sourceAttr; TCHAR *nativeSource, *nativeTarget, *nativeErrfile; int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen; HANDLE handle; WIN32_FIND_DATAT data; nativeErrfile = NULL; result = TCL_OK; oldTargetLen = 0; /* lint. */ nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); nativeTarget = (TCHAR *) (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)); oldSourceLen = Tcl_DStringLength(sourcePtr); sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource); if (sourceAttr == 0xffffffff) { nativeErrfile = nativeSource; goto end; } if (sourceAttr & FILE_ATTRIBUTE_REPARSE_POINT) { /* * Process the symbolic link */ return (*traverseProc)(nativeSource, nativeTarget, DOTREE_LINK, errorPtr); } if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) { /* * Process the regular file */ return (*traverseProc)(nativeSource, nativeTarget, DOTREE_F, errorPtr); } if (tclWinProcs->useWide) { Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1); Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); } else { Tcl_DStringAppend(sourcePtr, "\\*.*", 4); } nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data); if (handle == INVALID_HANDLE_VALUE) { /* * Can't read directory. */ TclWinConvertError(GetLastError()); nativeErrfile = nativeSource; goto end; } nativeSource[oldSourceLen + 1] = '\0'; Tcl_DStringSetLength(sourcePtr, oldSourceLen); result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED, errorPtr); if (result != TCL_OK) { FindClose(handle); return result; } sourceLen = oldSourceLen; |
︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 | } else { targetLen += 1; Tcl_DStringAppend(targetPtr, "\\", 1); } } found = 1; | | | | | | | | | | | > | | | | | | | | | | | | | < | | | | | < | | | > | | | | | | | < | | | | < | | | | | | | | | | | | | | | | < | | | | | < | | < | | | | | < | | | | | | | | | | | | | | | | | | > > | | < > | > > | > | > > > | | | | | | | | < | | | | | | | < > > | | | | > | > | | > > > | | | > | | | | | | | | | | | | | > > | > > | | | | | | | | < | | > > | | < | | | | | | > | < | | | | | | > | | | | | | 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 | } else { targetLen += 1; Tcl_DStringAppend(targetPtr, "\\", 1); } } found = 1; for (; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) { TCHAR *nativeName; int len; if (tclWinProcs->useWide) { WCHAR *wp; wp = data.w.cFileName; if (*wp == '.') { wp++; if (*wp == '.') { wp++; } if (*wp == '\0') { continue; } } nativeName = (TCHAR *) data.w.cFileName; len = wcslen(data.w.cFileName) * sizeof(WCHAR); } else { if ((strcmp(data.a.cFileName, ".") == 0) || (strcmp(data.a.cFileName, "..") == 0)) { continue; } nativeName = (TCHAR *) data.a.cFileName; len = strlen(data.a.cFileName); } /* * Append name after slash, and recurse on the file. */ Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1); Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); if (targetPtr != NULL) { Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1); Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1); } result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, errorPtr); if (result != TCL_OK) { break; } /* * Remove name after slash. */ Tcl_DStringSetLength(sourcePtr, sourceLen); if (targetPtr != NULL) { Tcl_DStringSetLength(targetPtr, targetLen); } } FindClose(handle); /* * Strip off the trailing slash we added. */ Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1); Tcl_DStringSetLength(sourcePtr, oldSourceLen); if (targetPtr != NULL) { Tcl_DStringSetLength(targetPtr, oldTargetLen + 1); Tcl_DStringSetLength(targetPtr, oldTargetLen); } if (result == TCL_OK) { /* * Call traverseProc() on a directory after visiting all the * files in that directory. */ result = (*traverseProc)(Tcl_DStringValue(sourcePtr), (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), DOTREE_POSTD, errorPtr); } end: if (nativeErrfile != NULL) { TclWinConvertError(GetLastError()); if (errorPtr != NULL) { Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr); } result = TCL_ERROR; } return result; } /* *---------------------------------------------------------------------- * * TraversalCopy * * Called from TraverseUnixTree in order to execute a recursive copy of a * directory. * * Results: * Standard Tcl result. * * Side effects: * Depending on the value of type, src may be copied to dst. * *---------------------------------------------------------------------- */ static int TraversalCopy( CONST TCHAR *nativeSrc, /* Source pathname to copy. */ CONST TCHAR *nativeDst, /* Destination pathname of copy. */ int type, /* Reason for call - see TraverseWinTree() */ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled * with UTF-8 name of file causing error. */ { switch (type) { case DOTREE_F: if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) { return TCL_OK; } break; case DOTREE_LINK: if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) { return TCL_OK; } break; case DOTREE_PRED: if (DoCreateDirectory(nativeDst) == TCL_OK) { DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); } break; case DOTREE_POSTD: return TCL_OK; } /* * There shouldn't be a problem with src, because we already checked it to * get here. */ if (errorPtr != NULL) { Tcl_WinTCharToUtf(nativeDst, -1, errorPtr); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TraversalDelete -- * * Called by function TraverseWinTree for every file and directory that * it encounters in a directory hierarchy. This function unlinks files, * and removes directories after all the containing files have been * processed. * * Results: * Standard Tcl result. * * Side effects: * Files or directory specified by src will be deleted. If an error * occurs, the windows error is converted to a Posix error and errno is * set accordingly. * *---------------------------------------------------------------------- */ static int TraversalDelete( CONST TCHAR *nativeSrc, /* Source pathname to delete. */ CONST TCHAR *dstPtr, /* Not used. */ int type, /* Reason for call - see TraverseWinTree() */ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled * with UTF-8 name of file causing error. */ { switch (type) { case DOTREE_F: if (TclpDeleteFile(nativeSrc) == TCL_OK) { return TCL_OK; } break; case DOTREE_LINK: if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) { return TCL_OK; } break; case DOTREE_PRED: return TCL_OK; case DOTREE_POSTD: if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) { return TCL_OK; } break; } if (errorPtr != NULL) { Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * StatError -- * * Sets the object result with the appropriate error. * * Results: * None. * * Side effects: * The interp's object result is set with an error message based on the * objIndex, fileName and errno. * *---------------------------------------------------------------------- */ static void StatError( Tcl_Interp *interp, /* The interp that has the error */ Tcl_Obj *fileName) /* The name of the file which caused the * error. */ { TclWinConvertError(GetLastError()); Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } /* *---------------------------------------------------------------------- * * GetWinFileAttributes -- * * Returns a Tcl_Obj containing the value of a file attribute. This * routine gets the -hidden, -readonly or -system attribute. * * Results: * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will * have ref count 0. If the return value is not TCL_OK, attributePtrPtr * is not touched. * * Side effects: * A new object is allocated if the file is valid. * *---------------------------------------------------------------------- */ static int GetWinFileAttributes( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { DWORD result; CONST TCHAR *nativeName; int attr; nativeName = Tcl_FSGetNativePath(fileName); result = (*tclWinProcs->getFileAttributesProc)(nativeName); if (result == 0xffffffff) { StatError(interp, fileName); return TCL_ERROR; } attr = (int)(result & attributeArray[objIndex]); if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) { /* * It is hidden. However there is a bug on some Windows OSes in which * root volumes (drives) formatted as NTFS are declared hidden when * they are not (and cannot be). * * We test for, and fix that case, here. */ int len; char *str = Tcl_GetStringFromObj(fileName,&len); if (len < 4) { if (len == 0) { /* * Not sure if this is possible, but we pass it on anyway. */ } else if (len == 1 && (str[0] == '/' || str[0] == '\\')) { /* * Path is pointing to the root volume. */ attr = 0; } else if ((str[1] == ':') && (len == 2 || (str[2] == '/' || str[2] == '\\'))) { /* * Path is of the form 'x:' or 'x:/' or 'x:\' */ attr = 0; } } } *attributePtrPtr = Tcl_NewBooleanObj(attr); return TCL_OK; } /* *---------------------------------------------------------------------- * * ConvertFileNameFormat -- * * Returns a Tcl_Obj containing either the long or short version of the * file name. * * Results: * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will * have ref count 0. If the return value is not TCL_OK, attributePtrPtr * is not touched. * * Warning: if you pass this function a drive name like 'c:' it will * actually return the current working directory on that drive. To avoid * this, make sure the drive name ends in a slash, like this 'c:/'. * * Side effects: * A new object is allocated if the file is valid. * *---------------------------------------------------------------------- */ static int ConvertFileNameFormat( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file. */ int longShort, /* 0 to short name, 1 to long name. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { int pathc, i; Tcl_Obj *splitPath; splitPath = Tcl_FSSplitPath(fileName, &pathc); if (splitPath == NULL || pathc == 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": no such file or directory", (char *) NULL); } goto cleanup; } /* * We will decrement this again at the end. It is safer to do this in * case any of the calls below retain a reference to splitPath. */ Tcl_IncrRefCount(splitPath); for (i = 0; i < pathc; i++) { Tcl_Obj *elt; char *pathv; int pathLen; Tcl_ListObjIndex(NULL, splitPath, i, &elt); pathv = Tcl_GetStringFromObj(elt, &pathLen); if ((pathv[0] == '/') || ((pathLen == 3) && (pathv[1] == ':')) || (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) { /* * Handle "/", "//machine/export", "c:/", "." or ".." by just * copying the string literally. Uppercase the drive letter, just * because it looks better under Windows to do so. */ simple: /* * Here we are modifying the string representation in place. * * I believe this is legal, since this won't affect any file * representation this thing may have. */ pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0])); } else { Tcl_Obj *tempPath; Tcl_DString ds; Tcl_DString dsTemp; TCHAR *nativeName; char *tempString; int tempLen; WIN32_FIND_DATAT data; HANDLE handle; DWORD attr; tempPath = Tcl_FSJoinPath(splitPath, i+1); Tcl_IncrRefCount(tempPath); /* * We'd like to call Tcl_FSGetNativePath(tempPath) but that is * likely to lead to infinite loops. */ Tcl_DStringInit(&ds); tempString = Tcl_GetStringFromObj(tempPath,&tempLen); nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds); Tcl_DecrRefCount(tempPath); handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data); if (handle == INVALID_HANDLE_VALUE) { /* * FindFirstFile() doesn't like root directories. We would * only get a root directory here if the caller specified "c:" * or "c:." and the current directory on the drive was the * root directory */ attr = (*tclWinProcs->getFileAttributesProc)(nativeName); if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { Tcl_DStringFree(&ds); goto simple; } } if (handle == INVALID_HANDLE_VALUE) { Tcl_DStringFree(&ds); if (interp != NULL) { StatError(interp, fileName); } goto cleanup; } if (tclWinProcs->useWide) { nativeName = (TCHAR *) data.w.cAlternateFileName; if (longShort) { if (data.w.cFileName[0] != '\0') { nativeName = (TCHAR *) data.w.cFileName; } } else { if (data.w.cAlternateFileName[0] == '\0') { nativeName = (TCHAR *) data.w.cFileName; } } } else { nativeName = (TCHAR *) data.a.cAlternateFileName; if (longShort) { if (data.a.cFileName[0] != '\0') { nativeName = (TCHAR *) data.a.cFileName; } } else { if (data.a.cAlternateFileName[0] == '\0') { nativeName = (TCHAR *) data.a.cFileName; } } } /* * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying * to dereference nativeName as a Unicode string. I have proven to * myself that purify is wrong by running the following example * when nativeName == data.w.cAlternateFileName and noting that * purify doesn't complain about the first line, but does complain * about the second. * * fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]); * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]); */ Tcl_DStringInit(&dsTemp); Tcl_WinTCharToUtf(nativeName, -1, &dsTemp); /* * Deal with issues of tildes being absolute. */ if (Tcl_DStringValue(&dsTemp)[0] == '~') { tempPath = Tcl_NewStringObj("./",2); Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), Tcl_DStringLength(&dsTemp)); } else { tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), Tcl_DStringLength(&dsTemp)); } Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); Tcl_DStringFree(&ds); Tcl_DStringFree(&dsTemp); FindClose(handle); } } *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1); if (splitPath != NULL) { /* * Unfortunately, the object we will return may have its only refCount * as part of the list splitPath. This means if we free splitPath, the * object will disappear. So, we have to be very careful here. * Unfortunately this means we must manipulate the object's refCount * directly. */ Tcl_IncrRefCount(*attributePtrPtr); Tcl_DecrRefCount(splitPath); --(*attributePtrPtr)->refCount; } return TCL_OK; cleanup: if (splitPath != NULL) { Tcl_DecrRefCount(splitPath); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * GetWinFileLongName -- * * Returns a Tcl_Obj containing the long version of the file name. * * Results: * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will * have ref count 0. If the return value is not TCL_OK, attributePtrPtr * is not touched. * * Side effects: * A new object is allocated if the file is valid. * *---------------------------------------------------------------------- */ static int GetWinFileLongName( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr); } /* *---------------------------------------------------------------------- * * GetWinFileShortName -- * * Returns a Tcl_Obj containing the short version of the file name. * * Results: * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will * have ref count 0. If the return value is not TCL_OK, attributePtrPtr * is not touched. * * Side effects: * A new object is allocated if the file is valid. * *---------------------------------------------------------------------- */ static int GetWinFileShortName( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr); } /* *---------------------------------------------------------------------- * * SetWinFileAttributes -- * * Set the file attributes to the value given by attributePtr. This * routine sets the -hidden, -readonly, or -system attributes. * * Results: * Standard TCL error. * * Side effects: * The file's attribute is set. * *---------------------------------------------------------------------- */ static int SetWinFileAttributes( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { DWORD fileAttributes; int yesNo; int result; CONST TCHAR *nativeName; |
︙ | ︙ | |||
1931 1932 1933 1934 1935 1936 1937 | } /* *---------------------------------------------------------------------- * * SetWinFileLongName -- * | | < | | | | 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 | } /* *---------------------------------------------------------------------- * * SetWinFileLongName -- * * The attribute in question is a readonly attribute and cannot be set. * * Results: * TCL_ERROR * * Side effects: * The object result is set to a pertinent error message. * *---------------------------------------------------------------------- */ static int CannotSetAttribute( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { Tcl_AppendResult(interp, "cannot set attribute \"", tclpFileAttrStrings[objIndex], "\" for file \"", Tcl_GetString(fileName), "\": attribute is readonly", (char *) NULL); return TCL_ERROR; |
︙ | ︙ | |||
1993 1994 1995 1996 1997 1998 1999 | * GetLogicalDriveStrings() isn't implemented. * GetLogicalDrives() returns incorrect information. */ if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) { /* * GetVolumeInformation() will detects all drives, but causes | | | | | | | 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 | * GetLogicalDriveStrings() isn't implemented. * GetLogicalDrives() returns incorrect information. */ if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) { /* * GetVolumeInformation() will detects all drives, but causes * chattering on empty floppy drives. We only do this if * GetLogicalDriveStrings() didn't work. It has also been reported * that on some laptops it takes a while for GetVolumeInformation() to * return when pinging an empty floppy drive, another reason to try to * avoid calling it. */ buf[1] = ':'; buf[2] = '/'; buf[3] = '\0'; for (i = 0; i < 26; i++) { |
︙ | ︙ | |||
2019 2020 2021 2022 2023 2024 2025 | } else { for (p = buf; *p != '\0'; p += 4) { p[2] = '/'; elemPtr = Tcl_NewStringObj(p, -1); Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); } } | | > > > > > > > > | 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 | } else { for (p = buf; *p != '\0'; p += 4) { p[2] = '/'; elemPtr = Tcl_NewStringObj(p, -1); Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); } } Tcl_IncrRefCount(resultPtr); return resultPtr; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinFile.c.
|
| | | | | | | | | | | | < | | | | > | | | | | | | | | | | > | | | > | > | > | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | > | < | | | < | | | | | > | | | | | | | | | > | | | | | | | | > > | | | | | | | > | > > | | > | > > | > > > | > > | | > | > > > > | > > > | > > > > | > > > | > > > | > > > > | > > | | > > | | | | | | > | > > | | > | > > > | > > > | > > > > | > > | | | | | | | > > > | | | | | | | > | > > | > | | | | > | > | > > | | | | | | | | | | | | | | | | | > > > | | | | | | | | | | | | | > > > | | > | > > | > | | > | | < > | > > | | | | | | | > | | | | | > > | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > | < < < < < < < < < < < < | | | < | > | | | | | | > | | | | | | > | | | | | > | | | | < | | | | | > | | > | | > | > > | | | > | > | | | | | | | | | | | | | | | < > | | | | > | | | | | > > > | | | | | | > > | > > > > | > > | < | > | > > | | | | | > > | | | > | > > > | > > > | | > | > > > | > > | | < | > | > > > > | > > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 | /* * 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.72.2.4 2005/09/09 18:48:41 dgp Exp $ */ //#define _WIN32_WINNT 0x0500 #include "tclWinInt.h" #include "tclFileSystem.h" #include <winioctl.h> #include <sys/stat.h> #include <shlobj.h> #include <lmaccess.h> /* For TclpGetUserHome(). */ /* * The number of 100-ns intervals between the Windows system epoch (1601-01-01 * on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01). */ #define POSIX_EPOCH_AS_FILETIME 116444736000000000 /* * Declarations for 'link' related information. This information should come * with VC++ 6.0, but is not in some older SDKs. In any case it is not well * documented. */ #ifndef IO_REPARSE_TAG_RESERVED_ONE # define IO_REPARSE_TAG_RESERVED_ONE 0x000000001 #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; #if defined(_MSC_VER) && (_MSC_VER <= 1100) #undef HAVE_NO_FINDEX_ENUMS #define HAVE_NO_FINDEX_ENUMS #elif !defined(_WIN32_WINNT) || (_WIN32_WINNT < 0x0400) #undef HAVE_NO_FINDEX_ENUMS #define HAVE_NO_FINDEX_ENUMS #endif #ifdef HAVE_NO_FINDEX_ENUMS /* These two aren't in VC++ 5.2 headers */ typedef enum _FINDEX_INFO_LEVELS { FindExInfoStandard, FindExInfoMaxInfoLevel } FINDEX_INFO_LEVELS; typedef enum _FINDEX_SEARCH_OPS { FindExSearchNameMatch, FindExSearchLimitToDirectories, FindExSearchLimitToDevices, FindExSearchMaxSearchOp } FINDEX_SEARCH_OPS; #endif /* HAVE_NO_FINDEX_ENUMS */ /* * Other typedefs required by this code. */ static time_t ToCTime(FILETIME fileTime); static void FromCTime(time_t posixTime, FILETIME *fileTime); typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC( LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr); typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC(LPVOID Buffer); typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC( LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr); /* * Declarations for local functions defined in this file: */ static int NativeAccess(CONST TCHAR *path, int mode); static int NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr, int checkLinks); static unsigned short NativeStatMode(DWORD attr, int checkLinks, int isExec); 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(int isDrive, DWORD attr, CONST TCHAR *nativeName, Tcl_GlobTypeData *types); static int WinIsDrive(CONST char *name, int nameLen); static int WinIsReserved(CONST char *path); static Tcl_Obj * WinReadLink(CONST TCHAR *LinkSource); static Tcl_Obj * WinReadLinkDirectory(CONST TCHAR *LinkDirectory); static int WinLink(CONST TCHAR *LinkSource, CONST TCHAR *LinkTarget, int linkAction); static int WinSymLinkDirectory(CONST TCHAR *LinkDirectory, CONST TCHAR *LinkTarget); /* *-------------------------------------------------------------------- * * WinLink -- * * Make a link from source to target. * *-------------------------------------------------------------------- */ 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 source file/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? * *-------------------------------------------------------------------- */ 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; DWORD 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), or NULL if * anything went wrong. * * In the future we should enhance this to return a path object rather * than a string. * *-------------------------------------------------------------------- */ static Tcl_Obj* WinReadLinkDirectory(LinkDirectory) CONST TCHAR *LinkDirectory; { int attr; 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; int offset = 0; /* * Certain native path representations on Windows have a special * prefix to indicate that they are to be treated specially. For * example extremely long paths, or symlinks, or volumes mounted * inside directories. * * There is an assumption in this code that 'wide' interfaces are * being used (see tclWin32Dll.c), which is true for the only systems * which support reparse tags at present. If that changes in the * future, this code will have to be generalised. */ if (reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer[0] == L'\\') { /* * Check whether this is a mounted volume. */ if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, L"\\??\\Volume{",11) == 0) { char drive; /* * There is some confusion between \??\ and \\?\ which we have * to fix here. It doesn't seem very well documented. */ reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer[1] = L'\\'; /* * Check if a corresponding drive letter exists, and use that * if it is found */ drive = TclWinDriveLetterForVolMountPoint( reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer); if (drive != -1) { char driveSpec[3] = { '\0', ':', '\0' }; driveSpec[0] = drive; retVal = Tcl_NewStringObj(driveSpec,2); Tcl_IncrRefCount(retVal); return retVal; } /* * This is actually a mounted drive, which doesn't exists as a * DOS drive letter. This means the path isn't actually a * link, although we partially treat it like one ('file type' * will return 'link'), but then the link will actually just * be treated like an ordinary directory. I don't believe any * serious inconsistency will arise from this, but it is * something to be aware of. */ Tcl_SetErrno(EINVAL); return NULL; } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer .PathBuffer, L"\\\\?\\",4) == 0) { /* * Strip off the prefix. */ offset = 4; } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer .PathBuffer, L"\\??\\",4) == 0) { /* * Strip off the prefix. */ offset = 4; } } Tcl_WinTCharToUtf((CONST char*) reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, (int) reparseBuffer->SymbolicLinkReparseBuffer .SubstituteNameLength, &ds); copy = Tcl_DStringValue(&ds)+offset; len = Tcl_DStringLength(&ds)-offset; retVal = Tcl_NewStringObj(copy,len); Tcl_IncrRefCount(retVal); Tcl_DStringFree(&ds); return retVal; } default: 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; DWORD 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; DWORD 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, (DWORD) 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 function computes the absolute path name of the current * application. * * Results: * None. * * Side effects: * The computed path is stored. * *--------------------------------------------------------------------------- */ |
︙ | ︙ | |||
696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 | /* * Under Windows we ignore argv0, and return the path for the file used to * create this process. */ if (GetModuleFileNameW(NULL, wName, MAX_PATH) == 0) { GetModuleFileNameA(NULL, name, sizeof(name)); /* * Convert to WCHAR to get out of ANSI codepage */ MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH); } WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); TclWinNoBackslash(name); TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL); } /* *---------------------------------------------------------------------- * * TclpMatchInDirectory -- * | > > > | | | < | | | | > | > | > > > | > > | | > | < | | | | | | | | < > | | | | | | | | | | > > | < | > | > > | | | | | | < | > > > | | | | > | | | > | | | | | | | | | | > | > > | | | | > | | | | | < | | | | > | | | | > | | | | > | > > | | | > | > > | > | | < > | > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | > | | | | | | | | | | > | > > | > | | > | > | < | | | | | < | | > | > > > | | < | < | < | < | < < < | < > > | > | | | | | | 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 | /* * Under Windows we ignore argv0, and return the path for the file used to * create this process. */ if (GetModuleFileNameW(NULL, wName, MAX_PATH) == 0) { GetModuleFileNameA(NULL, name, sizeof(name)); /* * Convert to WCHAR to get out of ANSI codepage */ MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH); } WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); TclWinNoBackslash(name); TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL); } /* *---------------------------------------------------------------------- * * TclpMatchInDirectory -- * * This routine is used by the globbing code to search a directory for * all files which match a given pattern. * * Results: * The return value is a standard Tcl result indicating whether an error * occurred in globbing. Errors are left in interp, good results are * lappended to resultPtr (which must be a valid object). * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) Tcl_Interp *interp; /* Interpreter to receive errors. */ Tcl_Obj *resultPtr; /* List object to lappend results. */ Tcl_Obj *pathPtr; /* Contains path to directory to search. */ CONST char *pattern; /* Pattern to match against. */ Tcl_GlobTypeData *types; /* Object containing list of acceptable types. * May be NULL. In particular the directory * flag is very important. */ { CONST TCHAR *native; if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) { /* * The native filesystem never adds mounts. */ return TCL_OK; } if (pattern == NULL || (*pattern == '\0')) { Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (norm != NULL) { /* * Match a single file directly. */ int len; DWORD attr; CONST char *str = Tcl_GetStringFromObj(norm,&len); native = (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr); if (tclWinProcs->getFileAttributesExProc == NULL) { attr = (*tclWinProcs->getFileAttributesProc)(native); if (attr == 0xffffffff) { return TCL_OK; } } else { WIN32_FILE_ATTRIBUTE_DATA data; if ((*tclWinProcs->getFileAttributesExProc)(native, GetFileExInfoStandard, &data) != TRUE) { return TCL_OK; } attr = data.dwFileAttributes; } if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); } } return TCL_OK; } else { DWORD attr; HANDLE handle; WIN32_FIND_DATAT data; CONST char *dirName; /* UTF-8 dir name, later with pattern * appended. */ int dirLength; int matchSpecialDots; Tcl_DString ds; /* Native encoding of dir, also used * temporarily for other things. */ Tcl_DString dsOrig; /* UTF-8 encoding of dir. */ Tcl_Obj *fileNamePtr; char lastChar; /* * Get the normalized path representation (the main thing is we dont * want any '~' sequences). */ fileNamePtr = Tcl_FSGetNormalizedPath(interp, pathPtr); if (fileNamePtr == NULL) { return TCL_ERROR; } /* * Verify that the specified path exists and is actually a directory. */ native = Tcl_FSGetNativePath(pathPtr); if (native == NULL) { return TCL_OK; } attr = (*tclWinProcs->getFileAttributesProc)(native); if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { return TCL_OK; } /* * Build up the directory name for searching, including a trailing * directory separator. */ Tcl_DStringInit(&dsOrig); dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); lastChar = dirName[dirLength -1]; if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) { Tcl_DStringAppend(&dsOrig, "/", 1); dirLength++; } dirName = Tcl_DStringValue(&dsOrig); /* * We need to check all files in the directory, so we append '*.*' to * the path, unless the pattern we've been given is rather simple, * when we can use that instead. */ if (strpbrk(pattern, "[]\\") == NULL) { /* * The pattern is a simple one containing just '*' and/or '?'. * This means we can get the OS to help us, by passing it the * pattern. */ dirName = Tcl_DStringAppend(&dsOrig, pattern, -1); } else { dirName = Tcl_DStringAppend(&dsOrig, "*.*", 3); } native = Tcl_WinUtfToTChar(dirName, -1, &ds); if (tclWinProcs->findFirstFileExProc == NULL || (types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) { handle = (*tclWinProcs->findFirstFileProc)(native, &data); } else { /* * We can be more efficient, for pure directory requests. */ handle = (*tclWinProcs->findFirstFileExProc)(native, FindExInfoStandard, &data, FindExSearchLimitToDirectories, NULL, 0); } if (handle == INVALID_HANDLE_VALUE) { DWORD err = GetLastError(); Tcl_DStringFree(&ds); if (err == ERROR_FILE_NOT_FOUND) { /* * We used our 'pattern' above, and matched nothing. This * means we just return TCL_OK, indicating no results found. */ Tcl_DStringFree(&dsOrig); return TCL_OK; } TclWinConvertError(err); if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't read directory \"", Tcl_DStringValue(&dsOrig), "\": ", Tcl_PosixError(interp), (char *) NULL); } Tcl_DStringFree(&dsOrig); return TCL_ERROR; } Tcl_DStringFree(&ds); /* * We may use this later, so we must restore it to its length * including the directory delimiter. */ Tcl_DStringSetLength(&dsOrig, dirLength); /* * Check to see if the pattern should match the special . and * .. names, referring to the current directory, or the directory * above. We need a special check for this because paths beginning * with a dot are not considered hidden on Windows, and so otherwise a * relative glob like 'glob -join * *' will actually return * './. ../..' etc. */ if ((pattern[0] == '.') || ((pattern[0] == '\\') && (pattern[1] == '.'))) { matchSpecialDots = 1; } else { matchSpecialDots = 0; } /* * Now iterate over all of the files in the directory, starting with * the first one we found. */ do { CONST char *utfname; int checkDrive = 0; int isDrive; DWORD attr; if (tclWinProcs->useWide) { native = (CONST TCHAR *) data.w.cFileName; attr = data.w.dwFileAttributes; } else { native = (CONST TCHAR *) data.a.cFileName; attr = data.a.dwFileAttributes; } utfname = Tcl_WinTCharToUtf(native, -1, &ds); if (!matchSpecialDots) { /* * If it is exactly '.' or '..' then we ignore it. */ if ((utfname[0] == '.') && (utfname[1] == '\0' || (utfname[1] == '.' && utfname[2] == '\0'))) { Tcl_DStringFree(&ds); continue; } } else if (utfname[0] == '.' && utfname[1] == '.' && utfname[2] == '\0') { /* * Have to check if this is a drive below, so we can correctly * match 'hidden' and not hidden files. */ checkDrive = 1; } /* * Check to see if the file matches the pattern. Note that we are * ignoring the case sensitivity flag because Windows doesn't * honor case even if the volume is case sensitive. If the volume * also doesn't preserve case, then we previously returned the * lower case form of the name. This didn't seem quite right since * there are non-case-preserving volumes that actually return * mixed case. So now we are returning exactly what we get from * the system. */ if (Tcl_StringCaseMatch(utfname, pattern, 1)) { /* * If the file matches, then we need to process the remainder * of the path. */ if (checkDrive) { CONST char *fullname = Tcl_DStringAppend(&dsOrig, utfname, Tcl_DStringLength(&ds)); isDrive = WinIsDrive(fullname, Tcl_DStringLength(&dsOrig)); Tcl_DStringSetLength(&dsOrig, dirLength); } else { isDrive = 0; } if (NativeMatchType(isDrive, attr, native, types)) { Tcl_ListObjAppendElement(interp, resultPtr, TclNewFSPathObj(pathPtr, utfname, Tcl_DStringLength(&ds))); } } /* * Free ds here to ensure that native is valid above. */ Tcl_DStringFree(&ds); } while ((*tclWinProcs->findNextFileProc)(handle, &data) == TRUE); FindClose(handle); Tcl_DStringFree(&dsOrig); return TCL_OK; } } /* * Does the given path represent a root volume? We need this special case * because for NTFS root volumes, the getFileAttributesProc returns a 'hidden' * attribute when it should not. */ static int WinIsDrive( CONST char *name, /* Name (UTF-8) */ int len) /* Length of name */ { int remove = 0; while (len > 4) { if ((name[len-1] != '.' || name[len-2] != '.') || (name[len-3] != '/' && name[len-3] != '\\')) { /* * We don't have '/..' at the end. */ if (remove == 0) { break; } remove--; while (len > 0) { len--; if (name[len] == '/' || name[len] == '\\') { break; } } if (len < 4) { len++; break; } } else { /* * We do have '/..' */ len -= 3; remove++; } } if (len < 4) { if (len == 0) { /* * Not sure if this is possible, but we pass it on anyway. */ } else if (len == 1 && (name[0] == '/' || name[0] == '\\')) { /* * Path is pointing to the root volume. */ return 1; } else if ((name[1] == ':') && (len == 2 || (name[2] == '/' || name[2] == '\\'))) { /* * Path is of the form 'x:' or 'x:/' or 'x:\' */ return 1; } } return 0; } /* * Does the given path represent a reserved window path name? If not return 0, * if true, return the number of characters of the path that we actually want * (not any trailing :). */ static int WinIsReserved( CONST char *path) /* Path in UTF-8 */ { if ((path[0] == 'c' || path[0] == 'C') && (path[1] == 'o' || path[1] == 'O')) { if ((path[2] == 'm' || path[2] == 'M') && path[3] >= '1' && path[3] <= '4') { /* * May have match for 'com[1-4]:?', which is a serial port. */ if (path[4] == '\0') { return 4; } else if (path [4] == ':' && path[5] == '\0') { return 4; } } else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') { /* * Have match for 'con' */ return 3; } } else if ((path[0] == 'l' || path[0] == 'L') && (path[1] == 'p' || path[1] == 'P') && (path[2] == 't' || path[2] == 'T')) { if (path[3] >= '1' && path[3] <= '3') { /* * May have match for 'lpt[1-3]:?' */ if (path[4] == '\0') { return 4; } else if (path [4] == ':' && path[5] == '\0') { return 4; } } } else if (!stricmp(path, "prn") || !stricmp(path, "nul") || !stricmp(path, "aux")) { /* * Have match for 'prn', 'nul' or 'aux'. */ return 3; } return 0; } /* *---------------------------------------------------------------------- * * NativeMatchType -- * * This function needs a special case for a path which is a root volume, * because for NTFS root volumes, the getFileAttributesProc returns a * 'hidden' attribute when it should not. * * We never make any calss to a 'get attributes' routine here, since we * have arranged things so that our caller already knows such * information. * * Results: * 0 = file doesn't match * 1 = file matches * *---------------------------------------------------------------------- */ static int NativeMatchType( int isDrive, /* Is this a drive. */ DWORD attr, /* We already know the attributes for the * file. */ CONST TCHAR *nativeName, /* Native path to check. */ Tcl_GlobTypeData *types) /* Type description to match against. */ { /* * 'attr' represents the attributes of the file, but we only want to * retrieve this info if it is absolutely necessary because it is an * expensive call. Unfortunately, to deal with hidden files properly, we * must always retrieve it. */ if (types == NULL) { /* * If invisible, don't return the file. */ if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { return 0; } } else { if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { /* * If invisible. */ if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) { return 0; } } else { /* * Visible. */ if (types->perm & TCL_GLOB_PERM_HIDDEN) { return 0; } } if (types->perm != 0) { if (((types->perm & TCL_GLOB_PERM_RONLY) && !(attr & FILE_ATTRIBUTE_READONLY)) || ((types->perm & TCL_GLOB_PERM_R) && (0 /* File exists => R_OK on Windows */)) || ((types->perm & TCL_GLOB_PERM_W) && (attr & FILE_ATTRIBUTE_READONLY)) || ((types->perm & TCL_GLOB_PERM_X) && (!(attr & FILE_ATTRIBUTE_DIRECTORY) && !NativeIsExec(nativeName)))) { return 0; } } if ((types->type & TCL_GLOB_TYPE_DIR) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { /* * Quicker test for directory, which is a common case. */ return 1; } else if (types->type != 0) { unsigned short st_mode; int isExec = NativeIsExec(nativeName); st_mode = NativeStatMode(attr, 0, isExec); /* * In order bcdpfls as in 'find -t' */ if (((types->type&TCL_GLOB_TYPE_BLOCK) && S_ISBLK(st_mode)) || ((types->type&TCL_GLOB_TYPE_CHAR) && S_ISCHR(st_mode)) || ((types->type&TCL_GLOB_TYPE_DIR) && S_ISDIR(st_mode)) || ((types->type&TCL_GLOB_TYPE_PIPE) && S_ISFIFO(st_mode)) || #ifdef S_ISSOCK ((types->type&TCL_GLOB_TYPE_SOCK) && S_ISSOCK(st_mode)) || #endif ((types->type&TCL_GLOB_TYPE_FILE) && S_ISREG(st_mode))) { /* * Do nothing - this file is ok. */ } else { #ifdef S_ISLNK if (types->type & TCL_GLOB_TYPE_LINK) { st_mode = NativeStatMode(attr, 1, isExec); if (S_ISLNK(st_mode)) { return 1; } } #endif return 0; } } } return 1; } /* *---------------------------------------------------------------------- * * TclpGetUserHome -- * * This function takes the passed in user name and finds the * corresponding home directory specified in the password file. * * Results: * The result is a pointer to a string specifying the user's home * directory, or NULL if the user's home directory could not be * determined. Storage for the result string is allocated in bufferPtr; * the caller must call Tcl_DStringFree() when the result is no longer * needed. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1188 1189 1190 1191 1192 1193 1194 | if (netapiInst != NULL) { NETAPIBUFFERFREEPROC *netApiBufferFreeProc; NETGETDCNAMEPROC *netGetDCNameProc; NETUSERGETINFOPROC *netUserGetInfoProc; netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) GetProcAddress(netapiInst, "NetApiBufferFree"); | | | | 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 | if (netapiInst != NULL) { NETAPIBUFFERFREEPROC *netApiBufferFreeProc; NETGETDCNAMEPROC *netGetDCNameProc; NETUSERGETINFOPROC *netUserGetInfoProc; netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) GetProcAddress(netapiInst, "NetApiBufferFree"); netGetDCNameProc = (NETGETDCNAMEPROC *) GetProcAddress(netapiInst, "NetGetDCName"); netUserGetInfoProc = (NETUSERGETINFOPROC *) GetProcAddress(netapiInst, "NetUserGetInfo"); if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) && (netApiBufferFreeProc != NULL)) { USER_INFO_1 *uiPtr; Tcl_DString ds; int nameLen, badDomain; char *domain; |
︙ | ︙ | |||
1223 1224 1225 1226 1227 1228 1229 | if ((*netUserGetInfoProc)(wDomain, wName, 1, (LPBYTE *) &uiPtr) == 0) { wHomeDir = uiPtr->usri1_home_dir; if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir), bufferPtr); } else { | | | | | | | | | | | | | < | > | | > | | | | | < | | | | < | | | | > | | | | > | | | > | | > | | > | | | | | | | | | | | | | | > | | > | | | > | | | > | | > | | < > | | | | > | | | > | > | > | > | 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 | if ((*netUserGetInfoProc)(wDomain, wName, 1, (LPBYTE *) &uiPtr) == 0) { wHomeDir = uiPtr->usri1_home_dir; if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir), bufferPtr); } else { /* * User exists but has no home dir. Return * "{Windows Drive}:/users/default". */ GetWindowsDirectoryW(buf, MAX_PATH); Tcl_UniCharToUtfDString(buf, 2, bufferPtr); Tcl_DStringAppend(bufferPtr, "/users/default", -1); } result = Tcl_DStringValue(bufferPtr); (*netApiBufferFreeProc)((void *) uiPtr); } Tcl_DStringFree(&ds); } if (wDomain != NULL) { (*netApiBufferFreeProc)((void *) wDomain); } } FreeLibrary(netapiInst); } if (result == NULL) { /* * Look in the "Password Lists" section of system.ini for the local * user. There are also entries in that section that begin with a "*" * character that are used by Windows for other purposes; ignore user * names beginning with a "*". */ char buf[MAX_PATH]; if (name[0] != '*') { if (GetPrivateProfileStringA("Password Lists", name, "", buf, MAX_PATH, "system.ini") > 0) { /* * User exists, but there is no such thing as a home directory * in system.ini. Return "{Windows drive}:/". */ GetWindowsDirectoryA(buf, MAX_PATH); Tcl_DStringAppend(bufferPtr, buf, 3); result = Tcl_DStringValue(bufferPtr); } } } return result; } /* *--------------------------------------------------------------------------- * * NativeAccess -- * * This function replaces the library version of access(), fixing the * following bugs: * * 1. access() returns that all files have execute permission. * * Results: * See access documentation. * * Side effects: * See access documentation. * *--------------------------------------------------------------------------- */ static int NativeAccess(nativePath, mode) CONST TCHAR *nativePath; /* Path of file to access, native encoding. */ int mode; /* Permission setting. */ { DWORD attr; attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr == 0xffffffff) { /* * File doesn't exist. */ TclWinConvertError(GetLastError()); return -1; } if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) { /* * File is not writable. */ Tcl_SetErrno(EACCES); return -1; } if (mode & X_OK) { if (!(attr & FILE_ATTRIBUTE_DIRECTORY) && !NativeIsExec(nativePath)) { /* * It's not a directory and doesn't have the correct extension. * Therefore it can't be executable */ Tcl_SetErrno(EACCES); return -1; } } /* * It looks as if the permissions are ok, but if we are on NT, 2000 or XP, * we have a more complex permissions structure so we try to check that. * The code below is remarkably complex for such a simple thing as finding * what permissions the OS has set for a file. * * If we are simply checking for file existence, then we don't need all * these complications (which are really quite slow: with this code 'file * readable' is 5-6 times slower than 'file exists'). */ if ((mode != F_OK) && (tclWinProcs->getFileSecurityProc != NULL)) { SECURITY_DESCRIPTOR *sdPtr = NULL; unsigned long size; GENERIC_MAPPING genMap; HANDLE hToken = NULL; DWORD desiredAccess = 0; DWORD grantedAccess; BOOL accessYesNo; PRIVILEGE_SET privSet; DWORD privSetSize = sizeof(PRIVILEGE_SET); int error; /* * First find out how big the buffer needs to be */ size = 0; (*tclWinProcs->getFileSecurityProc)(nativePath, OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION, 0, 0, &size); /* * Should have failed with ERROR_INSUFFICIENT_BUFFER */ error = GetLastError(); if (error != ERROR_INSUFFICIENT_BUFFER) { /* * Most likely case is ERROR_ACCESS_DENIED, which we will convert * to EACCES - just what we want! */ TclWinConvertError(error); return -1; } /* * Now size contains the size of buffer needed */ sdPtr = (SECURITY_DESCRIPTOR *) HeapAlloc(GetProcessHeap(), 0, size); if (sdPtr == NULL) { goto accessError; } /* * Call GetFileSecurity() for real */ if (!(*tclWinProcs->getFileSecurityProc)(nativePath, OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION, sdPtr, size, &size)) { /* * Error getting owner SD */ goto accessError; } /* * Perform security impersonation of the user and open the * resulting thread token. */ if (!(*tclWinProcs->impersonateSelfProc)(SecurityImpersonation)) { /* * Unable to perform security impersonation. */ goto accessError; } if (!(*tclWinProcs->openThreadTokenProc)(GetCurrentThread (), TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken)) { /* * Unable to get current thread's token. */ goto accessError; } (*tclWinProcs->revertToSelfProc)(); memset (&genMap, 0x00, sizeof (GENERIC_MAPPING)); /* * Setup desiredAccess according to the access priveleges we are * checking. */ genMap.GenericAll = 0; if (mode & R_OK) { desiredAccess |= FILE_GENERIC_READ; } if (mode & W_OK) { desiredAccess |= FILE_GENERIC_WRITE; } if (mode & X_OK) { desiredAccess |= FILE_GENERIC_EXECUTE; } /* * Perform access check using the token. */ if (!(*tclWinProcs->accessCheckProc)(sdPtr, hToken, desiredAccess, &genMap, &privSet, &privSetSize, &grantedAccess, &accessYesNo)) { /* * Unable to perform access check. */ accessError: TclWinConvertError(GetLastError()); if (sdPtr != NULL) { HeapFree(GetProcessHeap(), 0, sdPtr); } if (hToken != NULL) { CloseHandle(hToken); } return -1; } /* * Clean up. */ HeapFree(GetProcessHeap (), 0, sdPtr); CloseHandle(hToken); if (!accessYesNo) { Tcl_SetErrno(EACCES); return -1; } } return 0; } /* *---------------------------------------------------------------------- * * NativeIsExec -- * * Determines if a path is executable. On windows this is simply defined * by whether the path ends in any of ".exe", ".com", or ".bat" * * Results: * 1 = executable, 0 = not. * *---------------------------------------------------------------------- */ static int NativeIsExec(nativePath) CONST TCHAR *nativePath; { if (tclWinProcs->useWide) { CONST WCHAR *path; int len; path = (CONST WCHAR*)nativePath; len = wcslen(path); if (len < 5) { return 0; } if (path[len-4] != L'.') { return 0; } /* * Use wide-char case-insensitive comparison */ if ((_wcsicmp(path+len-3,L"exe") == 0) || (_wcsicmp(path+len-3,L"com") == 0) || (_wcsicmp(path+len-3,L"bat") == 0)) { return 1; } } else { CONST char *p; /* * We are only looking for pure ascii. */ p = strrchr((CONST char*)nativePath, '.'); if (p != NULL) { p++; /* * Note: in the old code, stat considered '.pif' files as * executable, whereas access did not. */ if ((stricmp(p, "exe") == 0) || (stricmp(p, "com") == 0) || (stricmp(p, "bat") == 0)) { /* * File that ends with .exe, .com, or .bat is executable. */ |
︙ | ︙ | |||
1541 1542 1543 1544 1545 1546 1547 | * * This function replaces the library version of chdir(). * * Results: * See chdir() documentation. * * Side effects: | | | | | < > > | > > | 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 | * * This function replaces the library version of chdir(). * * Results: * See chdir() documentation. * * Side effects: * See chdir() documentation. * *---------------------------------------------------------------------- */ int TclpObjChdir(pathPtr) Tcl_Obj *pathPtr; /* Path to new working directory. */ { int result; CONST TCHAR *nativePath; #ifdef __CYGWIN__ extern int cygwin_conv_to_posix_path(CONST char *, char *); char posixPath[MAX_PATH+1]; CONST char *path; Tcl_DString ds; #endif /* __CYGWIN__ */ nativePath = (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr); #ifdef __CYGWIN__ /* * Cygwin chdir only groks POSIX path. */ path = Tcl_WinTCharToUtf(nativePath, -1, &ds); cygwin_conv_to_posix_path(path, posixPath); result = (chdir(posixPath) == 0 ? 1 : 0); Tcl_DStringFree(&ds); #else /* __CYGWIN__ */ result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath); #endif /* __CYGWIN__ */ |
︙ | ︙ | |||
1584 1585 1586 1587 1588 1589 1590 | #ifdef __CYGWIN__ /* *--------------------------------------------------------------------------- * * TclpReadlink -- * | | | | | | | | | | | | | | | | | | | | | < | | | < | | | | | | > | | | | | | | | | | | | | | | | | | > | | | | < | | | > | | | | | > | | < < | | | > | | | | | | | | | | < > | > | > | | | | | 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 | #ifdef __CYGWIN__ /* *--------------------------------------------------------------------------- * * TclpReadlink -- * * This function replaces the library version of readlink(). * * Results: * The result is a pointer to a string specifying the contents of the * symbolic link given by 'path', or NULL if the symbolic link could not * be read. Storage for the result string is allocated in bufferPtr; the * caller must call Tcl_DStringFree() when the result is no longer * needed. * * Side effects: * See readlink() documentation. * *--------------------------------------------------------------------------- */ char * TclpReadlink(path, linkPtr) CONST char *path; /* Path of file to readlink (UTF-8). */ Tcl_DString *linkPtr; /* Uninitialized or free DString filled with * contents of link (UTF-8). */ { char link[MAXPATHLEN]; int length; char *native; 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__ */ /* *---------------------------------------------------------------------- * * TclpGetCwd -- * * This function replaces the library version of getcwd(). (Obsolete * function, only retained for old extensions which may call it * directly). * * Results: * The result is a pointer to a string specifying the current directory, * or NULL if the current directory could not be determined. If NULL is * returned, an error message is left in the interp's result. Storage for * the result string is allocated in bufferPtr; the caller must call * Tcl_DStringFree() when the result is no longer needed. * * Side effects: * None. * *---------------------------------------------------------------------- */ CONST char * TclpGetCwd(interp, bufferPtr) Tcl_Interp *interp; /* If non-NULL, used for error reporting. */ Tcl_DString *bufferPtr; /* Uninitialized or free DString filled with * name of current directory. */ { WCHAR buffer[MAX_PATH]; char *p; if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); if (interp != NULL) { Tcl_AppendResult(interp, "error getting working directory name: ", Tcl_PosixError(interp), (char *) NULL); } return NULL; } /* * Watch for the weird Windows c:\\UNC syntax. */ if (tclWinProcs->useWide) { WCHAR *native; native = (WCHAR *) buffer; if ((native[0] != '\0') && (native[1] == ':') && (native[2] == '\\') && (native[3] == '\\')) { native += 2; } Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr); } else { char *native; native = (char *) buffer; if ((native[0] != '\0') && (native[1] == ':') && (native[2] == '\\') && (native[3] == '\\')) { native += 2; } Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr); } /* * Convert to forward slashes for easier use in scripts. */ for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { if (*p == '\\') { *p = '/'; } } return Tcl_DStringValue(bufferPtr); } int TclpObjStat(pathPtr, statPtr) Tcl_Obj *pathPtr; /* Path of file to stat. */ Tcl_StatBuf *statPtr; /* Filled with results of stat call. */ { #ifdef OLD_API Tcl_Obj *transPtr; /* * Eliminate file names containing wildcard characters, or subsequent call * to FindFirstFile() will expand them, matching some other file. */ transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); if (transPtr == NULL || (strpbrk(Tcl_GetString(transPtr), "?*") != NULL)) { if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } Tcl_SetErrno(ENOENT); return -1; } Tcl_DecrRefCount(transPtr); #endif /* * Ensure correct file sizes by forcing the OS to write any pending data * to disk. This is done only for channels which are dirty, i.e. have been * written to since the last flush here. */ TclWinFlushDirtyChannels(); return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 0); } /* *---------------------------------------------------------------------- * * NativeStat -- * * This function replaces the library version of stat(), fixing the * following bugs: * * 1. stat("c:") returns an error. * 2. Borland stat() return time in GMT instead of localtime. * 3. stat("\\server\mount") would return error. * 4. Accepts slashes or backslashes. * 5. st_dev and st_rdev were wrong for UNC paths. * * Results: * See stat documentation. * * 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; unsigned short mode; if (tclWinProcs->getFileAttributesExProc == NULL) { /* * We don't have the faster attributes proc, so we're probably running * on Win95. */ WIN32_FIND_DATAT data; HANDLE handle; handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data); if (handle == INVALID_HANDLE_VALUE) { /* * FindFirstFile() doesn't work on root directories, so call * GetFileAttributes() to see if the specified file exists. */ attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr == 0xffffffff) { Tcl_SetErrno(ENOENT); return -1; } /* * Make up some fake information for this file. It has the correct * file attributes and a time of 0. */ memset(&data, 0, sizeof(data)); data.a.dwFileAttributes = attr; } else { FindClose(handle); } (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath, &nativePart); fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds); dev = -1; if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) { CONST char *p; DWORD dw; CONST TCHAR *nativeVol; Tcl_DString volString; p = strchr(fullPath + 2, '\\'); p = strchr(p + 1, '\\'); if (p == NULL) { /* * Add terminating backslash to fullpath or * GetVolumeInformation() won't work. */ fullPath = Tcl_DStringAppend(&ds, "\\", 1); p = fullPath + Tcl_DStringLength(&ds); } else { p++; } nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString); dw = (DWORD) -1; (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); /* * GetFullPathName() turns special devices like "NUL" into * "\\.\NUL", but GetVolumeInformation() returns failure for * "\\.\NUL". This will cause "NUL" to get a drive number of -1, * which makes about as much sense as anything since the special * devices don't live on any drive. */ dev = dw; Tcl_DStringFree(&volString); } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) { dev = Tcl_UniCharToLower(fullPath[0]) - 'a'; } Tcl_DStringFree(&ds); attr = data.a.dwFileAttributes; statPtr->st_size = ((Tcl_WideInt)data.a.nFileSizeLow) | (((Tcl_WideInt)data.a.nFileSizeHigh) << 32); statPtr->st_atime = ToCTime(data.a.ftLastAccessTime); statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime); statPtr->st_ctime = ToCTime(data.a.ftCreationTime); } else { WIN32_FILE_ATTRIBUTE_DATA data; if ((*tclWinProcs->getFileAttributesExProc)(nativePath, GetFileExInfoStandard, &data) != TRUE) { Tcl_SetErrno(ENOENT); return -1; } (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath, &nativePart); fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds); dev = -1; if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) { CONST char *p; DWORD dw; CONST TCHAR *nativeVol; Tcl_DString volString; p = strchr(fullPath + 2, '\\'); p = strchr(p + 1, '\\'); if (p == NULL) { /* * Add terminating backslash to fullpath or * GetVolumeInformation() won't work. */ fullPath = Tcl_DStringAppend(&ds, "\\", 1); p = fullPath + Tcl_DStringLength(&ds); } else { p++; } nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString); dw = (DWORD) -1; (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); /* * GetFullPathName() turns special devices like "NUL" into * "\\.\NUL", but GetVolumeInformation() returns failure for * "\\.\NUL". This will cause "NUL" to get a drive number of -1, * which makes about as much sense as anything since the special * devices don't live on any drive. */ dev = dw; Tcl_DStringFree(&volString); } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) { dev = Tcl_UniCharToLower(fullPath[0]) - 'a'; } Tcl_DStringFree(&ds); attr = data.dwFileAttributes; 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); } mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath)); statPtr->st_dev = (dev_t) dev; statPtr->st_ino = 0; statPtr->st_mode = mode; statPtr->st_nlink = 1; statPtr->st_uid = 0; statPtr->st_gid = 0; statPtr->st_rdev = (dev_t) dev; return 0; } /* *---------------------------------------------------------------------- * * NativeStatMode -- * * Calculate just the 'st_mode' field of a 'stat' structure. * * In many places we don't need the full stat structure, and it's much * faster just to calculate these pieces, if that's all we need. * *---------------------------------------------------------------------- */ static unsigned short NativeStatMode(DWORD attr, int checkLinks, int isExec) { int mode; 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 (isExec) { 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; return (unsigned short)mode; } |
︙ | ︙ | |||
1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 | *------------------------------------------------------------------------ */ static time_t ToCTime(FILETIME fileTime) /* UTC time */ { LARGE_INTEGER convertedTime; convertedTime.LowPart = fileTime.dwLowDateTime; convertedTime.HighPart = (LONG) fileTime.dwHighDateTime; return (time_t) ((convertedTime.QuadPart | > > | < < | > | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | < | | > | > > | < > | > > | < | | | | | | | | | | | < | | > | | > | > < < | | | | > | < > | > > | > | > | | > | | | | | > > | | | | | < | | | | | > | | | < | | | | | < | | | | < | > | | > > | > > | | | | | > | < > | > > > > > > > > > > > > > > > > > > > > | > | > | | | | | < > | | | > | > > | | < > | > > > > | > > > > | | | > | > > | > | > > | | > | > | > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | < | > | | > | | | < | | | | < > > > | > > > > | > > > | | | > | | > | > | | | | | < > | < | < | > | > > > | > > > | | > | | | | > | | | > > | > < | | | | | > | > > > > | > > | | | < | > > | | > | > > > | | > | > > | | | | | | | | | | | > | | | | | | > | > > | > | | | | | | | > | | < | | < | > > | | < | | < | | < | | < > | | | | | < | | > | | | | | | | > > | > | | | | > | | | | | < > > | > > | | | | > | > | > | > > | > | > | | | | | | | | | | | > | | | | | | > > > > > > > > | 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 | *------------------------------------------------------------------------ */ static time_t ToCTime(FILETIME fileTime) /* UTC time */ { LARGE_INTEGER convertedTime; convertedTime.LowPart = fileTime.dwLowDateTime; convertedTime.HighPart = (LONG) fileTime.dwHighDateTime; return (time_t) ((convertedTime.QuadPart - (Tcl_WideInt) POSIX_EPOCH_AS_FILETIME) / (Tcl_WideInt) 10000000); } /* *------------------------------------------------------------------------ * * FromCTime -- * * Converts a time_t to a Windows FILETIME * * Results: * Returns the count of 100-ns ticks seconds from the Windows epoch. * *------------------------------------------------------------------------ */ static void FromCTime( time_t posixTime, FILETIME* fileTime) /* UTC Time */ { LARGE_INTEGER convertedTime; convertedTime.QuadPart = ((LONGLONG) posixTime) * 10000000 + POSIX_EPOCH_AS_FILETIME; fileTime->dwLowDateTime = convertedTime.LowPart; fileTime->dwHighDateTime = convertedTime.HighPart; } #if 0 /* *------------------------------------------------------------------------- * * TclWinResolveShortcut -- * * Resolve a potential Windows shortcut to get the actual file or * directory in question. * * Results: * Returns 1 if the shortcut could be resolved, or 0 if there was an * error or if the filename was not a shortcut. If bufferPtr did hold the * name of a shortcut, it is modified to hold the resolved target of the * shortcut instead. * * Side effects: * Loads and unloads OLE package to determine if filename refers to a * shortcut. * *------------------------------------------------------------------------- */ int TclWinResolveShortcut(bufferPtr) Tcl_DString *bufferPtr; /* Holds name of file to resolve. On return, * holds resolved file name. */ { HRESULT hres; IShellLink *psl; IPersistFile *ppf; WIN32_FIND_DATA wfd; WCHAR wpath[MAX_PATH]; char *path, *ext; char realFileName[MAX_PATH]; /* * Windows system calls do not automatically resolve shortcuts like UNIX * automatically will with symbolic links. */ path = Tcl_DStringValue(bufferPtr); ext = strrchr(path, '.'); if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) { return 0; } CoInitialize(NULL); path = Tcl_DStringValue(bufferPtr); realFileName[0] = '\0'; hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER, &IID_IShellLink, &psl); if (SUCCEEDED(hres)) { hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf); if (SUCCEEDED(hres)) { MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath)); hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ); if (SUCCEEDED(hres)) { hres = psl->lpVtbl->Resolve(psl,NULL,SLR_ANY_MATCH|SLR_NO_UI); if (SUCCEEDED(hres)) { hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH, &wfd, 0); } } ppf->lpVtbl->Release(ppf); } psl->lpVtbl->Release(psl); } CoUninitialize(); if (realFileName[0] != '\0') { Tcl_DStringSetLength(bufferPtr, 0); Tcl_DStringAppend(bufferPtr, realFileName, -1); return 1; } return 0; } #endif /* *--------------------------------------------------------------------------- * * TclpGetNativeCwd -- * * This function replaces the library version of getcwd(). * * Results: * The input and output are filesystem paths in native form. The result * is either the given clientData, if the working directory hasn't * changed, or a new clientData (owned by our caller), giving the new * native path, or NULL if the current directory could not be determined. * If NULL is returned, the caller can examine the standard posix error * codes to determine the cause of the problem. * * Side effects: * None. * *---------------------------------------------------------------------- */ ClientData TclpGetNativeCwd(clientData) ClientData clientData; { WCHAR buffer[MAX_PATH]; if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); return NULL; } if (clientData != NULL) { if (tclWinProcs->useWide) { /* * Unicode representation when running on NT/2K/XP. */ if (wcscmp((CONST WCHAR*)clientData, (CONST WCHAR*)buffer) == 0) { return clientData; } } else { /* * ANSI representation when running on 95/98/ME. */ if (strcmp((CONST char*)clientData, (CONST char*)buffer) == 0) { return clientData; } } } return TclNativeDupInternalRep((ClientData)buffer); } int TclpObjAccess(pathPtr, mode) 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; #if 0 TCHAR *LinkTarget = (TCHAR *) Tcl_FSGetNativePath(toPtr); #else TCHAR *LinkTarget = (TCHAR *) Tcl_FSGetNativePath( Tcl_FSGetNormalizedPath(NULL, toPtr)); #endif 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 /* *--------------------------------------------------------------------------- * * TclpFilesystemPathType -- * * This function is part of the native filesystem support, and returns * the path type of the given path. Returns NTFS or FAT or whatever is * returned by the 'volume information' proc. * * Results: * NULL at present. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_Obj* TclpFilesystemPathType(pathPtr) Tcl_Obj* pathPtr; { #define VOL_BUF_SIZE 32 int found; WCHAR volType[VOL_BUF_SIZE]; char* firstSeparator; CONST char *path; Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normPath == NULL) { return NULL; } path = Tcl_GetString(normPath); if (path == NULL) { return NULL; } firstSeparator = strchr(path, '/'); if (firstSeparator == NULL) { found = tclWinProcs->getVolumeInformationProc( Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL, NULL, (WCHAR *) volType, VOL_BUF_SIZE); } else { Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1); Tcl_IncrRefCount(driveName); found = tclWinProcs->getVolumeInformationProc( Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL, NULL, (WCHAR *) volType, VOL_BUF_SIZE); Tcl_DecrRefCount(driveName); } if (found == 0) { return NULL; } else { Tcl_DString ds; Tcl_Obj *objPtr; Tcl_WinTCharToUtf((CONST char *)volType, -1, &ds); objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); return objPtr; } #undef VOL_BUF_SIZE } /* * This define can be turned on to experiment with a different way of * normalizing paths (using a different Windows API). Unfortunately the new * path seems to take almost exactly the same amount of time as the old path! * The primary time taken by normalization is in * GetFileAttributesEx/FindFirstFile or GetFileAttributesEx/GetLongPathName. * Conversion to/from native is not a significant factor at all. * * Also, since we have to check for symbolic links (reparse points) then we * have to call GetFileAttributes on each path segment anyway, so there's no * benefit to doing anything clever there. */ /* #define TclNORM_LONG_PATH */ /* *--------------------------------------------------------------------------- * * 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; Tcl_DString dsNorm; /* This will hold the normalized string. */ 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. */ int isDrive = 1; Tcl_DString ds; currentPathEndPosition = path + nextCheckpoint; if (*currentPathEndPosition == '/') { currentPathEndPosition++; } 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. */ if (isDrive) { int len = WinIsReserved(path); if (len > 0) { /* * Actually it does exist - COM1, etc. */ int i; for (i=0;i<len;i++) { if (nativePath[i] >= 'a') { ((char*)nativePath)[i] -= ('a' - 'A'); } } Tcl_DStringAppend(&dsNorm, nativePath, len); lastValidPathEnd = currentPathEndPosition; } } Tcl_DStringFree(&ds); break; } if (nativePath[0] >= 'a') { ((char*)nativePath)[0] -= ('a' - 'A'); } Tcl_DStringAppend(&dsNorm, nativePath, Tcl_DStringLength(&ds)); } else { char *checkDots = NULL; if (lastValidPathEnd[1] == '.') { checkDots = lastValidPathEnd + 1; while (checkDots < currentPathEndPosition) { if (*checkDots != '.') { checkDots = NULL; break; } checkDots++; } } if (checkDots != NULL) { int dotLen = currentPathEndPosition - lastValidPathEnd; /* * Path is just dots. We shouldn't really ever see a * path like that. However, to be nice we at least * don't mangle the path - we just add the dots as a * path segment and continue */ Tcl_DStringAppend(&dsNorm, (TCHAR *) (nativePath + Tcl_DStringLength(&ds) - dotLen), dotLen); } else { /* * Normal path. */ 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; something with an NT core). */ Tcl_Obj *temp = NULL; int isDrive = 1; Tcl_DString ds; currentPathEndPosition = path + nextCheckpoint; if (*currentPathEndPosition == '/') { currentPathEndPosition++; } 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. */ if (isDrive) { int len = WinIsReserved(path); if (len > 0) { /* * Actually it does exist - COM1, etc. */ int i; for (i=0;i<len;i++) { WCHAR wc = ((WCHAR*)nativePath)[i]; if (wc >= L'a') { wc -= (L'a' - L'A'); ((WCHAR*)nativePath)[i] = wc; } } Tcl_DStringAppend(&dsNorm, nativePath, sizeof(WCHAR)*len); lastValidPathEnd = currentPathEndPosition; } } Tcl_DStringFree(&ds); break; } /* * File 'nativePath' does exist if we get here. We now want to * check if it is a symlink and otherwise 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. Now, reparse points need * not be normalized, otherwise we could use: * * Tcl_GetStringFromObj(to, &pathLen); * nextCheckpoint = pathLen * * So, instead we have to start from the beginning. */ nextCheckpoint = 0; 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; } } #ifndef TclNORM_LONG_PATH /* * 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 { char *checkDots = NULL; if (lastValidPathEnd[1] == '.') { checkDots = lastValidPathEnd + 1; while (checkDots < currentPathEndPosition) { if (*checkDots != '.') { checkDots = NULL; break; } checkDots++; } } if (checkDots != NULL) { int dotLen = currentPathEndPosition - lastValidPathEnd; /* * Path is just dots. We shouldn't really ever see a * path like that. However, to be nice we at least * don't mangle the path - we just add the dots as a * path segment and continue. */ Tcl_DStringAppend(&dsNorm, (TCHAR *) ((WCHAR*)(nativePath + Tcl_DStringLength(&ds)) - dotLen), (int)(dotLen * sizeof(WCHAR))); } else { /* * Normal path. */ WIN32_FIND_DATAW fData; HANDLE handle; handle = FindFirstFileW((WCHAR*)nativePath, &fData); if (handle == INVALID_HANDLE_VALUE) { /* * This is usually the '/' in 'c:/' at end of * string. */ Tcl_DStringAppend(&dsNorm,(CONST char*)L"/", sizeof(WCHAR)); } else { WCHAR *nativeName; if (fData.cFileName[0] != '\0') { nativeName = fData.cFileName; } else { nativeName = fData.cAlternateFileName; } FindClose(handle); Tcl_DStringAppend(&dsNorm, (CONST char*)L"/", sizeof(WCHAR)); Tcl_DStringAppend(&dsNorm, (TCHAR *) nativeName, (int) (wcslen(nativeName)*sizeof(WCHAR))); } } } #endif 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++; } #ifdef TclNORM_LONG_PATH /* * Convert the entire known path to long form. */ if (1) { WCHAR wpath[MAX_PATH]; CONST char *nativePath = Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds); DWORD wpathlen = (*tclWinProcs->getLongPathNameProc)( nativePath, (TCHAR *) wpath, MAX_PATH); /* * We have to make the drive letter uppercase. */ if (wpath[0] >= L'a') { wpath[0] -= (L'a' - L'A'); } Tcl_DStringAppend(&dsNorm, (TCHAR*)wpath, wpathlen*sizeof(WCHAR)); Tcl_DStringFree(&ds); } #endif } /* * 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; } /* *--------------------------------------------------------------------------- * * TclWinVolumeRelativeNormalize -- * * Only Windows has volume-relative paths. These paths are rather rare, * but it is nice if Tcl can handle them. It is much better if we can * handle them here, rather than in the native fs code, because we really * need to have a real absolute path just below. * * We do not let this block compile on non-Windows platforms because the * test suite's manual forcing of tclPlatform can otherwise cause this * code path to be executed, causing various errors because * volume-relative paths really do not exist. * * Results: * A valid normalized path. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_Obj* TclWinVolumeRelativeNormalize(interp, path, useThisCwdPtr) Tcl_Interp *interp; CONST char *path; Tcl_Obj **useThisCwdPtr; { Tcl_Obj *absolutePath, *useThisCwd; useThisCwd = Tcl_FSGetCwd(interp); if (useThisCwd == NULL) { return NULL; } if (path[0] == '/') { /* * Path of form /foo/bar which is a path in the root directory of the * current volume. */ CONST char *drive = Tcl_GetString(useThisCwd); absolutePath = Tcl_NewStringObj(drive,2); Tcl_AppendToObj(absolutePath, path, -1); Tcl_IncrRefCount(absolutePath); /* * We have a refCount on the cwd. */ } else { /* * Path of form C:foo/bar, but this only makes sense if the cwd is * also on drive C. */ int cwdLen; CONST char *drive = Tcl_GetStringFromObj(useThisCwd, &cwdLen); char drive_cur = path[0]; if (drive_cur >= 'a') { drive_cur -= ('a' - 'A'); } if (drive[0] == drive_cur) { absolutePath = Tcl_DuplicateObj(useThisCwd); /* * We have a refCount on the cwd, which we will release later. */ if (drive[cwdLen-1] != '/' && (path[2] != '\0')) { /* * Only add a trailing '/' if needed, which is if there isn't * one already, and if we are going to be adding some more * characters. */ Tcl_AppendToObj(absolutePath, "/", 1); } } else { Tcl_DecrRefCount(useThisCwd); useThisCwd = NULL; /* * The path is not in the current drive, but is volume-relative. * The way Tcl 8.3 handles this is that it treats such a path as * relative to the root of the drive. We therefore behave the same * here. This behaviour is, however, different to that of the * windows command-line. If we want to fix this at some point in * the future (at the expense of a behaviour change to Tcl), we * could use the '_dgetdcwd' Win32 API to get the drive's cwd. */ absolutePath = Tcl_NewStringObj(path, 2); Tcl_AppendToObj(absolutePath, "/", 1); } Tcl_IncrRefCount(absolutePath); Tcl_AppendToObj(absolutePath, path+2, -1); } *useThisCwdPtr = useThisCwd; return absolutePath; } /* *--------------------------------------------------------------------------- * * TclpNativeToNormalized -- * * Convert native format to a normalized path object, with refCount of * zero. * * Currently assumes all native paths are actually normalized already, so * if the path given is not normalized this will actually just convert to * a valid string path, but not necessarily a normalized one. * * Results: * A valid normalized path. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_Obj* TclpNativeToNormalized(clientData) ClientData clientData; { Tcl_DString ds; Tcl_Obj *objPtr; int len; char *copy; char *p; Tcl_WinTCharToUtf((CONST char*)clientData, -1, &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; } } /* * Ensure we are using forward slashes only. */ for (p = copy; *p != '\0'; p++) { if (*p == '\\') { *p = '/'; } } objPtr = Tcl_NewStringObj(copy,len); Tcl_DStringFree(&ds); return objPtr; } /* *--------------------------------------------------------------------------- * * TclNativeCreateNativeRep -- * * Create a native representation for the given path. * * Results: * The nativePath representation. * * Side effects: * Memory will be allocated. The path may need to be normalized. * *--------------------------------------------------------------------------- */ ClientData TclNativeCreateNativeRep(pathPtr) Tcl_Obj* pathPtr; { char *nativePathPtr; Tcl_DString ds; Tcl_Obj* validPathPtr; int len; char *str; if (TclFSCwdIsNative()) { /* * The cwd is native, which means we can use the translated path * without worrying about normalization (this will also usually be * shorter so the utf-to-external conversion will be somewhat faster). */ validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); } else { /* * Make sure the normalized path is set. */ validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); Tcl_IncrRefCount(validPathPtr); } str = Tcl_GetStringFromObj(validPathPtr, &len); Tcl_WinUtfToTChar(str, len, &ds); if (tclWinProcs->useWide) { len = Tcl_DStringLength(&ds) + sizeof(WCHAR); } else { len = Tcl_DStringLength(&ds) + sizeof(char); } Tcl_DecrRefCount(validPathPtr); nativePathPtr = ckalloc((unsigned) len); memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len); Tcl_DStringFree(&ds); return (ClientData)nativePathPtr; } /* *--------------------------------------------------------------------------- * * TclNativeDupInternalRep -- * * Duplicate the native representation. * * Results: * The copied native representation, or NULL if it is not possible to * copy the representation. * * Side effects: * Memory allocation for the copy. * *--------------------------------------------------------------------------- */ ClientData TclNativeDupInternalRep(clientData) ClientData clientData; { char *copy; size_t len; if (clientData == NULL) { return NULL; } if (tclWinProcs->useWide) { /* * Unicode representation when running on NT/2K/XP. */ len = sizeof(WCHAR) * (wcslen((CONST WCHAR *) clientData) + 1); } else { /* * ANSI representation when running on 95/98/ME. */ len = sizeof(char) * (strlen((CONST char *) clientData) + 1); } copy = (char *) ckalloc(len); memcpy((VOID *) copy, (VOID *) clientData, len); return (ClientData) copy; } /* *--------------------------------------------------------------------------- * * TclpUtime -- * * Set the modification date for a file. * * Results: * 0 on success, -1 on error. * * Side effects: * Sets errno to a representation of any Windows problem that's observed * in the process. * *--------------------------------------------------------------------------- */ int TclpUtime(pathPtr, tval) Tcl_Obj *pathPtr; /* File to modify */ struct utimbuf *tval; /* New modification date structure */ { int res = 0; HANDLE fileHandle; FILETIME lastAccessTime, lastModTime; FromCTime(tval->actime, &lastAccessTime); FromCTime(tval->modtime, &lastModTime); /* * We use the native APIs (not 'utime') because there are some daylight * savings complications that utime gets wrong. */ fileHandle = (tclWinProcs->createFileProc) ( (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr), FILE_WRITE_ATTRIBUTES, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (fileHandle == INVALID_HANDLE_VALUE || !SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) { TclWinConvertError(GetLastError()); res = -1; } if (fileHandle != INVALID_HANDLE_VALUE) { CloseHandle(fileHandle); } return res; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinInit.c.
1 2 3 4 5 6 7 8 9 | /* * tclWinInit.c -- * * Contains the Windows-specific interpreter initialization functions. * * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * | > > > | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 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 | /* * tclWinInit.c -- * * Contains the Windows-specific interpreter initialization functions. * * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinInit.c,v 1.64.2.2 2005/08/02 18:17:17 dgp Exp $ */ #include "tclWinInt.h" #include <winnt.h> #include <winbase.h> #include <lmcons.h> /* * GetUserName() is found in advapi32.dll */ #ifdef _MSC_VER # pragma comment(lib, "advapi32.lib") #endif /* * The following declaration is a workaround for some Microsoft brain damage. * The SYSTEM_INFO structure is different in various releases, even though the * layout is the same. So we overlay our own structure on top of it so we can * access the interesting slots in a uniform way. */ typedef struct { WORD wProcessorArchitecture; WORD wReserved; } OemId; /* * The following macros are missing from some versions of winnt.h. */ #ifndef PROCESSOR_ARCHITECTURE_INTEL #define PROCESSOR_ARCHITECTURE_INTEL 0 #endif #ifndef PROCESSOR_ARCHITECTURE_MIPS #define PROCESSOR_ARCHITECTURE_MIPS 1 #endif #ifndef PROCESSOR_ARCHITECTURE_ALPHA #define PROCESSOR_ARCHITECTURE_ALPHA 2 #endif #ifndef PROCESSOR_ARCHITECTURE_PPC #define PROCESSOR_ARCHITECTURE_PPC 3 #endif #ifndef PROCESSOR_ARCHITECTURE_SHX #define PROCESSOR_ARCHITECTURE_SHX 4 #endif #ifndef PROCESSOR_ARCHITECTURE_ARM #define PROCESSOR_ARCHITECTURE_ARM 5 #endif #ifndef PROCESSOR_ARCHITECTURE_IA64 #define PROCESSOR_ARCHITECTURE_IA64 6 #endif #ifndef PROCESSOR_ARCHITECTURE_ALPHA64 #define PROCESSOR_ARCHITECTURE_ALPHA64 7 #endif #ifndef PROCESSOR_ARCHITECTURE_MSIL #define PROCESSOR_ARCHITECTURE_MSIL 8 #endif #ifndef PROCESSOR_ARCHITECTURE_AMD64 #define PROCESSOR_ARCHITECTURE_AMD64 9 #endif #ifndef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 #define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10 #endif #ifndef PROCESSOR_ARCHITECTURE_UNKNOWN #define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF #endif /* * The following arrays contain the human readable strings for the Windows * platform and processor values. */ |
︙ | ︙ | |||
91 92 93 94 95 96 97 98 99 100 101 102 103 104 | "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "amd64", "ia32_on_win64" }; /* * The default directory in which the init.tcl file is expected to be found. */ static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir; static ProcessGlobalValue defaultLibraryDir = {0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL}; static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib); static int ToUtf(CONST WCHAR *wSrc, char *dst); | > | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "amd64", "ia32_on_win64" }; /* * The default directory in which the init.tcl file is expected to be found. */ static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir; static ProcessGlobalValue defaultLibraryDir = {0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL}; static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib); static int ToUtf(CONST WCHAR *wSrc, char *dst); |
︙ | ︙ | |||
123 124 125 126 127 128 129 | void TclpInitPlatform() { tclPlatform = TCL_PLATFORM_WINDOWS; /* | | | | | | < | | | | | | < | | | | | | | > | | | | 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 | void TclpInitPlatform() { tclPlatform = TCL_PLATFORM_WINDOWS; /* * The following code stops Windows 3.X and Windows NT 3.51 from * automatically putting up Sharing Violation dialogs, e.g, when someone * tries to access a file that is locked or a drive with no disk in it. * Tcl already returns the appropriate error to the caller, and they can * decide to put up their own dialog in response to that failure. * * Under 95 and NT 4.0, this is a NOOP because the system doesn't * automatically put up dialogs when the above operations fail. */ SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS); #ifdef STATIC_BUILD /* * If we are in a statically linked executable, then we need to explicitly * initialize the Windows function tables here since DllMain() will not be * invoked. */ TclWinInit(GetModuleHandle(NULL)); #endif } /* *------------------------------------------------------------------------- * * TclpInitLibraryPath -- * * This is the fallback routine that sets the library path if the * application has not set one by the first time it is needed. * * Results: * None. * * Side effects: * Sets the library path to an initial value. * *------------------------------------------------------------------------- */ void TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr) char **valuePtr; int *lengthPtr; Tcl_Encoding *encodingPtr; { #define LIBRARY_SIZE 32 Tcl_Obj *pathPtr; char installLib[LIBRARY_SIZE]; char *bytes; pathPtr = Tcl_NewObj(); /* * Initialize the substring used when locating the script library. The * installLib variable computes the script library path relative to the * installed DLL. */ sprintf(installLib, "lib/tcl%s", TCL_VERSION); /* * Look for the library relative to the TCL_LIBRARY env variable. If the * last dirname in the TCL_LIBRARY path does not match the last dirname in * the installLib variable, use the last dir name of installLib in * addition to the orginal TCL_LIBRARY path. */ AppendEnvironment(pathPtr, installLib); /* * Look for the library in its default location. */ Tcl_ListObjAppendElement(NULL, pathPtr, TclGetProcessGlobalValue(&defaultLibraryDir)); *encodingPtr = NULL; bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr); *valuePtr = ckalloc((unsigned int)(*lengthPtr)+1); memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t)(*lengthPtr)+1); Tcl_DecrRefCount(pathPtr); } /* *--------------------------------------------------------------------------- * * AppendEnvironment -- * * Append the value of the TCL_LIBRARY environment variable onto the path * pointer. If the env variable points to another version of tcl (e.g. * "tcl7.6") also append the path to this version (e.g., * "tcl7.6/../tcl8.2") * * Results: * None. * * Side effects: * None. |
︙ | ︙ | |||
241 242 243 244 245 246 247 | char buf[MAX_PATH * TCL_UTF_MAX]; Tcl_Obj *objPtr; Tcl_DString ds; CONST char **pathv; char *shortlib; /* | | | < > | | | | > | | | | < | | | 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 | char buf[MAX_PATH * TCL_UTF_MAX]; Tcl_Obj *objPtr; Tcl_DString ds; CONST char **pathv; char *shortlib; /* * The shortlib value needs to be the tail component of the lib path. For * example, "lib/tcl8.4" -> "tcl8.4" while "usr/share/tcl8.5" -> "tcl8.5". */ for (shortlib = (char *) &lib[strlen(lib)-1]; shortlib>lib ; shortlib--) { if (*shortlib == '/') { if ((unsigned)(shortlib - lib) == strlen(lib) - 1) { Tcl_Panic("last character in lib cannot be '/'"); } shortlib++; break; } } if (shortlib == lib) { Tcl_Panic("no '/' character found in lib"); } /* * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ that * this is a unicode string. */ if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) { buf[0] = '\0'; GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH); } else { ToUtf(wBuf, buf); } if (buf[0] != '\0') { objPtr = Tcl_NewStringObj(buf, -1); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); TclWinNoBackslash(buf); Tcl_SplitPath(buf, &pathc, &pathv); /* * The lstrcmpi() will work even if pathv[pathc-1] is random UTF-8 * chars because I know shortlib is ascii. */ if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) { CONST char *str; /* * TCL_LIBRARY is set but refers to a different tcl installation * than the current version. Try fiddling with the specified * directory to make it refer to this installation by removing the * old "tclX.Y" and substituting the current version string. */ pathv[pathc - 1] = shortlib; Tcl_DStringInit(&ds); str = Tcl_JoinPath(pathc, pathv, &ds); objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); } else { objPtr = Tcl_NewStringObj(buf, -1); } Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); ckfree((char *) pathv); } } /* *--------------------------------------------------------------------------- * * InitializeDefaultLibraryDir -- * * Locate the Tcl script library default location relative to the * location of the Tcl DLL. * * Results: * None. * * Side effects: * None. * |
︙ | ︙ | |||
338 339 340 341 342 343 344 | char *end, *p; if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { GetModuleFileNameA(hModule, name, MAX_PATH); } else { ToUtf(wName, name); } | > | | | | | | | > | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 | char *end, *p; if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { GetModuleFileNameA(hModule, name, MAX_PATH); } else { ToUtf(wName, name); } end = strrchr(name, '\\'); *end = '\0'; p = strrchr(name, '\\'); if (p != NULL) { end = p; } *end = '\\'; TclWinNoBackslash(name); sprintf(end + 1, "lib/tcl%s", TCL_VERSION); *lengthPtr = strlen(name); *valuePtr = ckalloc((unsigned int) *lengthPtr + 1); *encodingPtr = NULL; memcpy((VOID *) *valuePtr, (VOID *) name, (size_t) *lengthPtr + 1); } |
︙ | ︙ | |||
390 391 392 393 394 395 396 | } /* *--------------------------------------------------------------------------- * * TclWinEncodingsCleanup -- * | | | | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 | } /* *--------------------------------------------------------------------------- * * TclWinEncodingsCleanup -- * * Reset information to its original state in finalization to allow for * reinitialization to be possible. This must not be called until after * the filesystem has been finalised, or exit crashes may occur when * using virtual filesystems. * * Results: * None. * * Side effects: * Static information reset to startup state. * |
︙ | ︙ | |||
415 416 417 418 419 420 421 | } /* *--------------------------------------------------------------------------- * * TclpSetInitialEncodings -- * | | | | | | | | | | < > > > > > > > > > > > < < < < | | < | 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 | } /* *--------------------------------------------------------------------------- * * TclpSetInitialEncodings -- * * Based on the locale, determine the encoding of the operating system * and the default encoding for newly opened files. * * Called at process initialization time, and part way through startup, * we verify that the initial encodings were correctly setup. Depending * on Tcl's environment, there may not have been enough information first * time through (above). * * Results: * None. * * Side effects: * The Tcl library path is converted from native encoding to UTF-8, on * the first call, and the encodings may be changed on first or second * call. * *--------------------------------------------------------------------------- */ void TclpSetInitialEncodings() { Tcl_DString encodingName; TclpSetInterfaces(); Tcl_SetSystemEncoding(NULL, TclpGetEncodingNameFromEnvironment(&encodingName)); Tcl_DStringFree(&encodingName); } void TclpSetInterfaces() { int platformId, useWide; platformId = TclWinGetPlatformId(); useWide = ((platformId == VER_PLATFORM_WIN32_NT) || (platformId == VER_PLATFORM_WIN32_CE)); TclWinSetInterfaces(useWide); } CONST char * TclpGetEncodingNameFromEnvironment(bufPtr) Tcl_DString *bufPtr; { Tcl_DStringInit(bufPtr); wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP()); return Tcl_DStringValue(bufPtr); } /* *--------------------------------------------------------------------------- * * TclpSetVariables -- * * Performs platform-specific interpreter initialization related to the * tcl_platform and env variables, and other platform-specific things. * * Results: * None. * * Side effects: * Sets "tcl_platform", and "env(HOME)" Tcl variables. * |
︙ | ︙ | |||
519 520 521 522 523 524 525 | Tcl_SetVar2(interp, "tcl_platform", "machine", processors[oemId->wProcessorArchitecture], TCL_GLOBAL_ONLY); } #ifdef _DEBUG /* | | | | | > | 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 | Tcl_SetVar2(interp, "tcl_platform", "machine", processors[oemId->wProcessorArchitecture], TCL_GLOBAL_ONLY); } #ifdef _DEBUG /* * The existence of the "debug" element of the tcl_platform array * indicates that this particular Tcl shell has been compiled with debug * information. Using "info exists tcl_platform(debug)" a Tcl script can * direct the interpreter to load debug versions of DLLs with the load * command. */ Tcl_SetVar2(interp, "tcl_platform", "debug", "1", TCL_GLOBAL_ONLY); #endif /* |
︙ | ︙ | |||
574 575 576 577 578 579 580 | } /* *---------------------------------------------------------------------- * * TclpFindVariable -- * | | | | | | | < | 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 | } /* *---------------------------------------------------------------------- * * TclpFindVariable -- * * Locate the entry in environ for a given name. On Unix this routine is * case sensetive, on Windows this matches mioxed case. * * Results: * The return value is the index in environ of an entry with the name * "name", or -1 if there is no such entry. The integer at *lengthPtr is * filled in with the length of name (if a matching entry is found) or * the length of the environ array (if no matching entry is found). * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
605 606 607 608 609 610 611 | { int i, length, result = -1; register CONST char *env, *p1, *p2; char *envUpper, *nameUpper; Tcl_DString envString; /* | | < | | | | 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 | { int i, length, result = -1; register CONST char *env, *p1, *p2; char *envUpper, *nameUpper; Tcl_DString envString; /* * Convert the name to all upper case for the case insensitive comparison. */ length = strlen(name); nameUpper = (char *) ckalloc((unsigned) length+1); memcpy((VOID *) nameUpper, (VOID *) name, (size_t) length+1); Tcl_UtfToUpper(nameUpper); Tcl_DStringInit(&envString); for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) { /* * Chop the env string off after the equal sign, then Convert the name * to all upper case, so we do not have to convert all the characters * after the equal sign. */ envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString); p1 = strchr(envUpper, '='); if (p1 == NULL) { continue; } |
︙ | ︙ | |||
647 648 649 650 651 652 653 | } Tcl_DStringFree(&envString); } *lengthPtr = i; | | > > > > > > > > | 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 | } Tcl_DStringFree(&envString); } *lengthPtr = i; done: Tcl_DStringFree(&envString); ckfree(nameUpper); return result; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinLoad.c.
|
| | | | | | | | | | | | | | | | | | | | > | | | | > | > | > | | > > > | > | | | | > | | | | < | | | | | < | | | | | | | | | | | | < | | | | | > | > | | | | | | < | | | | | | | | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 | /* * tclWinLoad.c -- * * This function 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.17.2.1 2005/08/02 18:17:18 dgp 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; /* * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a * relative path. */ nativeName = Tcl_FSGetNativePath(pathPtr); handle = (*tclWinProcs->loadLibraryProc)(nativeName); if (handle == NULL) { /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; 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... */ LPTSTR lpMsgBuf; char *buf; int size; size = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, lastError, 0, (LPTSTR) &lpMsgBuf, 0, NULL); buf = (char *) ckalloc((unsigned) TCL_INTEGER_SPACE + size + 1); sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf); #endif Tcl_AppendResult(interp, "couldn't load library \"", Tcl_GetString(pathPtr), "\": ", (char *) NULL); /* * Check for possible DLL errors. This doesn't work quite right, * because Windows seems to only return ERROR_MOD_NOT_FOUND for just * about any problem, but it's better than nothing. It'd be even * better if there was a way to get what DLLs */ switch (lastError) { case ERROR_MOD_NOT_FOUND: case ERROR_DLL_NOT_FOUND: Tcl_AppendResult(interp, "this library or a dependent library", " could not be found in library path", (char *) NULL); break; case ERROR_PROC_NOT_FOUND: Tcl_AppendResult(interp, "A function specified in the import", " table could not be resolved by the system. Windows", " is not telling which one, I'm sorry.", (char *) NULL); break; case ERROR_INVALID_DLL: Tcl_AppendResult(interp, "this library or a dependent library", " is damaged", (char *) NULL); break; case ERROR_DLL_INIT_FAILED: Tcl_AppendResult(interp, "the library initialization", " routine failed", (char *) NULL); break; default: TclWinConvertError(lastError); 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 -- * * 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. */ { HINSTANCE handle; handle = (HINSTANCE) loadHandle; FreeLibrary(handle); } /* *---------------------------------------------------------------------- * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package name, * this function is invoked to try to figure it out. * * Results: * Always returns 0 to indicate that we couldn't figure out a package * name; generic code will then try to guess the package from the file * name. A return value of 1 would have meant that we figured out the * package name and put it in bufPtr. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclGuessPackageName(fileName, bufPtr) CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ Tcl_DString *bufPtr; /* Initialized empty dstring. Append package * name to this if possible. */ { return 0; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinNotify.c.
|
| | | | | | | | | | | | | | | | < | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | /* * tclWinNotify.c -- * * This file contains Windows-specific procedures for the notifier, which * is the lowest-level part of the Tcl event loop. This file works * together with ../generic/tclNotify.c. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinNotify.c,v 1.16.2.3 2005/08/02 18:17:18 dgp Exp $ */ #include "tclInt.h" /* * The follwing static indicates whether this module has been initialized. */ #define INTERVAL_TIMER 1 /* Handle of interval timer. */ #define WM_WAKEUP WM_USER /* Message that is send by * Tcl_AlertNotifier. */ /* * The following static structure contains the state information for the * Windows implementation of the Tcl notifier. One of these structures is * created for each thread that is using the notifier. */ typedef struct ThreadSpecificData { CRITICAL_SECTION crit; /* Monitor for this notifier. */ DWORD thread; /* Identifier for thread associated with this * notifier. */ HANDLE event; /* Event object used to wake up the notifier * thread. */ int pending; /* Alert message pending, this field is locked * by the notifierMutex. */ HWND hwnd; /* Messaging window. */ int timeout; /* Current timeout value. */ int timerActive; /* 1 if interval timer is running. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; extern TclStubs tclStubs; extern Tcl_NotifierProcs tclOriginalNotifier; /* * The following static indicates the number of threads that have initialized * notifiers. It controls the lifetime of the TclNotifier window class. * * You must hold the notifierMutex lock before accessing this variable. */ static int notifierCount = 0; TCL_DECLARE_MUTEX(notifierMutex) /* * Static routines defined in this file. */ static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); /* *---------------------------------------------------------------------- * * Tcl_InitNotifier -- * * Initializes the platform specific notifier state. |
︙ | ︙ | |||
85 86 87 88 89 90 91 | ClientData Tcl_InitNotifier() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); WNDCLASS class; /* | | | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | ClientData Tcl_InitNotifier() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); WNDCLASS class; /* * Register Notifier window class if this is the first thread to use this * module. */ Tcl_MutexLock(¬ifierMutex); if (notifierCount == 0) { class.style = 0; class.cbClsExtra = 0; class.cbWndExtra = 0; |
︙ | ︙ | |||
127 128 129 130 131 132 133 | } /* *---------------------------------------------------------------------- * * Tcl_FinalizeNotifier -- * | | | | | | | | | > | | | | < | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_FinalizeNotifier -- * * This function is called to cleanup the notifier state before a thread * is terminated. * * Results: * None. * * Side effects: * May dispose of the notifier window and class. * *---------------------------------------------------------------------- */ void Tcl_FinalizeNotifier(clientData) ClientData clientData; /* Pointer to notifier data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; /* * Only finalize the notifier if a notifier was installed in the current * thread; there is a route in which this is not guaranteed to be true * (when tclWin32Dll.c:DllMain() is called with the flag * DLL_PROCESS_DETACH by the OS, which could be doing so from a thread * that's never previously been involved with Tcl, e.g. the task manager) * so this check is important. * * Fixes Bug #217982 reported by Hugh Vu and Gene Leache. */ if (tsdPtr == NULL) { return; } DeleteCriticalSection(&tsdPtr->crit); CloseHandle(tsdPtr->event); /* * Clean up the timer and messaging window for this thread. */ if (tsdPtr->hwnd) { KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); DestroyWindow(tsdPtr->hwnd); } /* * If this is the last thread to use the notifier, unregister the notifier * window class. */ Tcl_MutexLock(¬ifierMutex); notifierCount--; if (notifierCount == 0) { UnregisterClassA("TclNotifier", TclWinGetTclInstance()); } Tcl_MutexUnlock(¬ifierMutex); } /* *---------------------------------------------------------------------- * * Tcl_AlertNotifier -- * * Wake up the specified notifier from any thread. This routine is called * by the platform independent notifier code whenever the Tcl_ThreadAlert * routine is called. This routine is guaranteed not to be called on a * given notifier after Tcl_FinalizeNotifier is called for that notifier. * This routine is typically called from a thread other than the * notifier's thread. * * Results: * None. * * Side effects: * Sends a message to the messaging window for the notifier if there * isn't already one pending. * *---------------------------------------------------------------------- */ void Tcl_AlertNotifier(clientData) ClientData clientData; /* Pointer to thread data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; /* * Note that we do not need to lock around access to the hwnd because the * race condition has no effect since any race condition implies that the * notifier thread is already awake. */ if (tsdPtr->hwnd) { /* * We do need to lock around access to the pending flag. */ |
︙ | ︙ | |||
240 241 242 243 244 245 246 | } /* *---------------------------------------------------------------------- * * Tcl_SetTimer -- * | | | | | | | | | < | 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 | } /* *---------------------------------------------------------------------- * * Tcl_SetTimer -- * * This procedure sets the current notifier timer value. The notifier * will ensure that Tcl_ServiceAll() is called after the specified * interval, even if no events have occurred. * * Results: * None. * * Side effects: * Replaces any previous timer. * *---------------------------------------------------------------------- */ void Tcl_SetTimer( Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); UINT timeout; /* * Allow the notifier to be hooked. This may not make sense on Windows, * but mirrors the UNIX hook. */ if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) { tclStubs.tcl_SetTimer(timePtr); return; } /* * We only need to set up an interval timer if we're being called from an * external event loop. If we don't have a window handle then we just * return immediately and let Tcl_WaitForEvent handle timeouts. */ if (!tsdPtr->hwnd) { return; } if (!timePtr) { |
︙ | ︙ | |||
297 298 299 300 301 302 303 | if (timeout == 0) { timeout = 1; } } tsdPtr->timeout = timeout; if (timeout != 0) { tsdPtr->timerActive = 1; | | | | | | | | | < | | > | | | | | < | | | | | | | | | | | | < | | > > > > > > > | > > > > > > > | | | | 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 | if (timeout == 0) { timeout = 1; } } tsdPtr->timeout = timeout; if (timeout != 0) { tsdPtr->timerActive = 1; SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, (unsigned long) tsdPtr->timeout, NULL); } else { tsdPtr->timerActive = 0; KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); } } /* *---------------------------------------------------------------------- * * Tcl_ServiceModeHook -- * * This function is invoked whenever the service mode changes. * * Results: * None. * * Side effects: * If this is the first time the notifier is set into TCL_SERVICE_ALL, * then the communication window is created. * *---------------------------------------------------------------------- */ void Tcl_ServiceModeHook(mode) int mode; /* Either TCL_SERVICE_ALL, or * TCL_SERVICE_NONE. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * If this is the first time that the notifier has been used from a modal * loop, then create a communication window. Note that after this point, * the application needs to service events in a timely fashion or Windows * will hang waiting for the window to respond to synchronous system * messages. At some point, we may want to consider destroying the window * if we leave the modal loop, but for now we'll leave it around. */ if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { tsdPtr->hwnd = CreateWindowA("TclNotifier", "TclNotifier", WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL); /* * Send an initial message to the window to ensure that we wake up the * notifier once we get into the modal loop. This will force the * notifier to recompute the timeout value and schedule a timer if one * is needed. */ Tcl_AlertNotifier((ClientData)tsdPtr); } } /* *---------------------------------------------------------------------- * * NotifierProc -- * * This procedure is invoked by Windows to process events on the notifier * window. Messages will be sent to this window in response to external * timer events or calls to TclpAlertTsdPtr-> * * Results: * A standard windows result. * * Side effects: * Services any pending events. * *---------------------------------------------------------------------- */ static LRESULT CALLBACK NotifierProc( HWND hwnd, /* Passed on... */ UINT message, /* What messsage is this? */ WPARAM wParam, /* Passed on... */ LPARAM lParam) /* Passed on... */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (message == WM_WAKEUP) { EnterCriticalSection(&tsdPtr->crit); tsdPtr->pending = 0; LeaveCriticalSection(&tsdPtr->crit); } else if (message != WM_TIMER) { return DefWindowProc(hwnd, message, wParam, lParam); } /* * Process all of the runnable events. */ Tcl_ServiceAll(); return 0; } /* *---------------------------------------------------------------------- * * Tcl_WaitForEvent -- * * This function is called by Tcl_DoOneEvent to wait for new events on * the message queue. If the block time is 0, then Tcl_WaitForEvent just * polls the event queue without blocking. * * Results: * Returns -1 if a WM_QUIT message is detected, returns 1 if a message * was dispatched, otherwise returns 0. * * Side effects: * Dispatches a message to a window procedure, which could do anything. * *---------------------------------------------------------------------- */ int Tcl_WaitForEvent( Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); MSG msg; DWORD timeout, result; int status; /* * Allow the notifier to be hooked. This may not make sense on windows, * but mirrors the UNIX hook. */ if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) { return tclStubs.tcl_WaitForEvent(timePtr); } /* * Compute the timeout in milliseconds. */ if (timePtr) { /* * TIP #233 (Virtualized Time). Convert virtual domain delay to * real-time. */ Tcl_Time myTime; myTime.sec = timePtr->sec; myTime.usec = timePtr->usec; if (myTime.sec != 0 || myTime.usec != 0) { (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData); } timeout = myTime.sec * 1000 + myTime.usec / 1000; } else { timeout = INFINITE; } /* * Check to see if there are any messages in the queue before waiting * because MsgWaitForMultipleObjects will not wake up if there are events * currently sitting in the queue. */ if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { /* * Wait for something to happen (a signal from another thread, a * message, or timeout) or loop servicing asynchronous procedure calls * queued to this thread. */ again: result = MsgWaitForMultipleObjectsEx(1, &tsdPtr->event, timeout, QS_ALLINPUT, MWMO_ALERTABLE); if (result == WAIT_IO_COMPLETION) { goto again; } else if (result == WAIT_FAILED) { status = -1; goto end; |
︙ | ︙ | |||
489 490 491 492 493 494 495 | * propagate the quit message and start unwinding. */ PostQuitMessage((int) msg.wParam); status = -1; } else if (result == -1) { /* | | | | 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 | * propagate the quit message and start unwinding. */ PostQuitMessage((int) msg.wParam); status = -1; } else if (result == -1) { /* * We got an error from the system. I have no idea why this would * happen, so we'll just unwind. */ status = -1; } else { TranslateMessage(&msg); DispatchMessage(&msg); status = 1; } } else { status = 0; } end: ResetEvent(tsdPtr->event); return status; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
529 530 531 532 533 534 535 | */ void Tcl_Sleep(ms) int ms; /* Number of milliseconds to sleep. */ { /* | | | | | < | | > | | > > | > > > | | | | | > > > > > > > | | | | < | | > | | > > | > > > > > > > > | 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 | */ void Tcl_Sleep(ms) int ms; /* Number of milliseconds to sleep. */ { /* * Simply calling 'Sleep' for the requisite number of milliseconds can * make the process appear to wake up early because it isn't synchronized * with the CPU performance counter that is used in tclWinTime.c. This * behavior is probably benign, but messes up some of the corner cases in * the test suite. We get around this problem by repeating the 'Sleep' * call as many times as necessary to make the clock advance by the * requisite amount. */ Tcl_Time now; /* Current wall clock time. */ Tcl_Time desired; /* Desired wakeup time. */ Tcl_Time vdelay; /* Time to sleep, for scaling virtual -> * real. */ DWORD sleepTime; /* Time to sleep, real-time */ vdelay.sec = ms / 1000; vdelay.usec = (ms % 1000) * 1000; Tcl_GetTime(&now); desired.sec = now.sec + vdelay.sec; desired.usec = now.usec + vdelay.usec; if (desired.usec > 1000000) { ++desired.sec; desired.usec -= 1000000; } /* * TIP #233: Scale delay from virtual to real-time. */ (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData); sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; for (;;) { Sleep(sleepTime); Tcl_GetTime(&now); if (now.sec > desired.sec) { break; } else if ((now.sec == desired.sec) && (now.usec >= desired.usec)) { break; } vdelay.sec = desired.sec - now.sec; vdelay.usec = desired.usec - now.usec; (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData); sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinPipe.c.
|
| | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | /* * 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.53.2.3 2005/08/02 18:17:18 dgp Exp $ */ #include "tclWinInt.h" #include <fcntl.h> #include <io.h> #include <sys/stat.h> /* * The following variable is used to tell whether this module has been * initialized. */ static int initialized = 0; /* * The pipeMutex locks around access to the initialized and procList * variables, and it is used to protect background threads from being * terminated while they are using APIs that hold locks. */ TCL_DECLARE_MUTEX(pipeMutex) /* * The following defines identify the various types of applications that run * under windows. There is special case code for the various types. */ #define APPL_NONE 0 #define APPL_DOS 1 #define APPL_WIN3X 2 #define APPL_WIN32 3 /* * The following constants and structures are used to encapsulate the state of * various types of files used in a pipeline. This used to have a 1 && 2 that * supported Win32s. */ #define WIN_FILE 3 /* Basic Win32 file. */ /* * This structure encapsulates the common state associated with all file types * used in a pipeline. */ typedef struct WinFile { int type; /* One of the file types defined above. */ HANDLE handle; /* Open file handle. */ } WinFile; |
︙ | ︙ | |||
108 109 110 111 112 113 114 | Tcl_Pid *pidPtr; /* Pids of attached processes. */ Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer * threads. */ HANDLE writeThread; /* Handle to writer thread. */ HANDLE readThread; /* Handle to reader thread. */ HANDLE writable; /* Manual-reset event to signal when the | | | | | | | | | | | < | | < | | | | | | | | | | | | | | | < > > | | | > > | 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 | Tcl_Pid *pidPtr; /* Pids of attached processes. */ Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer * threads. */ HANDLE writeThread; /* Handle to writer thread. */ HANDLE readThread; /* Handle to reader thread. */ HANDLE writable; /* Manual-reset event to signal when the * writer thread has finished waiting for the * current buffer to be written. */ HANDLE readable; /* Manual-reset event to signal when the * reader thread has finished waiting for * input. */ HANDLE startWriter; /* Auto-reset event used by the main thread to * signal when the writer thread should * attempt to write to the pipe. */ HANDLE stopWriter; /* Manual-reset event used to alert the reader * thread to fall-out and exit */ HANDLE startReader; /* Auto-reset event used by the main thread to * signal when the reader thread should * attempt to read from the pipe. */ HANDLE stopReader; /* Manual-reset event used to alert the reader * thread to fall-out and exit */ DWORD writeError; /* An error caused by the last background * write. Set to 0 if no error has been * detected. This word is shared with the * writer thread so access must be * synchronized with the writable object. */ char *writeBuf; /* Current background output buffer. Access is * synchronized with the writable object. */ int writeBufLen; /* Size of write buffer. Access is * synchronized with the writable object. */ int toWrite; /* Current amount to be written. Access is * synchronized with the writable object. */ int readFlags; /* Flags that are shared with the reader * thread. Access is synchronized with the * readable object. */ char extraByte; /* Buffer for extra character consumed by * reader thread. This byte is shared with the * reader thread so access must be * synchronized with the readable object. */ } PipeInfo; typedef struct ThreadSpecificData { /* * The following pointer refers to the head of the list of pipes that are * being watched for file events. */ PipeInfo *firstPipePtr; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * The following structure is what is added to the Tcl event queue when pipe * events are generated. */ typedef struct PipeEvent { Tcl_Event header; /* Information that is standard for all * events. */ PipeInfo *infoPtr; /* Pointer to pipe info structure. Note that * we still have to verify that the pipe * exists before dereferencing this * pointer. */ } PipeEvent; /* * Declarations for functions used only in this file. */ static int ApplicationType(Tcl_Interp *interp, const char *fileName, char *fullName); static void BuildCommandLine(const char *executable, int argc, CONST char **argv, Tcl_DString *linePtr); static BOOL HasConsole(void); static int PipeBlockModeProc(ClientData instanceData, int mode); static void PipeCheckProc(ClientData clientData, int flags); static int PipeClose2Proc(ClientData instanceData, Tcl_Interp *interp, int flags); static int PipeEventProc(Tcl_Event *evPtr, int flags); static void PipeExitHandler(ClientData clientData); static int PipeGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static void PipeInit(void); static int PipeInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int PipeOutputProc(ClientData instanceData, CONST char *buf, int toWrite, int *errorCode); static DWORD WINAPI PipeReaderThread(LPVOID arg); static void PipeSetupProc(ClientData clientData, int flags); static void PipeWatchProc(ClientData instanceData, int mask); static DWORD WINAPI PipeWriterThread(LPVOID arg); static int TempFileName(WCHAR name[MAX_PATH]); static int WaitForRead(PipeInfo *infoPtr, int blocking); static void PipeThreadActionProc(ClientData instanceData, int action); /* * This structure describes the channel type structure for command pipe based * I/O. */ static Tcl_ChannelType pipeChannelType = { "pipe", /* Type name. */ TCL_CHANNEL_VERSION_4, /* v4 channel */ TCL_CLOSE2PROC, /* Close proc. */ PipeInputProc, /* Input proc. */ PipeOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ PipeWatchProc, /* Set up notifier to watch the channel. */ PipeGetHandleProc, /* Get an OS handle from channel. */ PipeClose2Proc, /* close2proc */ PipeBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc */ PipeThreadActionProc, /* thread action proc */ }; /* *---------------------------------------------------------------------- * * PipeInit -- * |
︙ | ︙ | |||
245 246 247 248 249 250 251 | static void PipeInit() { ThreadSpecificData *tsdPtr; /* | | | < | | | | | | | < | | | 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 | static void PipeInit() { ThreadSpecificData *tsdPtr; /* * Check the initialized flag first, then check again in the mutex. This * is a speed enhancement. */ if (!initialized) { Tcl_MutexLock(&pipeMutex); if (!initialized) { initialized = 1; procList = NULL; } Tcl_MutexUnlock(&pipeMutex); } tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->firstPipePtr = NULL; Tcl_CreateEventSource(PipeSetupProc, PipeCheckProc, NULL); Tcl_CreateThreadExitHandler(PipeExitHandler, NULL); } } /* *---------------------------------------------------------------------- * * PipeExitHandler -- * * This function is called to cleanup the pipe module before Tcl is * unloaded. * * Results: * None. * * Side effects: * Removes the pipe event source. * *---------------------------------------------------------------------- */ static void PipeExitHandler( ClientData clientData) /* Old window proc */ { Tcl_DeleteEventSource(PipeSetupProc, PipeCheckProc, NULL); } /* *---------------------------------------------------------------------- * * TclpFinalizePipes -- * * This function is called to cleanup the process list before Tcl is * unloaded. * * Results: * None. * * Side effects: * Resets the process list. * *---------------------------------------------------------------------- */ void TclpFinalizePipes() { Tcl_MutexLock(&pipeMutex); initialized = 0; Tcl_MutexUnlock(&pipeMutex); } /* *---------------------------------------------------------------------- * * PipeSetupProc -- * * This function is invoked before Tcl_DoOneEvent blocks waiting for an * event. * * Results: * None. * * Side effects: * Adjusts the block time if needed. * |
︙ | ︙ | |||
349 350 351 352 353 354 355 | int block = 1; WinFile *filePtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } | | | | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 | int block = 1; WinFile *filePtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } /* * Look to see if any events are already pending. If they are, poll. */ for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->watchMask & TCL_WRITABLE) { filePtr = (WinFile*) infoPtr->writeFile; if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { block = 0; } } |
︙ | ︙ | |||
379 380 381 382 383 384 385 | } /* *---------------------------------------------------------------------- * * PipeCheckProc -- * | | | | 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 | } /* *---------------------------------------------------------------------- * * PipeCheckProc -- * * This function is called by Tcl_DoOneEvent to check the pipe event * source for events. * * Results: * None. * * Side effects: * May queue an event. * |
︙ | ︙ | |||
405 406 407 408 409 410 411 | WinFile *filePtr; int needEvent; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } | | | < | | | | 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 | WinFile *filePtr; int needEvent; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } /* * Queue events for any ready pipes that don't already have events queued. */ for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->flags & PIPE_PENDING) { continue; } /* * Queue an event if the pipe is signaled for reading or writing. */ needEvent = 0; filePtr = (WinFile*) infoPtr->writeFile; if ((infoPtr->watchMask & TCL_WRITABLE) && (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) { needEvent = 1; } filePtr = (WinFile*) infoPtr->readFile; if ((infoPtr->watchMask & TCL_READABLE) && (WaitForRead(infoPtr, 0) >= 0)) { needEvent = 1; } if (needEvent) { |
︙ | ︙ | |||
449 450 451 452 453 454 455 | } /* *---------------------------------------------------------------------- * * TclWinMakeFile -- * | | | | 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 | } /* *---------------------------------------------------------------------- * * TclWinMakeFile -- * * This function constructs a new TclFile from a given data and type * value. * * Results: * Returns a newly allocated WinFile as a TclFile. * * Side effects: * None. * |
︙ | ︙ | |||
479 480 481 482 483 484 485 | } /* *---------------------------------------------------------------------- * * TempFileName -- * | | | | < | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TempFileName -- * * Gets a temporary file name and deals with the fact that the temporary * file path provided by Windows may not actually exist if the TMP or * TEMP environment variables refer to a non-existent directory. * * Results: * 0 if error, non-zero otherwise. If non-zero is returned, the name * buffer will be filled with a name that can be used to construct a * temporary file. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TempFileName(name) WCHAR name[MAX_PATH]; /* Buffer in which name for temporary file * gets stored. */ { TCHAR *prefix; prefix = (tclWinProcs->useWide) ? (TCHAR *) L"TCL" : (TCHAR *) "TCL"; if ((*tclWinProcs->getTempPathProc)(MAX_PATH, name) != 0) { if ((*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0, name) != 0) { return 1; } } if (tclWinProcs->useWide) { ((WCHAR *) name)[0] = '.'; ((WCHAR *) name)[1] = '\0'; } else { ((char *) name)[0] = '.'; ((char *) name)[1] = '\0'; } return (*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0, name); } /* *---------------------------------------------------------------------- * * TclpMakeFile -- |
︙ | ︙ | |||
543 544 545 546 547 548 549 | TclFile TclpMakeFile(channel, direction) Tcl_Channel channel; /* Channel to get file from. */ int direction; /* Either TCL_READABLE or TCL_WRITABLE. */ { HANDLE handle; | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | TclFile TclpMakeFile(channel, direction) Tcl_Channel channel; /* Channel to get file from. */ int direction; /* Either TCL_READABLE or TCL_WRITABLE. */ { HANDLE handle; if (Tcl_GetChannelHandle(channel, direction, (ClientData *) &handle) == TCL_OK) { return TclWinMakeFile(handle); } else { return (TclFile) NULL; } } /* *---------------------------------------------------------------------- * * TclpOpenFile -- * * This function opens files for use in a pipeline. * * Results: * Returns a newly allocated TclFile structure containing the file * handle. * * Side effects: * None. * *---------------------------------------------------------------------- */ TclFile TclpOpenFile(path, mode) CONST char *path; /* The name of the file to open. */ int mode; /* In what mode to open the file? */ { HANDLE handle; DWORD accessMode, createMode, shareMode, flags; Tcl_DString ds; CONST TCHAR *nativePath; /* * Map the access bits to the NT access mode. */ switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { case O_RDONLY: accessMode = GENERIC_READ; break; case O_WRONLY: accessMode = GENERIC_WRITE; break; case O_RDWR: accessMode = (GENERIC_READ | GENERIC_WRITE); break; default: TclWinConvertError(ERROR_INVALID_FUNCTION); return NULL; } /* * Map the creation flags to the NT create mode. */ switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) { case (O_CREAT | O_EXCL): case (O_CREAT | O_EXCL | O_TRUNC): createMode = CREATE_NEW; break; case (O_CREAT | O_TRUNC): createMode = CREATE_ALWAYS; break; case O_CREAT: createMode = OPEN_ALWAYS; break; case O_TRUNC: case (O_TRUNC | O_EXCL): createMode = TRUNCATE_EXISTING; break; default: createMode = OPEN_EXISTING; break; } nativePath = Tcl_WinUtfToTChar(path, -1, &ds); /* * If the file is not being created, use the existing file attributes. */ |
︙ | ︙ | |||
645 646 647 648 649 650 651 | shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE; /* * Now we get to create the file. */ | | | | | | | | | | 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 | shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE; /* * Now we get to create the file. */ handle = (*tclWinProcs->createFileProc)(nativePath, accessMode, shareMode, NULL, createMode, flags, NULL); Tcl_DStringFree(&ds); if (handle == INVALID_HANDLE_VALUE) { DWORD err; err = GetLastError(); if ((err & 0xffffL) == ERROR_OPEN_FAILED) { err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; } TclWinConvertError(err); return NULL; } /* * Seek to the end of file if we are writing. */ if (mode & (O_WRONLY|O_APPEND)) { SetFilePointer(handle, 0, NULL, FILE_END); } return TclWinMakeFile(handle); } /* *---------------------------------------------------------------------- * * TclpCreateTempFile -- * * This function opens a unique file with the property that it will be * deleted when its file handle is closed. The temporary file is created * in the system temporary directory. * * Results: * Returns a valid TclFile, or NULL on failure. * * Side effects: * Creates a new temporary file. * |
︙ | ︙ | |||
702 703 704 705 706 707 708 | Tcl_DString dstring; HANDLE handle; if (TempFileName(name) == 0) { return NULL; } | | | > | | 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 | Tcl_DString dstring; HANDLE handle; if (TempFileName(name) == 0) { return NULL; } handle = (*tclWinProcs->createFileProc)((TCHAR *) name, GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL); if (handle == INVALID_HANDLE_VALUE) { goto error; } /* * Write the file out, doing line translations on the way. */ if (contents != NULL) { DWORD result, length; CONST char *p; /* * Convert the contents from UTF to native encoding */ native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring); for (p = native; *p != '\0'; p++) { if (*p == '\n') { length = p - native; if (length > 0) { if (!WriteFile(handle, native, length, &result, NULL)) { goto error; } |
︙ | ︙ | |||
751 752 753 754 755 756 757 | goto error; } } return TclWinMakeFile(handle); error: | > | > > | 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 | goto error; } } return TclWinMakeFile(handle); error: /* * Free the native representation of the contents if necessary. */ if (contents != NULL) { Tcl_DStringFree(&dstring); } TclWinConvertError(GetLastError()); CloseHandle(handle); (*tclWinProcs->deleteFileProc)((TCHAR *) name); |
︙ | ︙ | |||
778 779 780 781 782 783 784 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Obj* TclpTempFileName() { WCHAR fileName[MAX_PATH]; if (TempFileName(fileName) == 0) { return NULL; } return TclpNativeToNormalized((ClientData) fileName); } /* *---------------------------------------------------------------------- * * TclpCreatePipe -- * * Creates an anonymous pipe. * * Results: * Returns 1 on success, 0 on failure. * * Side effects: * Creates a pipe. * *---------------------------------------------------------------------- */ int TclpCreatePipe( TclFile *readPipe, /* Location to store file handle for read side * of pipe. */ TclFile *writePipe) /* Location to store file handle for write * side of pipe. */ { HANDLE readHandle, writeHandle; if (CreatePipe(&readHandle, &writeHandle, NULL, 0) != 0) { *readPipe = TclWinMakeFile(readHandle); *writePipe = TclWinMakeFile(writeHandle); return 1; } TclWinConvertError(GetLastError()); return 0; } /* *---------------------------------------------------------------------- * * TclpCloseFile -- * * Closes a pipeline file handle. These handles are created by * TclpOpenFile, TclpCreatePipe, or TclpMakeFile. * * Results: * 0 on success, -1 on failure. * * Side effects: * The file is closed and deallocated. * *---------------------------------------------------------------------- */ int TclpCloseFile( TclFile file) /* The file to close. */ { WinFile *filePtr = (WinFile *) file; switch (filePtr->type) { case WIN_FILE: /* * Don't close the Win32 handle if the handle is a standard channel * during the thread exit process. Otherwise, one thread may kill the * stdio of another. */ if (!TclInThreadExit() || ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle) && (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle) && (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) { if (filePtr->handle != NULL && CloseHandle(filePtr->handle) == FALSE) { TclWinConvertError(GetLastError()); ckfree((char *) filePtr); return -1; } } break; default: Tcl_Panic("TclpCloseFile: unexpected file type"); } ckfree((char *) filePtr); return 0; } /* *-------------------------------------------------------------------------- * * TclpGetPid -- * * Given a HANDLE to a child process, return the process id for that * child process. * * Results: * Returns the process id for the child process. If the pid was not known * by Tcl, either because the pid was not created by Tcl or the child * process has already been reaped, -1 is returned. * * Side effects: * None. * *-------------------------------------------------------------------------- */ |
︙ | ︙ | |||
920 921 922 923 924 925 926 | } /* *---------------------------------------------------------------------- * * TclpCreateProcess -- * | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TclpCreateProcess -- * * Create a child process that has the specified files as its standard * input, output, and error. The child process runs asynchronously under * Windows NT and Windows 9x, and runs with the same environment * variables as the creating process. * * The complete Windows search path is searched to find the specified * executable. If an executable by the given name is not found, * automatically tries appending ".com", ".exe", and ".bat" to the * executable name. * * Results: * The return value is TCL_ERROR and an error message is left in the * interp's result if there was a problem creating the child process. * Otherwise, the return value is TCL_OK and *pidPtr is filled with the * process id of the child process. * * Side effects: * A process is created. * *---------------------------------------------------------------------- */ int TclpCreateProcess( Tcl_Interp *interp, /* Interpreter in which to leave errors that * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ int argc, /* Number of arguments in following array. */ CONST char **argv, /* Array of argument strings. argv[0] contains * the name of the executable converted to * native format (using the * Tcl_TranslateFileName call). Additional * arguments have not been converted. */ TclFile inputFile, /* If non-NULL, gives the file to use as input * for the child process. If inputFile file is * not readable or is NULL, the child will * receive no standard input. */ TclFile outputFile, /* If non-NULL, gives the file that receives * output from the child process. If * outputFile file is not writeable or is * NULL, output from the child will be * discarded. */ TclFile errorFile, /* If non-NULL, gives the file that receives * errors from the child process. If errorFile * file is not writeable or is NULL, errors * from the child will be discarded. errorFile * may be the same as outputFile. */ Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is * filled with the process id of the child * process. */ { int result, applType, createFlags; Tcl_DString cmdLine; /* Complete command line (TCHAR). */ STARTUPINFOA startInfo; PROCESS_INFORMATION procInfo; SECURITY_ATTRIBUTES secAtts; |
︙ | ︙ | |||
994 995 996 997 998 999 1000 | result = TCL_ERROR; Tcl_DStringInit(&cmdLine); hProcess = GetCurrentProcess(); /* * STARTF_USESTDHANDLES must be used to pass handles to child process. | | | | | | 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 | result = TCL_ERROR; Tcl_DStringInit(&cmdLine); hProcess = GetCurrentProcess(); /* * STARTF_USESTDHANDLES must be used to pass handles to child process. * Using SetStdHandle() and/or dup2() only works when a console mode * parent process is spawning an attached console mode child process. */ ZeroMemory(&startInfo, sizeof(startInfo)); startInfo.cb = sizeof(startInfo); startInfo.dwFlags = STARTF_USESTDHANDLES; startInfo.hStdInput = INVALID_HANDLE_VALUE; startInfo.hStdOutput= INVALID_HANDLE_VALUE; startInfo.hStdError = INVALID_HANDLE_VALUE; secAtts.nLength = sizeof(SECURITY_ATTRIBUTES); secAtts.lpSecurityDescriptor = NULL; secAtts.bInheritHandle = TRUE; /* * We have to check the type of each file, since we cannot duplicate some * file types. */ inputHandle = INVALID_HANDLE_VALUE; if (inputFile != NULL) { filePtr = (WinFile *)inputFile; if (filePtr->type == WIN_FILE) { inputHandle = filePtr->handle; |
︙ | ︙ | |||
1037 1038 1039 1040 1041 1042 1043 | filePtr = (WinFile *)errorFile; if (filePtr->type == WIN_FILE) { errorHandle = filePtr->handle; } } /* | | | | | | | | | | | | | < | | | | | | | | < | | | | | | | | | > | | | | | | | < | | < | | | | | | | | | | | | | | | | | | | | < | | | > | | > | | | | | | | | | | < | | | | | | | | < | | | | < | | > | | | | < | | | | | | | | | | | | | | | | < | | | | | | > | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | filePtr = (WinFile *)errorFile; if (filePtr->type == WIN_FILE) { errorHandle = filePtr->handle; } } /* * Duplicate all the handles which will be passed off as stdin, stdout and * stderr of the child process. The duplicate handles are set to be * inheritable, so the child process can use them. */ if (inputHandle == INVALID_HANDLE_VALUE) { /* * If handle was not set, stdin should return immediate EOF. Under * Windows95, some applications (both 16 and 32 bit!) cannot read from * the NUL device; they read from console instead. When running tk, * this is fatal because the child process would hang forever waiting * for EOF from the unmapped console window used by the helper * application. * * Fortunately, the helper application detects a closed pipe as an * immediate EOF and can pass that information to the child process. */ if (CreatePipe(&startInfo.hStdInput, &h, &secAtts, 0) != FALSE) { CloseHandle(h); } } else { DuplicateHandle(hProcess, inputHandle, hProcess, &startInfo.hStdInput, 0, TRUE, DUPLICATE_SAME_ACCESS); } if (startInfo.hStdInput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); Tcl_AppendResult(interp, "couldn't duplicate input handle: ", Tcl_PosixError(interp), (char *) NULL); goto end; } if (outputHandle == INVALID_HANDLE_VALUE) { /* * If handle was not set, output should be sent to an infinitely deep * sink. Under Windows 95, some 16 bit applications cannot have stdout * redirected to NUL; they send their output to the console instead. * Some applications, like "more" or "dir /p", when outputting * multiple pages to the console, also then try and read from the * console to go the next page. When running tk, this is fatal because * the child process would hang forever waiting for input from the * unmapped console window used by the helper application. * * Fortunately, the helper application will detect a closed pipe as a * sink. */ if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) && (applType == APPL_DOS)) { if (CreatePipe(&h, &startInfo.hStdOutput, &secAtts, 0) != FALSE) { CloseHandle(h); } } else { startInfo.hStdOutput = CreateFileA("NUL:", GENERIC_WRITE, 0, &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); } } else { DuplicateHandle(hProcess, outputHandle, hProcess, &startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS); } if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); Tcl_AppendResult(interp, "couldn't duplicate output handle: ", Tcl_PosixError(interp), (char *) NULL); goto end; } if (errorHandle == INVALID_HANDLE_VALUE) { /* * If handle was not set, errors should be sent to an infinitely deep * sink. */ startInfo.hStdError = CreateFileA("NUL:", GENERIC_WRITE, 0, &secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); } else { DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError, 0, TRUE, DUPLICATE_SAME_ACCESS); } if (startInfo.hStdError == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); Tcl_AppendResult(interp, "couldn't duplicate error handle: ", Tcl_PosixError(interp), (char *) NULL); goto end; } /* * If we do not have a console window, then we must run DOS and WIN32 * console mode applications as detached processes. This tells the loader * that the child application should not inherit the console, and that it * should not create a new console window for the child application. The * child application should get its stdio from the redirection handles * provided by this application, and run in the background. * * If we are starting a GUI process, they don't automatically get a * console, so it doesn't matter if they are started as foreground or * detached processes. The GUI window will still pop up to the foreground. */ if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { if (HasConsole()) { createFlags = 0; } else if (applType == APPL_DOS) { /* * Under NT, 16-bit DOS applications will not run unless they can * be attached to a console. If we are running without a console, * run the 16-bit program as an normal process inside of a hidden * console application, and then run that hidden console as a * detached process. */ startInfo.wShowWindow = SW_HIDE; startInfo.dwFlags |= STARTF_USESHOWWINDOW; createFlags = CREATE_NEW_CONSOLE; Tcl_DStringAppend(&cmdLine, "cmd.exe /c", -1); } else { createFlags = DETACHED_PROCESS; } } else { if (HasConsole()) { createFlags = 0; } else { createFlags = DETACHED_PROCESS; } if (applType == APPL_DOS) { /* * Under Windows 95, 16-bit DOS applications do not work well with * pipes: * * 1. EOF on a pipe between a detached 16-bit DOS application and * another application is not seen at the other end of the pipe, * so the listening process blocks forever on reads. This inablity * to detect EOF happens when either a 16-bit app or the 32-bit * app is the listener. * * 2. If a 16-bit DOS application (detached or not) blocks when * writing to a pipe, it will never wake up again, and it * eventually brings the whole system down around it. * * The 16-bit application is run as a normal process inside of a * hidden helper console app, and this helper may be run as a * detached process. If any of the stdio handles is a pipe, the * helper application accumulates information into temp files and * forwards it to or from the DOS application as appropriate. * This means that DOS apps must receive EOF from a stdin pipe * before they will actually begin, and must finish generating * stdout or stderr before the data will be sent to the next stage * of the pipe. * * The helper app should be located in the same directory as the * tcl dll. */ if (createFlags != 0) { startInfo.wShowWindow = SW_HIDE; startInfo.dwFlags |= STARTF_USESHOWWINDOW; createFlags = CREATE_NEW_CONSOLE; } { Tcl_Obj *tclExePtr, *pipeDllPtr; int i, fileExists; char *start,*end; Tcl_DString pipeDll; Tcl_DStringInit(&pipeDll); Tcl_DStringAppend(&pipeDll, TCL_PIPE_DLL, -1); tclExePtr = TclGetObjNameOfExecutable(); start = Tcl_GetStringFromObj(tclExePtr, &i); for (end = start + (i-1); end > start; end--) { if (*end == '/') { break; } } if (*end != '/') { Tcl_Panic("no / in executable path name"); } i = (end - start) + 1; pipeDllPtr = Tcl_NewStringObj(start, i); Tcl_AppendToObj(pipeDllPtr, Tcl_DStringValue(&pipeDll), -1); Tcl_IncrRefCount(pipeDllPtr); if (Tcl_FSConvertToPathType(interp, pipeDllPtr) != TCL_OK) { Tcl_Panic("Tcl_FSConvertToPathType failed"); } fileExists = (Tcl_FSAccess(pipeDllPtr, F_OK) == 0); if (!fileExists) { Tcl_Panic("Tcl pipe dll \"%s\" not found", Tcl_DStringValue(&pipeDll)); } Tcl_DStringAppend(&cmdLine, Tcl_DStringValue(&pipeDll), -1); Tcl_DecrRefCount(tclExePtr); Tcl_DecrRefCount(pipeDllPtr); Tcl_DStringFree(&pipeDll); } } } /* * cmdLine gets the full command line used to invoke the executable, * including the name of the executable itself. The command line arguments * in argv[] are stored in cmdLine separated by spaces. Special characters * in individual arguments from argv[] must be quoted when being stored in * cmdLine. * * When calling any application, bear in mind that arguments that specify * a path name are not converted. If an argument contains forward slashes * as path separators, it may or may not be recognized as a path name, * depending on the program. In general, most applications accept forward * slashes only as option delimiters and backslashes only as paths. * * Additionally, when calling a 16-bit dos or windows application, all * path names must use the short, cryptic, path format (e.g., using * ab~1.def instead of "a b.default"). */ BuildCommandLine(execPath, argc, argv, &cmdLine); if ((*tclWinProcs->createProcessProc)(NULL, (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) { TclWinConvertError(GetLastError()); Tcl_AppendResult(interp, "couldn't execute \"", argv[0], "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } /* * This wait is used to force the OS to give some time to the DOS process. */ if (applType == APPL_DOS) { WaitForSingleObject(procInfo.hProcess, 50); } /* * "When an application spawns a process repeatedly, a new thread instance * will be created for each process but the previous instances may not be * cleaned up. This results in a significant virtual memory loss each time * the process is spawned. If there is a WaitForInputIdle() call between * CreateProcess() and CloseHandle(), the problem does not occur." PSS ID * Number: Q124121 */ WaitForInputIdle(procInfo.hProcess, 5000); CloseHandle(procInfo.hThread); *pidPtr = (Tcl_Pid) procInfo.hProcess; if (*pidPtr != 0) { TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId); } result = TCL_OK; end: Tcl_DStringFree(&cmdLine); if (startInfo.hStdInput != INVALID_HANDLE_VALUE) { CloseHandle(startInfo.hStdInput); } if (startInfo.hStdOutput != INVALID_HANDLE_VALUE) { CloseHandle(startInfo.hStdOutput); } if (startInfo.hStdError != INVALID_HANDLE_VALUE) { CloseHandle(startInfo.hStdError); } return result; } /* *---------------------------------------------------------------------- * * HasConsole -- * * Determines whether the current application is attached to a console. * * Results: * Returns TRUE if this application has a console, else FALSE. * * Side effects: * None. * *---------------------------------------------------------------------- */ static BOOL HasConsole() { HANDLE handle; handle = CreateFileA("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (handle != INVALID_HANDLE_VALUE) { CloseHandle(handle); return TRUE; } else { return FALSE; } } /* *-------------------------------------------------------------------- * * ApplicationType -- * * Search for the specified program and identify if it refers to a DOS, * Windows 3.X, or Win32 program. Used to determine how to invoke a * program, or if it can even be invoked. * * It is possible to almost positively identify DOS and Windows * applications that contain the appropriate magic numbers. However, DOS * .com files do not seem to contain a magic number; if the program name * ends with .com and could not be identified as a Windows .com file, it * will be assumed to be a DOS application, even if it was just random * data. If the program name does not end with .com, no such assumption * is made. * * The Win32 function GetBinaryType incorrectly identifies any junk file * that ends with .exe as a dos executable and some executables that * don't end with .exe as not executable. Plus it doesn't exist under * win95, so I won't feel bad about reimplementing functionality. * * Results: * The return value is one of APPL_DOS, APPL_WIN3X, or APPL_WIN32 if the * filename referred to the corresponding application type. If the file * name could not be found or did not refer to any known application * type, APPL_NONE is returned and an error message is left in interp. * .bat files are identified as APPL_DOS. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ApplicationType(interp, originalName, fullName) Tcl_Interp *interp; /* Interp, for error message. */ const char *originalName; /* Name of the application to find. */ char fullName[]; /* Filled with complete path to * application. */ { int applType, i, nameLen, found; HANDLE hFile; TCHAR *rest; char *ext; char buf[2]; DWORD attr, read; IMAGE_DOS_HEADER header; Tcl_DString nameBuf, ds; CONST TCHAR *nativeName; WCHAR nativeFullPath[MAX_PATH]; static char extensions[][5] = {"", ".com", ".exe", ".bat"}; /* * Look for the program as an external program. First try the name as it * is, then try adding .com, .exe, and .bat, in that order, to the name, * looking for an executable. * * Using the raw SearchPath() function doesn't do quite what is necessary. * If the name of the executable already contains a '.' character, it will * not try appending the specified extension when searching (in other * words, SearchPath will not find the program "a.b.exe" if the arguments * specified "a.b" and ".exe"). So, first look for the file as it is * named. Then manually append the extensions, looking for a match. */ applType = APPL_NONE; Tcl_DStringInit(&nameBuf); Tcl_DStringAppend(&nameBuf, originalName, -1); nameLen = Tcl_DStringLength(&nameBuf); for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) { Tcl_DStringSetLength(&nameBuf, nameLen); Tcl_DStringAppend(&nameBuf, extensions[i], -1); nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf), Tcl_DStringLength(&nameBuf), &ds); found = (*tclWinProcs->searchPathProc)(NULL, nativeName, NULL, MAX_PATH, nativeFullPath, &rest); Tcl_DStringFree(&ds); if (found == 0) { continue; } /* * Ignore matches on directories or data files, return if identified a * known type. */ attr = (*tclWinProcs->getFileAttributesProc)((TCHAR *) nativeFullPath); if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) { continue; } strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); ext = strrchr(fullName, '.'); if ((ext != NULL) && (stricmp(ext, ".bat") == 0)) { applType = APPL_DOS; break; } hFile = (*tclWinProcs->createFileProc)((TCHAR *) nativeFullPath, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (hFile == INVALID_HANDLE_VALUE) { continue; } header.e_magic = 0; ReadFile(hFile, (void *) &header, sizeof(header), &read, NULL); if (header.e_magic != IMAGE_DOS_SIGNATURE) { /* * Doesn't have the magic number for relocatable executables. If * filename ends with .com, assume it's a DOS application anyhow. * Note that we didn't make this assumption at first, because some * supposed .com files are really 32-bit executables with all the * magic numbers and everything. */ CloseHandle(hFile); if ((ext != NULL) && (stricmp(ext, ".com") == 0)) { applType = APPL_DOS; break; } continue; } if (header.e_lfarlc != sizeof(header)) { /* * All Windows 3.X and Win32 and some DOS programs have this value * set here. If it doesn't, assume that since it already had the * other magic number it was a DOS application. */ CloseHandle(hFile); applType = APPL_DOS; break; } /* * The DWORD at header.e_lfanew points to yet another magic number. */ buf[0] = '\0'; SetFilePointer(hFile, header.e_lfanew, NULL, FILE_BEGIN); ReadFile(hFile, (void *) buf, 2, &read, NULL); CloseHandle(hFile); if ((buf[0] == 'N') && (buf[1] == 'E')) { applType = APPL_WIN3X; } else if ((buf[0] == 'P') && (buf[1] == 'E')) { applType = APPL_WIN32; } else { /* * Strictly speaking, there should be a test that there is an 'L' * and 'E' at buf[0..1], to identify the type as DOS, but of * course we ran into a DOS executable that _doesn't_ have the * magic number - specifically, one compiled using the Lahey * Fortran90 compiler. */ applType = APPL_DOS; } break; } Tcl_DStringFree(&nameBuf); if (applType == APPL_NONE) { TclWinConvertError(GetLastError()); Tcl_AppendResult(interp, "couldn't execute \"", originalName, "\": ", Tcl_PosixError(interp), (char *) NULL); return APPL_NONE; } if ((applType == APPL_DOS) || (applType == APPL_WIN3X)) { /* * Replace long path name of executable with short path name for * 16-bit applications. Otherwise the application may not be able to * correctly parse its own command line to separate off the * application name from the arguments. */ (*tclWinProcs->getShortPathNameProc)((TCHAR *) nativeFullPath, nativeFullPath, MAX_PATH); strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); } return applType; } /* *---------------------------------------------------------------------- * * BuildCommandLine -- * * The command line arguments are stored in linePtr separated by spaces, * in a form that CreateProcess() understands. Special characters in * individual arguments from argv[] must be quoted when being stored in * cmdLine. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void BuildCommandLine( CONST char *executable, /* Full path of executable (including * extension). Replacement for argv[0]. */ int argc, /* Number of arguments. */ CONST char **argv, /* Argument strings in UTF. */ Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the * command line (TCHAR). */ { CONST char *arg, *start, *special; int quote, i; Tcl_DString ds; Tcl_DStringInit(&ds); /* * Prime the path. Add a space separator if we were primed with something. */ Tcl_DStringAppend(&ds, Tcl_DStringValue(linePtr), -1); if (Tcl_DStringLength(linePtr) > 0) { Tcl_DStringAppend(&ds, " ", 1); } |
︙ | ︙ | |||
1592 1593 1594 1595 1596 1597 1598 | quote = 0; if (arg[0] == '\0') { quote = 1; } else { int count; Tcl_UniChar ch; for (start = arg; *start != '\0'; start += count) { | | | | | | | 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 | quote = 0; if (arg[0] == '\0') { quote = 1; } else { int count; Tcl_UniChar ch; for (start = arg; *start != '\0'; start += count) { count = Tcl_UtfToUniChar(start, &ch); if (Tcl_UniCharIsSpace(ch)) { /* INTL: ISO space. */ quote = 1; break; } } } if (quote) { Tcl_DStringAppend(&ds, "\"", 1); } start = arg; for (special = arg; ; ) { if ((*special == '\\') && (special[1] == '\\' || special[1] == '"' || (quote && special[1] == '\0'))) { Tcl_DStringAppend(&ds, start, (int) (special - start)); start = special; while (1) { special++; if (*special == '"' || (quote && *special == '\0')) { /* * N backslashes followed a quote -> insert N * 2 + 1 * backslashes then a quote. */ Tcl_DStringAppend(&ds, start, (int) (special - start)); break; } if (*special != '\\') { |
︙ | ︙ | |||
1652 1653 1654 1655 1656 1657 1658 | } /* *---------------------------------------------------------------------- * * TclpCreateCommandChannel -- * | | | < | 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 | } /* *---------------------------------------------------------------------- * * TclpCreateCommandChannel -- * * This function is called by Tcl_OpenCommandChannel to perform the * platform specific channel initialization for a command channel. * * Results: * Returns a new channel or NULL on failure. * * Side effects: * Allocates a new channel. * |
︙ | ︙ | |||
1692 1693 1694 1695 1696 1697 1698 1699 1700 | infoPtr->writeFile = writeFile; infoPtr->errorFile = errorFile; infoPtr->numPids = numPids; infoPtr->pidPtr = pidPtr; infoPtr->writeBuf = 0; infoPtr->writeBufLen = 0; infoPtr->writeError = 0; /* | > | < | 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 | infoPtr->writeFile = writeFile; infoPtr->errorFile = errorFile; infoPtr->numPids = numPids; infoPtr->pidPtr = pidPtr; infoPtr->writeBuf = 0; infoPtr->writeBufLen = 0; infoPtr->writeError = 0; infoPtr->channel = (Tcl_Channel) NULL; /* * Use one of the fds associated with the channel as the channel id. */ if (readFile) { channelId = (int) ((WinFile*)readFile)->handle; } else if (writeFile) { channelId = (int) ((WinFile*)writeFile)->handle; } else if (errorFile) { |
︙ | ︙ | |||
1722 1723 1724 1725 1726 1727 1728 | */ infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL); infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->stopReader = CreateEvent(NULL, TRUE, FALSE, NULL); infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread, infoPtr, 0, &id); | | | | | | | < | | | | | | | | 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 | */ infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL); infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->stopReader = CreateEvent(NULL, TRUE, FALSE, NULL); infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread, infoPtr, 0, &id); SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); infoPtr->validMask |= TCL_READABLE; } else { infoPtr->readThread = 0; } if (writeFile != NULL) { /* * Start the background writer thread. */ infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL); infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->stopWriter = CreateEvent(NULL, TRUE, FALSE, NULL); infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread, infoPtr, 0, &id); SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); infoPtr->validMask |= TCL_WRITABLE; } /* * For backward compatibility with previous versions of Tcl, we use * "file%d" as the base name for pipes even though it would be more * natural to use "pipe%d". Use the pointer to keep the channel names * unique, in case channels share handles (stdin/stdout). */ wsprintfA(channelName, "file%lx", infoPtr); infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, (ClientData) infoPtr, infoPtr->validMask); /* * Pipes have AUTO translation mode on Windows and ^Z eof char, which * means that a ^Z will be appended to them at close. This is needed for * Windows programs that expect a ^Z at EOF. */ Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel, "-translation", "auto"); Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel, "-eofchar", "\032 {}"); return infoPtr->channel; } /* *---------------------------------------------------------------------- * * TclGetAndDetachPids -- * * Stores a list of the command PIDs for a command channel in the * interp's result. * * Results: * None. * * Side effects: * Modifies the interp's result. * |
︙ | ︙ | |||
1799 1800 1801 1802 1803 1804 1805 | /* * Punt if the channel is not a command channel. */ chanTypePtr = Tcl_GetChannelType(chan); if (chanTypePtr != &pipeChannelType) { | | | | | | | | 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 | /* * Punt if the channel is not a command channel. */ chanTypePtr = Tcl_GetChannelType(chan); if (chanTypePtr != &pipeChannelType) { return; } pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); for (i = 0; i < pipePtr->numPids; i++) { wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); Tcl_AppendElement(interp, buf); Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); } if (pipePtr->numPids > 0) { ckfree((char *) pipePtr->pidPtr); pipePtr->numPids = 0; } } /* *---------------------------------------------------------------------- * * PipeBlockModeProc -- |
︙ | ︙ | |||
1834 1835 1836 1837 1838 1839 1840 | *---------------------------------------------------------------------- */ static int PipeBlockModeProc( ClientData instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or | | | | 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 | *---------------------------------------------------------------------- */ static int PipeBlockModeProc( ClientData instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; /* * Pipes on Windows can not be switched between blocking and nonblocking, * hence we have to emulate the behavior. This is done in the input * function by checking against a bit in the state. We set or unset the * bit here to cause the input function to emulate the correct behavior. */ |
︙ | ︙ | |||
1885 1886 1887 1888 1889 1890 1891 | PipeInfo *infoPtr, **nextPtrPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); DWORD exitCode; errorCode = 0; result = 0; | | < | | | | | | | | | | | | | | < | < | | 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 | PipeInfo *infoPtr, **nextPtrPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); DWORD exitCode; errorCode = 0; result = 0; if ((!flags || flags == TCL_CLOSE_READ) && (pipePtr->readFile != NULL)) { /* * Clean up the background thread if necessary. Note that this must be * done before we can close the file, since the thread may be blocking * trying to read from the pipe. */ if (pipePtr->readThread) { /* * The thread may already have closed on its own. Check its exit * code. */ GetExitCodeThread(pipePtr->readThread, &exitCode); if (exitCode == STILL_ACTIVE) { /* * Set the stop event so that if the reader thread is blocked * in PipeReaderThread on WaitForMultipleEvents, it will exit * cleanly. */ SetEvent(pipePtr->stopReader); /* * Wait at most 20 milliseconds for the reader thread to * close. */ if (WaitForSingleObject(pipePtr->readThread, 20) == WAIT_TIMEOUT) { /* * The thread must be blocked waiting for the pipe to * become readable in ReadFile(). There isn't a clean way * to exit the thread from this condition. We should * terminate the child process instead to get the reader * thread to fall out of ReadFile with a FALSE. (below) is * not the correct way to do this, but will stay here * until a better solution is found. * * Note that we need to guard against terminating the * thread while it is in the middle of Tcl_ThreadAlert * because it won't be able to release the notifier lock. */ Tcl_MutexLock(&pipeMutex); /* BUG: this leaks memory */ TerminateThread(pipePtr->readThread, 0); Tcl_MutexUnlock(&pipeMutex); |
︙ | ︙ | |||
1957 1958 1959 1960 1961 1962 1963 | pipePtr->validMask &= ~TCL_READABLE; pipePtr->readFile = NULL; } if ((!flags || flags & TCL_CLOSE_WRITE) && (pipePtr->writeFile != NULL)) { if (pipePtr->writeThread) { /* | | | | < | | | | | | | | | | | < | < | | 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 | pipePtr->validMask &= ~TCL_READABLE; pipePtr->readFile = NULL; } if ((!flags || flags & TCL_CLOSE_WRITE) && (pipePtr->writeFile != NULL)) { if (pipePtr->writeThread) { /* * Wait for the writer thread to finish the current buffer, then * terminate the thread and close the handles. If the channel is * nonblocking, there should be no pending write operations. */ WaitForSingleObject(pipePtr->writable, INFINITE); /* * The thread may already have closed on it's own. Check its exit * code. */ GetExitCodeThread(pipePtr->writeThread, &exitCode); if (exitCode == STILL_ACTIVE) { /* * Set the stop event so that if the reader thread is blocked * in PipeReaderThread on WaitForMultipleEvents, it will exit * cleanly. */ SetEvent(pipePtr->stopWriter); /* * Wait at most 20 milliseconds for the reader thread to * close. */ if (WaitForSingleObject(pipePtr->writeThread, 20) == WAIT_TIMEOUT) { /* * The thread must be blocked waiting for the pipe to * consume input in WriteFile(). There isn't a clean way * to exit the thread from this condition. We should * terminate the child process instead to get the writer * thread to fall out of WriteFile with a FALSE. (below) * is not the correct way to do this, but will stay here * until a better solution is found. * * Note that we need to guard against terminating the * thread while it is in the middle of Tcl_ThreadAlert * because it won't be able to release the notifier lock. */ Tcl_MutexLock(&pipeMutex); /* BUG: this leaks memory */ TerminateThread(pipePtr->writeThread, 0); Tcl_MutexUnlock(&pipeMutex); |
︙ | ︙ | |||
2052 2053 2054 2055 2056 2057 2058 | *nextPtrPtr = infoPtr->nextPtr; break; } } if ((pipePtr->flags & PIPE_ASYNC) || TclInExit()) { /* | | | | | > > | > > > | 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 | *nextPtrPtr = infoPtr->nextPtr; break; } } if ((pipePtr->flags & PIPE_ASYNC) || TclInExit()) { /* * If the channel is non-blocking or Tcl is being cleaned up, just * detach the children PIDs, reap them (important if we are in a * dynamic load module), and discard the errorFile. */ Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); Tcl_ReapDetachedProcs(); if (pipePtr->errorFile) { if (TclpCloseFile(pipePtr->errorFile) != 0) { if (errorCode == 0) { errorCode = errno; } } } result = 0; } else { /* * Wrap the error file into a channel and give it to the cleanup * routine. */ if (pipePtr->errorFile) { |
︙ | ︙ | |||
2105 2106 2107 2108 2109 2110 2111 | } /* *---------------------------------------------------------------------- * * PipeInputProc -- * | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * PipeInputProc -- * * Reads input from the IO channel into the buffer given. Returns count * of how many bytes were actually read, and an error indication. * * Results: * A count of how many bytes were read is returned and an error * indication is returned in an output argument. * * Side effects: * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int PipeInputProc( ClientData instanceData, /* Pipe state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ int *errorCode) /* Where to store error code. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; WinFile *filePtr = (WinFile*) infoPtr->readFile; DWORD count, bytesRead = 0; int result; *errorCode = 0; |
︙ | ︙ | |||
2149 2150 2151 2152 2153 2154 2155 | if (result == -1) { *errorCode = errno; return -1; } if (infoPtr->readFlags & PIPE_EXTRABYTE) { /* | | | | | | | 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 | if (result == -1) { *errorCode = errno; return -1; } if (infoPtr->readFlags & PIPE_EXTRABYTE) { /* * The reader thread consumed 1 byte as a side effect of waiting so we * need to move it into the buffer. */ *buf = infoPtr->extraByte; infoPtr->readFlags &= ~PIPE_EXTRABYTE; buf++; bufSize--; bytesRead = 1; /* * If further read attempts would block, return what we have. */ if (result == 0) { return bytesRead; } } /* * Attempt to read bufSize bytes. The read will return immediately if * there is any data available. Otherwise it will block until at least one * byte is available or an EOF occurs. */ if (ReadFile(filePtr->handle, (LPVOID) buf, (DWORD) bufSize, &count, (LPOVERLAPPED) NULL) == TRUE) { return bytesRead + count; } else if (bytesRead) { /* |
︙ | ︙ | |||
2199 2200 2201 2202 2203 2204 2205 | } /* *---------------------------------------------------------------------- * * PipeOutputProc -- * | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * PipeOutputProc -- * * Writes the given output on the IO channel. Returns count of how many * characters were actually written, and an error indication. * * Results: * A count of how many characters were written is returned and an error * indication is returned in an output argument. * * Side effects: * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int PipeOutputProc( ClientData instanceData, /* Pipe state. */ CONST char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; WinFile *filePtr = (WinFile*) infoPtr->writeFile; DWORD bytesWritten, timeout; *errorCode = 0; timeout = (infoPtr->flags & PIPE_ASYNC) ? 0 : INFINITE; if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) { /* * The writer thread is blocked waiting for a write to complete and * the channel is in non-blocking mode. */ errno = EAGAIN; goto error; } /* * Check for a background error on the last write. */ if (infoPtr->writeError) { TclWinConvertError(infoPtr->writeError); infoPtr->writeError = 0; goto error; } if (infoPtr->flags & PIPE_ASYNC) { /* * The pipe is non-blocking, so copy the data into the output buffer * and restart the writer thread. */ if (toWrite > infoPtr->writeBufLen) { /* * Reallocate the buffer to be large enough to hold the data. */ if (infoPtr->writeBuf) { ckfree(infoPtr->writeBuf); } infoPtr->writeBufLen = toWrite; infoPtr->writeBuf = ckalloc((unsigned int) toWrite); } memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); infoPtr->toWrite = toWrite; ResetEvent(infoPtr->writable); SetEvent(infoPtr->startWriter); bytesWritten = toWrite; } else { /* * In the blocking case, just try to write the buffer directly. This * avoids an unnecessary copy. */ if (WriteFile(filePtr->handle, (LPVOID) buf, (DWORD) toWrite, &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) { TclWinConvertError(GetLastError()); goto error; } } return bytesWritten; error: *errorCode = errno; return -1; } /* *---------------------------------------------------------------------- * * PipeEventProc -- * * This function is invoked by Tcl_ServiceEvent when a file event reaches * the front of the event queue. This function invokes Tcl_NotifyChannel * on the pipe. * * Results: * Returns 1 if the event was handled, meaning it should be removed from * the queue. Returns 0 if the event was not handled, meaning it should * stay on the queue. The only time the event isn't handled is if the * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the notifier callback does. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2326 2327 2328 2329 2330 2331 2332 | if (!(flags & TCL_FILE_EVENTS)) { return 0; } /* * Search through the list of watched pipes for the one whose handle | | | | | | | | 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 | if (!(flags & TCL_FILE_EVENTS)) { return 0; } /* * Search through the list of watched pipes for the one whose handle * matches the event. We do this rather than simply dereferencing the * handle in the event so that pipes can be deleted while the event is in * the queue. */ for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (pipeEvPtr->infoPtr == infoPtr) { infoPtr->flags &= ~(PIPE_PENDING); break; } } /* * Remove stale events. */ if (!infoPtr) { return 1; } /* * Check to see if the pipe is readable. Note that we can't tell if a pipe * is writable, so we always report it as being writable unless we have * detected EOF. */ filePtr = (WinFile*) ((PipeInfo*)infoPtr)->writeFile; mask = 0; if ((infoPtr->watchMask & TCL_WRITABLE) && (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) { mask = TCL_WRITABLE; |
︙ | ︙ | |||
2382 2383 2384 2385 2386 2387 2388 | } /* *---------------------------------------------------------------------- * * PipeWatchProc -- * | | < | | | | | | < | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * PipeWatchProc -- * * Called by the notifier to set up to watch for events on this channel. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void PipeWatchProc( ClientData instanceData, /* Pipe state. */ int mask) /* What events to watch for, OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { PipeInfo **nextPtrPtr, *ptr; PipeInfo *infoPtr = (PipeInfo *) instanceData; int oldMask = infoPtr->watchMask; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Since most of the work is handled by the background threads, we just * need to update the watchMask and then force the notifier to poll once. */ infoPtr->watchMask = mask & infoPtr->validMask; if (infoPtr->watchMask) { Tcl_Time blockTime = { 0, 0 }; if (!oldMask) { infoPtr->nextPtr = tsdPtr->firstPipePtr; tsdPtr->firstPipePtr = infoPtr; } Tcl_SetMaxBlockTime(&blockTime); } else { if (oldMask) { /* * Remove the pipe from the list of watched pipes. */ for (nextPtrPtr = &(tsdPtr->firstPipePtr), ptr = *nextPtrPtr; ptr != NULL; nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { if (infoPtr == ptr) { *nextPtrPtr = ptr->nextPtr; break; } } } } } /* *---------------------------------------------------------------------- * * PipeGetHandleProc -- * * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a * command pipeline based channel. * * Results: * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int PipeGetHandleProc( ClientData instanceData, /* The pipe state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ ClientData *handlePtr) /* Where to store the handle. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; WinFile *filePtr; if (direction == TCL_READABLE && infoPtr->readFile) { filePtr = (WinFile*) infoPtr->readFile; *handlePtr = (ClientData) filePtr->handle; return TCL_OK; } if (direction == TCL_WRITABLE && infoPtr->writeFile) { |
︙ | ︙ | |||
2486 2487 2488 2489 2490 2491 2492 | *---------------------------------------------------------------------- * * Tcl_WaitPid -- * * Emulates the waitpid system call. * * Results: | | | | | < | | 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 | *---------------------------------------------------------------------- * * Tcl_WaitPid -- * * Emulates the waitpid system call. * * Results: * Returns 0 if the process is still alive, -1 on an error, or the pid on * a clean close. * * Side effects: * Unless WNOHANG is set and the wait times out, the process information * record will be deleted and the process handle will be closed. * *---------------------------------------------------------------------- */ Tcl_Pid Tcl_WaitPid( Tcl_Pid pid, int *statPtr, int options) { ProcInfo *infoPtr = NULL, **prevPtrPtr; DWORD flags; Tcl_Pid result; DWORD ret, exitCode; PipeInit(); /* * If no pid is specified, do nothing. */ if (pid == 0) { *statPtr = 0; return 0; } /* * Find the process and cut it from the process list. |
︙ | ︙ | |||
2538 2539 2540 2541 2542 2543 2544 | } Tcl_MutexUnlock(&pipeMutex); /* * If the pid is not one of the processes we know about (we started it) * then do nothing. */ | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | 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 | } Tcl_MutexUnlock(&pipeMutex); /* * If the pid is not one of the processes we know about (we started it) * then do nothing. */ if (infoPtr == NULL) { *statPtr = 0; return 0; } /* * Officially "wait" for it to finish. We either poll (WNOHANG) or wait * for an infinite amount of time. */ if (options & WNOHANG) { flags = 0; } else { flags = INFINITE; } ret = WaitForSingleObject(infoPtr->hProcess, flags); if (ret == WAIT_TIMEOUT) { *statPtr = 0; if (options & WNOHANG) { /* * Re-insert this infoPtr back on the list. */ Tcl_MutexLock(&pipeMutex); infoPtr->nextPtr = procList; procList = infoPtr; Tcl_MutexUnlock(&pipeMutex); return 0; } else { result = 0; } } else if (ret == WAIT_OBJECT_0) { GetExitCodeProcess(infoPtr->hProcess, &exitCode); /* * Does the exit code look like one of the exception codes? */ switch (exitCode) { case EXCEPTION_FLT_DENORMAL_OPERAND: case EXCEPTION_FLT_DIVIDE_BY_ZERO: case EXCEPTION_FLT_INEXACT_RESULT: case EXCEPTION_FLT_INVALID_OPERATION: case EXCEPTION_FLT_OVERFLOW: case EXCEPTION_FLT_STACK_CHECK: case EXCEPTION_FLT_UNDERFLOW: case EXCEPTION_INT_DIVIDE_BY_ZERO: case EXCEPTION_INT_OVERFLOW: *statPtr = SIGFPE; break; case EXCEPTION_PRIV_INSTRUCTION: case EXCEPTION_ILLEGAL_INSTRUCTION: *statPtr = SIGILL; break; case EXCEPTION_ACCESS_VIOLATION: case EXCEPTION_ARRAY_BOUNDS_EXCEEDED: case EXCEPTION_STACK_OVERFLOW: case EXCEPTION_NONCONTINUABLE_EXCEPTION: case EXCEPTION_INVALID_DISPOSITION: case EXCEPTION_GUARD_PAGE: case EXCEPTION_INVALID_HANDLE: *statPtr = SIGSEGV; break; case EXCEPTION_DATATYPE_MISALIGNMENT: *statPtr = SIGBUS; break; case EXCEPTION_BREAKPOINT: case EXCEPTION_SINGLE_STEP: *statPtr = SIGTRAP; break; case CONTROL_C_EXIT: *statPtr = SIGINT; break; default: /* * Non-exceptional, normal, exit code. Note that the exit code is * truncated to a signed short range [-32768,32768) whether it * fits into this range or not. * * BUG: Even though the exit code is a DWORD, it is understood by * convention to be a signed integer, yet there isn't enough room * to fit this into the POSIX style waitstatus mask without * truncating it. */ *statPtr = (((int)(short) exitCode << 8) & 0xffff00); break; } result = pid; } else { errno = ECHILD; *statPtr = ECHILD; result = (Tcl_Pid) -1; } /* * Officially close the process handle. */ CloseHandle(infoPtr->hProcess); ckfree((char*)infoPtr); return result; } /* *---------------------------------------------------------------------- * * TclWinAddProcess -- * * Add a process to the process list so that we can use Tcl_WaitPid on * the process. * * Results: * None * * Side effects: * Adds the specified process handle to the process list so Tcl_WaitPid * knows about it. * *---------------------------------------------------------------------- */ void TclWinAddProcess(hProcess, id) HANDLE hProcess; /* Handle to process */ DWORD id; /* Global process identifier */ { ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo)); PipeInit(); procPtr->hProcess = hProcess; procPtr->dwProcessId = id; Tcl_MutexLock(&pipeMutex); procPtr->nextPtr = procList; procList = procPtr; Tcl_MutexUnlock(&pipeMutex); } /* *---------------------------------------------------------------------- * * Tcl_PidObjCmd -- * * This function is invoked to process the "pid" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * |
︙ | ︙ | |||
2723 2724 2725 2726 2727 2728 2729 | Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); return TCL_ERROR; } if (objc == 1) { wsprintfA(buf, "%lu", (unsigned long) getpid()); Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); } else { | | | | | | | | | | | < | | | | | | | | < | > | 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 | Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); return TCL_ERROR; } if (objc == 1) { wsprintfA(buf, "%lu", (unsigned long) getpid()); Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); } else { chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } chanTypePtr = Tcl_GetChannelType(chan); if (chanTypePtr != &pipeChannelType) { return TCL_OK; } pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); resultPtr = Tcl_NewObj(); for (i = 0; i < pipePtr->numPids; i++) { wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr, Tcl_NewStringObj(buf, -1)); } Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * WaitForRead -- * * Wait until some data is available, the pipe is at EOF or the reader * thread is blocked waiting for data (if the channel is in non-blocking * mode). * * Results: * Returns 1 if pipe is readable. Returns 0 if there is no data on the * pipe, but there is buffered data. Returns -1 if an error occurred. If * an error occurred, the threads may not be synchronized. * * Side effects: * Updates the shared state flags and may consume 1 byte of data from the * pipe. If no error occurred, the reader thread is blocked waiting for a * signal from the main thread. * *---------------------------------------------------------------------- */ static int WaitForRead( PipeInfo *infoPtr, /* Pipe state. */ int blocking) /* Indicates whether call should be blocking * or not. */ { DWORD timeout, count; HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle; while (1) { /* * Synchronize with the reader thread. */ timeout = blocking ? INFINITE : 0; if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) { /* * The reader thread is blocked waiting for data and the channel * is in non-blocking mode. */ errno = EAGAIN; return -1; } /* * At this point, the two threads are synchronized, so it is safe to * access shared state. */ /* * If the pipe has hit EOF, it is always readable. */ if (infoPtr->readFlags & PIPE_EOF) { return 1; } /* * Check to see if there is any data sitting in the pipe. */ if (PeekNamedPipe(handle, (LPVOID) NULL, (DWORD) 0, (LPDWORD) NULL, &count, (LPDWORD) NULL) != TRUE) { TclWinConvertError(GetLastError()); /* * Check to see if the peek failed because of EOF. */ if (errno == EPIPE) { infoPtr->readFlags |= PIPE_EOF; return 1; |
︙ | ︙ | |||
2843 2844 2845 2846 2847 2848 2849 | */ if (count > 0) { return 1; } /* | | | | < | | | | | | < | | | | | | | | | | | | | | | | | | | | > > > > > > | > | < | | < | | | | | | | | | > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | */ if (count > 0) { return 1; } /* * The pipe isn't readable, but there is some data sitting in the * buffer, so return immediately. */ if (infoPtr->readFlags & PIPE_EXTRABYTE) { return 0; } /* * There wasn't any data available, so reset the thread and try again. */ ResetEvent(infoPtr->readable); SetEvent(infoPtr->startReader); } } /* *---------------------------------------------------------------------- * * PipeReaderThread -- * * This function runs in a separate thread and waits for input to become * available on a pipe. * * Results: * None. * * Side effects: * Signals the main thread when input become available. May cause the * main thread to wake up by posting a message. May consume one byte from * the pipe for each wait operation. Will cause a memory leak of ~4k, if * forcefully terminated with TerminateThread(). * *---------------------------------------------------------------------- */ static DWORD WINAPI PipeReaderThread(LPVOID arg) { PipeInfo *infoPtr = (PipeInfo *)arg; HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle; DWORD count, err; int done = 0; HANDLE wEvents[2]; DWORD waitResult; wEvents[0] = infoPtr->stopReader; wEvents[1] = infoPtr->startReader; while (!done) { /* * Wait for the main thread to signal before attempting to wait on the * pipe becoming readable. */ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); if (waitResult != (WAIT_OBJECT_0 + 1)) { /* * The start event was not signaled. It might be the stop event or * an error, so exit. */ break; } /* * Try waiting for 0 bytes. This will block until some data is * available on NT, but will return immediately on Win 95. So, if no * data is available after the first read, we block until we can read * a single byte off of the pipe. */ if (ReadFile(handle, NULL, 0, &count, NULL) == FALSE || PeekNamedPipe(handle, NULL, 0, NULL, &count, NULL) == FALSE) { /* * The error is a result of an EOF condition, so set the EOF bit * before signalling the main thread. */ err = GetLastError(); if (err == ERROR_BROKEN_PIPE) { infoPtr->readFlags |= PIPE_EOF; done = 1; } else if (err == ERROR_INVALID_HANDLE) { break; } } else if (count == 0) { if (ReadFile(handle, &(infoPtr->extraByte), 1, &count, NULL) != FALSE) { /* * One byte was consumed as a side effect of waiting for the * pipe to become readable. */ infoPtr->readFlags |= PIPE_EXTRABYTE; } else { err = GetLastError(); if (err == ERROR_BROKEN_PIPE) { /* * The error is a result of an EOF condition, so set the * EOF bit before signalling the main thread. */ infoPtr->readFlags |= PIPE_EOF; done = 1; } else if (err == ERROR_INVALID_HANDLE) { break; } } } /* * Signal the main thread by signalling the readable event and then * waking up the notifier thread. */ SetEvent(infoPtr->readable); /* * Alert the foreground thread. Note that we need to treat this like a * critical section so the foreground thread does not terminate this * thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&pipeMutex); if (infoPtr->threadId != NULL) { /* * TIP #218. When in flight ignore the event, no one will receive * it anyway. */ Tcl_ThreadAlert(infoPtr->threadId); } Tcl_MutexUnlock(&pipeMutex); } return 0; } /* *---------------------------------------------------------------------- * * PipeWriterThread -- * * This function runs in a separate thread and writes data onto a pipe. * * Results: * Always returns 0. * * Side effects: * Signals the main thread when an output operation is completed. May * cause the main thread to wake up by posting a message. * *---------------------------------------------------------------------- */ static DWORD WINAPI PipeWriterThread(LPVOID arg) { PipeInfo *infoPtr = (PipeInfo *)arg; HANDLE *handle = ((WinFile *) infoPtr->writeFile)->handle; DWORD count, toWrite; char *buf; int done = 0; HANDLE wEvents[2]; DWORD waitResult; wEvents[0] = infoPtr->stopWriter; wEvents[1] = infoPtr->startWriter; while (!done) { /* * Wait for the main thread to signal before attempting to write. */ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); if (waitResult != (WAIT_OBJECT_0 + 1)) { /* * The start event was not signaled. It might be the stop event or * an error, so exit. */ break; } buf = infoPtr->writeBuf; toWrite = infoPtr->toWrite; /* * Loop until all of the bytes are written or an error occurs. */ while (toWrite > 0) { if (WriteFile(handle, buf, toWrite, &count, NULL) == FALSE) { infoPtr->writeError = GetLastError(); done = 1; break; } else { toWrite -= count; buf += count; } } /* * Signal the main thread by signalling the writable event and then * waking up the notifier thread. */ SetEvent(infoPtr->writable); /* * Alert the foreground thread. Note that we need to treat this like a * critical section so the foreground thread does not terminate this * thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&pipeMutex); if (infoPtr->threadId != NULL) { /* * TIP #218. When in flight ignore the event, no one will receive * it anyway. */ Tcl_ThreadAlert(infoPtr->threadId); } Tcl_MutexUnlock(&pipeMutex); } return 0; } /* *---------------------------------------------------------------------- * * PipeThreadActionProc -- * * Insert or remove any thread local refs to this channel. * * Results: * None. * * Side effects: * Changes thread local list of valid channels. * *---------------------------------------------------------------------- */ static void PipeThreadActionProc(instanceData, action) ClientData instanceData; int action; { PipeInfo *infoPtr = (PipeInfo *) instanceData; /* * We do not access firstPipePtr in the thread structures. This is not for * all pipes managed by the thread, but only those we are watching. * Removal of the filevent handlers before transfer thus takes care of * this structure. */ Tcl_MutexLock(&pipeMutex); if (action == TCL_CHANNEL_THREAD_INSERT) { /* * We can't copy the thread information from the channel when the * channel is created. At this time the channel back pointer has not * been set yet. However in that case the threadId has already been * set by TclpCreateCommandChannel itself, so the structure is still * good. */ PipeInit(); if (infoPtr->channel != NULL) { infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel); } } else { infoPtr->threadId = NULL; } Tcl_MutexUnlock(&pipeMutex); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
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.43.2.2 2005/10/08 13:45:04 dgp Exp $ */ #ifndef _TCLWINPORT #define _TCLWINPORT #ifdef CHECK_UNICODE_CALLS # define _UNICODE |
︙ | ︙ | |||
40 41 42 43 44 45 46 47 48 49 50 51 52 53 | #include <float.h> #include <io.h> #include <malloc.h> #include <process.h> #include <signal.h> #include <string.h> /* * Need to block out these includes for building extensions with MetroWerks * compiler for Win32. */ #ifndef __MWERKS__ #include <sys/stat.h> | > > > > > > > | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | #include <float.h> #include <io.h> #include <malloc.h> #include <process.h> #include <signal.h> #include <string.h> /* * These string functions are not defined with the same names on Windows. */ #define strcasecmp stricmp #define strncasecmp strnicmp /* * Need to block out these includes for building extensions with MetroWerks * compiler for Win32. */ #ifndef __MWERKS__ #include <sys/stat.h> |
︙ | ︙ | |||
434 435 436 437 438 439 440 | /* * The following define ensures that we use the native putenv * implementation to modify the environment array. This keeps * the C level environment in synch with the system level environment. */ | | > | 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 | /* * The following define ensures that we use the native putenv * implementation to modify the environment array. This keeps * the C level environment in synch with the system level environment. */ #define USE_PUTENV 1 #define USE_PUTENV_FOR_UNSET 1 /* * Msvcrt's putenv() copies the string rather than takes ownership of it. */ #if defined(_MSC_VER) || defined(__MINGW32__) # define HAVE_PUTENV_THAT_COPIES 1 |
︙ | ︙ |
Changes to win/tclWinReg.c.
1 2 3 | /* * tclWinReg.c -- * | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclWinReg.c -- * * This file contains the implementation of the "registry" Tcl built-in * command. This command is built as a dynamically loadable extension in * a separate DLL. * * Copyright (c) 1997 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinReg.c,v 1.32.2.1 2005/08/02 18:17:18 dgp Exp $ */ #include "tclInt.h" #ifdef _MSC_VER # pragma comment (lib, "advapi32.lib") #endif #include <stdlib.h> |
︙ | ︙ | |||
33 34 35 36 37 38 39 | * The following macros convert between different endian ints. */ #define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x)) #define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x))) /* | | | | | | | | < | | | | | 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 | * The following macros convert between different endian ints. */ #define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x)) #define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x))) /* * The following flag is used in OpenKeys to indicate that the specified key * should be created if it doesn't currently exist. */ #define REG_CREATE 1 /* * The following tables contain the mapping from registry root names to the * system predefined keys. */ static CONST char *rootKeyNames[] = { "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT", "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL }; static HKEY rootKeys[] = { HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA }; static CONST char REGISTRY_ASSOC_KEY[] = "registry::command"; /* * The following table maps from registry types to strings. Note that the * indices for this array are the same as the constants for the known registry * types so we don't need a separate table to hold the mapping. */ static CONST char *typeNames[] = { "none", "sz", "expand_sz", "binary", "dword", "dword_big_endian", "link", "multi_sz", "resource_list", NULL }; static DWORD lastType = REG_RESOURCE_LIST; /* * The following structures allow us to select between the Unicode and ASCII * interfaces at run time based on whether Unicode APIs are available. The * Unicode APIs are preferable because they will handle characters outside of * the current code page. */ typedef struct RegWinProcs { int useWide; LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY); LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *, DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *); LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *); LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *); LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD); LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, TCHAR *, DWORD *, FILETIME *); LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, DWORD *, BYTE *, DWORD *); |
︙ | ︙ | |||
110 111 112 113 114 115 116 | static RegWinProcs asciiProcs = { 0, (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | static RegWinProcs asciiProcs = { 0, (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *)) RegCreateKeyExA, (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA, (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA, (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA, (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA, (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, DWORD *, BYTE *, DWORD *)) RegEnumValueA, |
︙ | ︙ | |||
135 136 137 138 139 140 141 | static RegWinProcs unicodeProcs = { 1, (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | static RegWinProcs unicodeProcs = { 1, (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *)) RegCreateKeyExW, (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW, (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW, (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW, (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW, (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, DWORD *, BYTE *, DWORD *)) RegEnumValueW, |
︙ | ︙ | |||
200 201 202 203 204 205 206 | EXTERN int Registry_Unload(Tcl_Interp *interp, int flags); /* *---------------------------------------------------------------------- * * Registry_Init -- * | | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 | EXTERN int Registry_Unload(Tcl_Interp *interp, int flags); /* *---------------------------------------------------------------------- * * Registry_Init -- * * This function initializes the registry command. * * Results: * A standard Tcl result. * * Side effects: * None. * |
︙ | ︙ | |||
243 244 245 246 247 248 249 | } /* *---------------------------------------------------------------------- * * Registry_Unload -- * | | | | 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 | } /* *---------------------------------------------------------------------- * * Registry_Unload -- * * This function removes the registry command. * * Results: * A standard Tcl result. * * Side effects: * The registry command is deleted and the dll may be unloaded. * *---------------------------------------------------------------------- */ int Registry_Unload( Tcl_Interp *interp, /* Interpreter for unloading */ int flags) /* Flags passed by the unload system */ { Tcl_Command cmd; Tcl_Obj *objv[3]; /* * Unregister the registry package. There is no Tcl_PkgForget() */ objv[0] = Tcl_NewStringObj("package", -1); objv[1] = Tcl_NewStringObj("forget", -1); objv[2] = Tcl_NewStringObj("registry", -1); Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL); |
︙ | ︙ | |||
288 289 290 291 292 293 294 | } /* *---------------------------------------------------------------------- * * DeleteCmd -- * | | | | 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 | } /* *---------------------------------------------------------------------- * * DeleteCmd -- * * Cleanup the interp command token so that unloading doesn't try to * re-delete the command (which will crash). * * Results: * None. * * Side effects: * The unload command will not attempt to delete this command. * |
︙ | ︙ | |||
352 353 354 355 356 357 358 | if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | 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 | if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case BroadcastIdx: /* broadcast */ return BroadcastValue(interp, objc, objv); break; case DeleteIdx: /* delete */ if (objc == 3) { return DeleteKey(interp, objv[2]); } else if (objc == 4) { return DeleteValue(interp, objv[2], objv[3]); } errString = "keyName ?valueName?"; break; case GetIdx: /* get */ if (objc == 4) { return GetValue(interp, objv[2], objv[3]); } errString = "keyName valueName"; break; case KeysIdx: /* keys */ if (objc == 3) { return GetKeyNames(interp, objv[2], NULL); } else if (objc == 4) { return GetKeyNames(interp, objv[2], objv[3]); } errString = "keyName ?pattern?"; break; case SetIdx: /* set */ if (objc == 3) { HKEY key; /* * Create the key and then close it immediately. */ if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) != TCL_OK) { return TCL_ERROR; } RegCloseKey(key); return TCL_OK; } else if (objc == 5 || objc == 6) { Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5]; return SetValue(interp, objv[2], objv[3], objv[4], typeObj); } errString = "keyName ?valueName data ?type??"; break; case TypeIdx: /* type */ if (objc == 4) { return GetType(interp, objv[2], objv[3]); } errString = "keyName valueName"; break; case ValuesIdx: /* values */ if (objc == 3) { return GetValueNames(interp, objv[2], NULL); } else if (objc == 4) { return GetValueNames(interp, objv[2], objv[3]); } errString = "keyName ?pattern?"; break; } Tcl_WrongNumArgs(interp, 2, objv, errString); return TCL_ERROR; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
452 453 454 455 456 457 458 | * Find the parent of the key being deleted and open it. */ keyName = Tcl_GetStringFromObj(keyNameObj, &length); buffer = ckalloc((unsigned int) length + 1); strcpy(buffer, keyName); | | | | 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 | * Find the parent of the key being deleted and open it. */ keyName = Tcl_GetStringFromObj(keyNameObj, &length); buffer = ckalloc((unsigned int) length + 1); strcpy(buffer, keyName); if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName) != TCL_OK) { ckfree(buffer); return TCL_ERROR; } if (*keyName == '\0') { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad key: cannot delete root keys", -1)); |
︙ | ︙ | |||
479 480 481 482 483 484 485 | result = OpenSubKey(hostName, rootKey, keyName, KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey); if (result != ERROR_SUCCESS) { ckfree(buffer); if (result == ERROR_FILE_NOT_FOUND) { return TCL_OK; | < > | | | | < | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 | result = OpenSubKey(hostName, rootKey, keyName, KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey); if (result != ERROR_SUCCESS) { ckfree(buffer); if (result == ERROR_FILE_NOT_FOUND) { return TCL_OK; } Tcl_SetObjResult(interp, Tcl_NewStringObj( "unable to delete key: ", -1)); AppendSystemError(interp, result); return TCL_ERROR; } /* * Now we recursively delete the key and everything below it. */ nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf); |
︙ | ︙ | |||
568 569 570 571 572 573 574 | } /* *---------------------------------------------------------------------- * * GetKeyNames -- * | | | | | | | 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 | } /* *---------------------------------------------------------------------- * * GetKeyNames -- * * This function enumerates the subkeys of a given key. If the optional * pattern is supplied, then only keys that match the pattern will be * returned. * * Results: * Returns the list of subkeys in the result object of the interpreter, * or an error message on failure. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
599 600 601 602 603 604 605 | int result = TCL_OK; Tcl_DString ds; /* * Attempt to open the key for enumeration. */ | | | | | | 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 | int result = TCL_OK; Tcl_DString ds; /* * Attempt to open the key for enumeration. */ if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key) != TCL_OK) { return TCL_ERROR; } if (patternObj) { pattern = Tcl_GetString(patternObj); } else { pattern = NULL; } /* * Enumerate over the subkeys until we get an error, indicating the end of * the list. */ resultPtr = Tcl_NewObj(); for (index = 0; (*regWinProcs->regEnumKeyProc)(key, index, buffer, MAX_PATH+1) == ERROR_SUCCESS; index++) { Tcl_WinTCharToUtf((TCHAR *) buffer, -1, &ds); name = Tcl_DStringValue(&ds); |
︙ | ︙ | |||
642 643 644 645 646 647 648 | } /* *---------------------------------------------------------------------- * * GetType -- * | | | | 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 | } /* *---------------------------------------------------------------------- * * GetType -- * * This function gets the type of a given registry value and places it in * the interpreter result. * * Results: * Returns a normal Tcl result. * * Side effects: * None. * |
︙ | ︙ | |||
697 698 699 700 701 702 703 | Tcl_GetString(valueNameObj), "\" from key \"", Tcl_GetString(keyNameObj), "\": ", NULL); AppendSystemError(interp, result); return TCL_ERROR; } /* | | | | | < | 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 | Tcl_GetString(valueNameObj), "\" from key \"", Tcl_GetString(keyNameObj), "\": ", NULL); AppendSystemError(interp, result); return TCL_ERROR; } /* * Set the type into the result. Watch out for unknown types. If we don't * know about the type, just use the numeric value. */ if (type > lastType || type < 0) { Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type)); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1)); } return TCL_OK; } /* *---------------------------------------------------------------------- * * GetValue -- * * This function gets the contents of a registry value and places a list * containing the data and the type in the interpreter result. * * Results: * Returns a normal Tcl result. * * Side effects: * None. * |
︙ | ︙ | |||
744 745 746 747 748 749 750 | Tcl_DString data, buf; int nameLen; /* * Attempt to open the key for reading. */ | | < | | | | | | | > | | | | | | | | | | | | 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 | Tcl_DString data, buf; int nameLen; /* * Attempt to open the key for reading. */ if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) != TCL_OK) { return TCL_ERROR; } /* * Initialize a Dstring to maximum statically allocated size we could get * one more byte by avoiding Tcl_DStringSetLength() and just setting * length to TCL_DSTRING_STATIC_SIZE, but this should be safer if the * implementation of Dstrings changes. * * This allows short values to be read from the registy in one call. * Longer values need a second call with an expanded DString. */ Tcl_DStringInit(&data); length = TCL_DSTRING_STATIC_SIZE - 1; Tcl_DStringSetLength(&data, (int) length); valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen); nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf); result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); while (result == ERROR_MORE_DATA) { /* * The Windows docs say that in this error case, we just need to * expand our buffer and request more data. Required for * HKEY_PERFORMANCE_DATA */ length *= 2; Tcl_DStringSetLength(&data, (int) length); result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); } Tcl_DStringFree(&buf); RegCloseKey(key); if (result != ERROR_SUCCESS) { Tcl_AppendResult(interp, "unable to get value \"", Tcl_GetString(valueNameObj), "\" from key \"", Tcl_GetString(keyNameObj), "\": ", NULL); AppendSystemError(interp, result); Tcl_DStringFree(&data); return TCL_ERROR; } /* * If the data is a 32-bit quantity, store it as an integer object. If it * is a multi-string, store it as a list of strings. For null-terminated * strings, append up the to first null. Otherwise, store it as a binary * string. */ if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type, *((DWORD*) Tcl_DStringValue(&data))))); } else if (type == REG_MULTI_SZ) { char *p = Tcl_DStringValue(&data); char *end = Tcl_DStringValue(&data) + length; Tcl_Obj *resultPtr = Tcl_NewObj(); /* * Multistrings are stored as an array of null-terminated strings, * terminated by two null characters. Also do a bounds check in case * we get bogus data. */ while (p < end && ((regWinProcs->useWide) ? *((Tcl_UniChar *)p) : *p) != 0) { Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); if (regWinProcs->useWide) { while (*((Tcl_UniChar *)p)++ != 0) {} |
︙ | ︙ | |||
845 846 847 848 849 850 851 | } /* *---------------------------------------------------------------------- * * GetValueNames -- * | | | | | 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 | } /* *---------------------------------------------------------------------- * * GetValueNames -- * * This function enumerates the values of the a given key. If the * optional pattern is supplied, then only value names that match the * pattern will be returned. * * Results: * Returns the list of value names in the result object of the * interpreter, or an error message on failure. * * Side effects: * None. |
︙ | ︙ | |||
912 913 914 915 916 917 918 | pattern = Tcl_GetString(patternObj); } else { pattern = NULL; } /* * Enumerate the values under the given subkey until we get an error, | | | | > | | | | < | 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 | pattern = Tcl_GetString(patternObj); } else { pattern = NULL; } /* * Enumerate the values under the given subkey until we get an error, * indicating the end of the list. Note that we need to reset size after * each iteration because RegEnumValue smashes the old value. */ size = maxSize; while ((*regWinProcs->regEnumValueProc)(key, index, Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) { if (regWinProcs->useWide) { size *= 2; } Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, &ds); name = Tcl_DStringValue(&ds); if (!pattern || Tcl_StringMatch(name, pattern)) { result = Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); if (result != TCL_OK) { Tcl_DStringFree(&ds); break; } } Tcl_DStringFree(&ds); index++; size = maxSize; } Tcl_SetObjResult(interp, resultPtr); Tcl_DStringFree(&buffer); done: RegCloseKey(key); return result; } /* *---------------------------------------------------------------------- * * OpenKey -- * * This function opens the specified key. This function is a simple * wrapper around ParseKeyName and OpenSubKey. * * Results: * Returns the opened key in the keyPtr argument and a Tcl result code. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1005 1006 1007 1008 1009 1010 1011 | } /* *---------------------------------------------------------------------- * * OpenSubKey -- * | | | | | | 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 | } /* *---------------------------------------------------------------------- * * OpenSubKey -- * * This function opens a given subkey of a root key on the specified * host. * * Results: * Returns the opened key in the keyPtr and a Windows error code as the * return value. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1045 1046 1047 1048 1049 1050 1051 | Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS) { return result; } } /* | | | < | | | < | | | | | | | < | < | | < | < | 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 | Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS) { return result; } } /* * Now open the specified key with the requested permissions. Note that * this key must be closed by the caller. */ keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); if (flags & REG_CREATE) { DWORD create; result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, NULL, REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); } else if (rootKey == HKEY_PERFORMANCE_DATA) { /* * Here we fudge it for this special root key. See MSDN for more info * on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it. */ *keyPtr = HKEY_PERFORMANCE_DATA; result = ERROR_SUCCESS; } else { result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, mode, keyPtr); } Tcl_DStringFree(&buf); /* * Be sure to close the root key since we are done with it now. */ if (hostName) { RegCloseKey(rootKey); } return result; } /* *---------------------------------------------------------------------- * * ParseKeyName -- * * This function parses a key name into the host, root, and subkey parts. * * Results: * The pointers to the start of the host and subkey names are returned in * the hostNamePtr and keyNamePtr variables. The specified root HKEY is * returned in rootKeyPtr. Returns a standard Tcl result. * * Side effects: * Modifies the name string by inserting nulls. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1169 1170 1171 1172 1173 1174 1175 | } /* *---------------------------------------------------------------------- * * RecursiveDeleteKey -- * | | | | | 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 | } /* *---------------------------------------------------------------------- * * RecursiveDeleteKey -- * * This function recursively deletes all the keys below a starting key. * Although Windows 95 does this automatically, we still need to do this * for Windows NT. * * Results: * Returns a Windows error code. * * Side effects: * Deletes all of the keys and values below the given key. * |
︙ | ︙ | |||
1241 1242 1243 1244 1245 1246 1247 | } /* *---------------------------------------------------------------------- * * SetValue -- * | | | | | 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 | } /* *---------------------------------------------------------------------- * * SetValue -- * * This function sets the contents of a registry value. If the key or * value does not exist, it will be created. If it does exist, then the * data and type will be replaced. * * Results: * Returns a normal Tcl result. * * Side effects: * May create new keys or values. * |
︙ | ︙ | |||
1307 1308 1309 1310 1311 1312 1313 | if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) { RegCloseKey(key); Tcl_DStringFree(&nameBuf); return TCL_ERROR; } /* | | | | | | | 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 | if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) { RegCloseKey(key); Tcl_DStringFree(&nameBuf); return TCL_ERROR; } /* * Append the elements as null terminated strings. Note that we must * not assume the length of the string in case there are embedded * nulls, which aren't allowed in REG_MULTI_SZ values. */ Tcl_DStringInit(&data); for (i = 0; i < objc; i++) { Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1); /* * Add a null character to separate this value from the next. We * accomplish this by growing the string by one byte. Since the * DString always tacks on an extra null byte, the new byte will * already be set to null. */ Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1); } |
︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 | * Store binary data in the registry. */ data = Tcl_GetByteArrayFromObj(dataObj, &length); result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, (BYTE *)data, (DWORD) length); } Tcl_DStringFree(&nameBuf); RegCloseKey(key); if (result != ERROR_SUCCESS) { | > > > | | | < | 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 | * Store binary data in the registry. */ data = Tcl_GetByteArrayFromObj(dataObj, &length); result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, (BYTE *)data, (DWORD) length); } Tcl_DStringFree(&nameBuf); RegCloseKey(key); if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_NewStringObj("unable to set value: ", -1)); AppendSystemError(interp, result); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * BroadcastValue -- * * This function broadcasts a WM_SETTINGCHANGE message to indicate to * other programs that we have changed the contents of a registry value. * * Results: * Returns a normal Tcl result. * * Side effects: * Will cause other programs to reload their system settings. * |
︙ | ︙ | |||
1409 1410 1411 1412 1413 1414 1415 | if ((objc != 3) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); return TCL_ERROR; } if (objc > 3) { str = Tcl_GetStringFromObj(objv[3], &len); | | > > | | | 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 | if ((objc != 3) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); return TCL_ERROR; } if (objc > 3) { str = Tcl_GetStringFromObj(objv[3], &len); if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", (size_t) len)) { Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) { return TCL_ERROR; } } str = Tcl_GetStringFromObj(objv[2], &len); if (len == 0) { str = NULL; } /* * Use the ignore the result. */ result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult); objPtr = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result)); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) sendResult)); Tcl_SetObjResult(interp, objPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * AppendSystemError -- * * This routine formats a Windows system error message and places it into * the interpreter result. * * Results: * None. * * Side effects: * None. * |
︙ | ︙ | |||
1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 | msg = Tcl_DStringValue(&ds); length = Tcl_DStringLength(&ds); /* * Trim the trailing CR/LF from the system message. */ if (msg[length-1] == '\n') { msg[--length] = 0; } if (msg[length-1] == '\r') { msg[--length] = 0; } } | > | 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 | msg = Tcl_DStringValue(&ds); length = Tcl_DStringLength(&ds); /* * Trim the trailing CR/LF from the system message. */ if (msg[length-1] == '\n') { msg[--length] = 0; } if (msg[length-1] == '\r') { msg[--length] = 0; } } |
︙ | ︙ | |||
1531 1532 1533 1534 1535 1536 1537 | } /* *---------------------------------------------------------------------- * * ConvertDWORD -- * | | | | 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 | } /* *---------------------------------------------------------------------- * * ConvertDWORD -- * * This function determines whether a DWORD needs to be byte swapped, and * returns the appropriately swapped value. * * Results: * Returns a converted DWORD. * * Side effects: * None. * |
︙ | ︙ | |||
1558 1559 1560 1561 1562 1563 1564 | /* * Check to see if the low bit is in the first byte. */ localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN; return (type != localType) ? SWAPLONG(value) : value; } | > > > > > > > > | 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 | /* * Check to see if the low bit is in the first byte. */ localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN; return (type != localType) ? SWAPLONG(value) : value; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinSerial.c.
1 2 3 | /* * tclWinSerial.c -- * | | | | | | | 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 [email protected] * * RCS: @(#) $Id: tclWinSerial.c,v 1.28.2.3 2005/10/08 13:45:04 dgp Exp $ */ #include "tclWinInt.h" #include <fcntl.h> #include <io.h> #include <sys/stat.h> |
︙ | ︙ | |||
35 36 37 38 39 40 41 | TCL_DECLARE_MUTEX(serialMutex) /* * Bit masks used in the flags field of the SerialInfo structure below. */ | | | | | | | | | > | | | | | | | | | | | | | | | < | | < | | < | | | | | | | | | | | | | 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 | TCL_DECLARE_MUTEX(serialMutex) /* * Bit masks used in the flags field of the SerialInfo structure below. */ #define SERIAL_PENDING (1<<0) /* Message is pending in the queue. */ #define SERIAL_ASYNC (1<<1) /* Channel is non-blocking. */ /* * Bit masks used in the sharedFlags field of the SerialInfo structure below. */ #define SERIAL_EOF (1<<2) /* Serial has reached EOF. */ #define SERIAL_ERROR (1<<4) /* * Default time to block between checking status on the serial port. */ #define SERIAL_DEFAULT_BLOCKTIME 10 /* 10 msec */ /* * Define Win32 read/write error masks returned by ClearCommError() */ #define SERIAL_READ_ERRORS \ (CE_RXOVER | CE_OVERRUN | CE_RXPARITY | CE_FRAME | CE_BREAK) #define SERIAL_WRITE_ERRORS \ (CE_TXFULL | CE_PTO) /* * This structure describes per-instance data for a serial based channel. */ typedef struct SerialInfo { HANDLE handle; struct SerialInfo *nextPtr; /* Pointer to next registered serial. */ Tcl_Channel channel; /* Pointer to channel structure. */ int validMask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which operations are valid on the file. */ int watchMask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which events should be reported. */ int flags; /* State flags, see above for a list. */ int readable; /* Flag that the channel is readable. */ int writable; /* Flag that the channel is writable. */ int blockTime; /* Maximum blocktime in msec. */ unsigned int lastEventTime; /* Time in milliseconds since last readable * event. */ /* Next readable event only after blockTime */ DWORD error; /* pending error code returned by * ClearCommError() */ DWORD lastError; /* last error code, can be fetched with * fconfigure chan -lasterror */ DWORD sysBufRead; /* Win32 system buffer size for read ops, * default=4096 */ DWORD sysBufWrite; /* Win32 system buffer size for write ops, * default=4096 */ Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer * threads. */ OVERLAPPED osRead; /* OVERLAPPED structure for read operations. */ OVERLAPPED osWrite; /* OVERLAPPED structure for write operations */ HANDLE writeThread; /* Handle to writer thread. */ CRITICAL_SECTION csWrite; /* Writer thread synchronisation. */ HANDLE evWritable; /* Manual-reset event to signal when the * writer thread has finished waiting for the * current buffer to be written. */ HANDLE evStartWriter; /* Auto-reset event used by the main thread to * signal when the writer thread should * attempt to write to the serial. */ HANDLE evStopWriter; /* Auto-reset event used by the main thread to * signal when the writer thread should close. */ DWORD writeError; /* An error caused by the last background * write. Set to 0 if no error has been * detected. This word is shared with the * writer thread so access must be * synchronized with the evWritable object. */ char *writeBuf; /* Current background output buffer. Access is * synchronized with the evWritable object. */ int writeBufLen; /* Size of write buffer. Access is * synchronized with the evWritable object. */ int toWrite; /* Current amount to be written. Access is * synchronized with the evWritable object. */ int writeQueue; /* Number of bytes pending in output queue. * Offset to DCB.cbInQue. Used to query * [fconfigure -queue] */ } SerialInfo; typedef struct ThreadSpecificData { /* * The following pointer refers to the head of the list of serials that * are being watched for file events. */ SerialInfo *firstSerialPtr; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * The following structure is what is added to the Tcl event queue when serial * events are generated. */ typedef struct SerialEvent { Tcl_Event header; /* Information that is standard for 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. */ |
︙ | ︙ | |||
186 187 188 189 190 191 192 | CONST char *buf, int toWrite, int *errorCode); static void SerialSetupProc(ClientData clientData, int flags); static void SerialWatchProc(ClientData instanceData, int mask); static void ProcExitHandler(ClientData clientData); | | < | | < | > > > | > > | 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 | CONST char *buf, int toWrite, int *errorCode); static void SerialSetupProc(ClientData clientData, int flags); static void SerialWatchProc(ClientData instanceData, int mask); static void ProcExitHandler(ClientData clientData); static int SerialGetOptionProc(ClientData instanceData, Tcl_Interp *interp, CONST char *optionName, Tcl_DString *dsPtr); static int SerialSetOptionProc(ClientData instanceData, Tcl_Interp *interp, CONST char *optionName, CONST char *value); static DWORD WINAPI SerialWriterThread(LPVOID arg); static void SerialThreadActionProc(ClientData instanceData, int action); /* * This structure describes the channel type structure for command serial * based IO. */ static Tcl_ChannelType serialChannelType = { "serial", /* Type name. */ TCL_CHANNEL_VERSION_4, /* v4 channel */ SerialCloseProc, /* Close proc. */ SerialInputProc, /* Input proc. */ SerialOutputProc, /* Output proc. */ NULL, /* Seek proc. */ SerialSetOptionProc, /* Set option proc. */ SerialGetOptionProc, /* Get option proc. */ SerialWatchProc, /* Set up notifier to watch the channel. */ SerialGetHandleProc, /* Get an OS handle from channel. */ NULL, /* close2proc. */ SerialBlockProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc */ SerialThreadActionProc, /* thread action proc */ }; /* *---------------------------------------------------------------------- * * SerialInit -- * |
︙ | ︙ | |||
268 269 270 271 272 273 274 | } /* *---------------------------------------------------------------------- * * SerialExitHandler -- * | | | | | < | | | | | > | > | | | | | | | | > | 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 | } /* *---------------------------------------------------------------------- * * SerialExitHandler -- * * This function is called to cleanup the serial module before Tcl is * unloaded. * * Results: * None. * * Side effects: * Removes the serial event source. * *---------------------------------------------------------------------- */ static void SerialExitHandler( ClientData clientData) /* Old window proc */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); SerialInfo *infoPtr; /* * Clear all eventually pending output. Otherwise Tcl's exit could totally * block, because it performs a blocking flush on all open channels. Note * that serial write operations may be blocked due to handshake. */ for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { PurgeComm(infoPtr->handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR); } Tcl_DeleteEventSource(SerialSetupProc, SerialCheckProc, NULL); } /* *---------------------------------------------------------------------- * * ProcExitHandler -- * * This function is called to cleanup the process list before Tcl is * unloaded. * * Results: * None. * * Side effects: * Resets the process list. * *---------------------------------------------------------------------- */ static void ProcExitHandler( ClientData clientData) /* Old window proc */ { Tcl_MutexLock(&serialMutex); initialized = 0; Tcl_MutexUnlock(&serialMutex); } /* *---------------------------------------------------------------------- * * SerialBlockTime -- * * Wrapper to set Tcl's block time in msec * * Results: * None. * * Side effects: * Updates the maximum blocking time. * *---------------------------------------------------------------------- */ static void SerialBlockTime( int msec) /* milli-seconds */ { Tcl_Time blockTime; blockTime.sec = msec / 1000; blockTime.usec = (msec % 1000) * 1000; Tcl_SetMaxBlockTime(&blockTime); } /* *---------------------------------------------------------------------- * * SerialGetMilliseconds -- * * Get current time in milliseconds,ignoring integer overruns. * * Results: * The current time. * * Side effects: * None. * *---------------------------------------------------------------------- */ static unsigned int SerialGetMilliseconds(void) { Tcl_Time time; TclpGetTime(&time); return (time.sec * 1000 + time.usec / 1000); } /* *---------------------------------------------------------------------- * * SerialSetupProc -- * * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an * event. * * Results: * None. * * Side effects: * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void SerialSetupProc( ClientData data, /* Not used. */ int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { SerialInfo *infoPtr; int block = 1; int msec = INT_MAX; /* min. found block time */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } /* * Look to see if any events handlers installed. If they are, do not * block. */ for (infoPtr=tsdPtr->firstSerialPtr ; infoPtr!=NULL ; infoPtr=infoPtr->nextPtr) { if (infoPtr->watchMask & TCL_WRITABLE) { if (WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) { block = 0; |
︙ | ︙ | |||
438 439 440 441 442 443 444 | } /* *---------------------------------------------------------------------- * * SerialCheckProc -- * | | | | | | 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 | } /* *---------------------------------------------------------------------- * * SerialCheckProc -- * * This procedure is called by Tcl_DoOneEvent to check the serial event * source for events. * * Results: * None. * * Side effects: * May queue an event. * *---------------------------------------------------------------------- */ static void SerialCheckProc( ClientData data, /* Not used. */ int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { SerialInfo *infoPtr; SerialEvent *evPtr; int needEvent; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); COMSTAT cStat; unsigned int time; |
︙ | ︙ | |||
480 481 482 483 484 485 486 | if (infoPtr->flags & SERIAL_PENDING) { continue; } needEvent = 0; /* | | < | | | | < | | | | | | < | 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 | if (infoPtr->flags & SERIAL_PENDING) { continue; } needEvent = 0; /* * If WRITABLE watch mask is set look for infoPtr->evWritable object. */ if (infoPtr->watchMask & TCL_WRITABLE && WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) { infoPtr->writable = 1; needEvent = 1; } /* * If READABLE watch mask is set call ClearCommError to poll cbInQue. * Window errors are ignored here. */ if (infoPtr->watchMask & TCL_READABLE) { if (ClearCommError(infoPtr->handle, &infoPtr->error, &cStat)) { /* * Look for characters already pending in windows queue. If * they are, poll. */ if (infoPtr->watchMask & TCL_READABLE) { /* * Force fileevent after serial read error. */ if ((cStat.cbInQue > 0) || (infoPtr->error & SERIAL_READ_ERRORS)) { infoPtr->readable = 1; time = SerialGetMilliseconds(); if ((unsigned int) (time - infoPtr->lastEventTime) >= (unsigned int) infoPtr->blockTime) { needEvent = 1; infoPtr->lastEventTime = time; } } } } } /* * Queue an event if the serial is signaled for reading or writing. */ if (needEvent) { infoPtr->flags |= SERIAL_PENDING; evPtr = (SerialEvent *) ckalloc(sizeof(SerialEvent)); evPtr->header.proc = SerialEventProc; evPtr->infoPtr = infoPtr; |
︙ | ︙ | |||
563 564 565 566 567 568 569 | int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { int errorCode = 0; SerialInfo *infoPtr = (SerialInfo *) instanceData; /* | | | | | 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 | int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { int errorCode = 0; SerialInfo *infoPtr = (SerialInfo *) instanceData; /* * Only serial READ can be switched between blocking & nonblocking using * COMMTIMEOUTS. Serial write emulates blocking & nonblocking by the * SerialWriterThread. */ if (mode == TCL_MODE_NONBLOCKING) { infoPtr->flags |= SERIAL_ASYNC; } else { infoPtr->flags &= ~(SERIAL_ASYNC); } |
︙ | ︙ | |||
612 613 614 615 616 617 618 | if (serialPtr->validMask & TCL_READABLE) { PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR); CloseHandle(serialPtr->osRead.hEvent); } serialPtr->validMask &= ~TCL_READABLE; if (serialPtr->validMask & TCL_WRITABLE) { | < | | | | | | | | < | | | | | < | | 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 | if (serialPtr->validMask & TCL_READABLE) { PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR); CloseHandle(serialPtr->osRead.hEvent); } serialPtr->validMask &= ~TCL_READABLE; if (serialPtr->validMask & TCL_WRITABLE) { /* * Generally we cannot wait for a pending write operation because it * may hang due to handshake * WaitForSingleObject(serialPtr->evWritable, INFINITE); */ /* * The thread may have already closed on it's own. Check it's exit * code. */ GetExitCodeThread(serialPtr->writeThread, &exitCode); if (exitCode == STILL_ACTIVE) { /* * Set the stop event so that if the writer thread is blocked in * SerialWriterThread on WaitForMultipleEvents, it will exit * cleanly. */ SetEvent(serialPtr->evStopWriter); /* * Wait at most 20 milliseconds for the writer thread to close. */ if (WaitForSingleObject(serialPtr->writeThread, 20) == WAIT_TIMEOUT) { /* * Forcibly terminate the background thread as a last resort. * Note that we need to guard against terminating the thread * while it is in the middle of Tcl_ThreadAlert because it * won't be able to release the notifier lock. */ Tcl_MutexLock(&serialMutex); /* BUG: this leaks memory */ TerminateThread(serialPtr->writeThread, 0); |
︙ | ︙ | |||
672 673 674 675 676 677 678 | serialPtr->writeThread = NULL; PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR); } serialPtr->validMask &= ~TCL_WRITABLE; /* | | | | | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 | serialPtr->writeThread = NULL; PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR); } serialPtr->validMask &= ~TCL_WRITABLE; /* * Don't close the Win32 handle if the handle is a standard channel during * the thread exit process. Otherwise, one thread may kill the stdio of * another. */ if (!TclInThreadExit() || ((GetStdHandle(STD_INPUT_HANDLE) != serialPtr->handle) && (GetStdHandle(STD_OUTPUT_HANDLE) != serialPtr->handle) && (GetStdHandle(STD_ERROR_HANDLE) != serialPtr->handle))) { if (CloseHandle(serialPtr->handle) == FALSE) { |
︙ | ︙ | |||
703 704 705 706 707 708 709 | if (infoPtr == (SerialInfo *)serialPtr) { *nextPtrPtr = infoPtr->nextPtr; break; } } /* | | < | | | | | | > | > > | > | > > > | > | | < | | | > | | > > > | > > > | > > > | > > > | > | | < | | | | | | < | < | | | > > | > < < < < < | > | | | | < | | | | | | > | | | | 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 | if (infoPtr == (SerialInfo *)serialPtr) { *nextPtrPtr = infoPtr->nextPtr; break; } } /* * Wrap the error file into a channel and give it to the cleanup routine. */ if (serialPtr->writeBuf != NULL) { ckfree(serialPtr->writeBuf); serialPtr->writeBuf = NULL; } ckfree((char*) serialPtr); if (errorCode == 0) { return result; } return errorCode; } /* *---------------------------------------------------------------------- * * blockingRead -- * * Perform a blocking read into the buffer given. Returns count of how * many bytes were actually read, and an error indication. * * Results: * A count of how many bytes were read is returned and an error * indication is returned. * * Side effects: * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int blockingRead( SerialInfo *infoPtr, /* Serial info structure */ LPVOID buf, /* The input buffer pointer */ DWORD bufSize, /* The number of bytes to read */ LPDWORD lpRead, /* Returns number of bytes read */ LPOVERLAPPED osPtr ) /* OVERLAPPED structure */ { /* * Perform overlapped blocking read. * 1. Reset the overlapped event * 2. Start overlapped read operation * 3. Wait for completion */ /* * Set Offset to ZERO, otherwise NT4.0 may report an error. */ osPtr->Offset = osPtr->OffsetHigh = 0; ResetEvent(osPtr->hEvent); if (!ReadFile(infoPtr->handle, buf, bufSize, lpRead, osPtr)) { if (GetLastError() != ERROR_IO_PENDING) { /* * ReadFile failed, but it isn't delayed. Report error. */ return FALSE; } else { /* * Read is pending, wait for completion, timeout? */ if (!GetOverlappedResult(infoPtr->handle, osPtr, lpRead, TRUE)) { return FALSE; } } } else { /* * ReadFile completed immediately. */ } return TRUE; } /* *---------------------------------------------------------------------- * * blockingWrite -- * * Perform a blocking write from the buffer given. Returns count of how * many bytes were actually written, and an error indication. * * Results: * A count of how many bytes were written is returned and an error * indication is returned. * * Side effects: * Writes output to the actual channel. * *---------------------------------------------------------------------- */ static int blockingWrite( SerialInfo *infoPtr, /* Serial info structure */ LPVOID buf, /* The output buffer pointer */ DWORD bufSize, /* The number of bytes to write */ LPDWORD lpWritten, /* Returns number of bytes written */ LPOVERLAPPED osPtr) /* OVERLAPPED structure */ { int result; /* * Perform overlapped blocking write. * 1. Reset the overlapped event * 2. Remove these bytes from the output queue counter * 3. Start overlapped write operation * 3. Remove these bytes from the output queue counter * 4. Wait for completion * 5. Adjust the output queue counter */ ResetEvent(osPtr->hEvent); EnterCriticalSection(&infoPtr->csWrite); infoPtr->writeQueue -= bufSize; /* * Set Offset to ZERO, otherwise NT4.0 may report an error */ osPtr->Offset = osPtr->OffsetHigh = 0; result = WriteFile(infoPtr->handle, buf, bufSize, lpWritten, osPtr); LeaveCriticalSection(&infoPtr->csWrite); if (result == FALSE) { int err = GetLastError(); switch (err) { case ERROR_IO_PENDING: /* * Write is pending, wait for completion. */ if (!GetOverlappedResult(infoPtr->handle, osPtr, lpWritten, TRUE)) { return FALSE; } break; case ERROR_COUNTER_TIMEOUT: /* * Write timeout handled in SerialOutputProc. */ break; default: /* * WriteFile failed, but it isn't delayed. Report error. */ return FALSE; } } else { /* * WriteFile completed immediately. */ } EnterCriticalSection(&infoPtr->csWrite); infoPtr->writeQueue += (*lpWritten - bufSize); LeaveCriticalSection(&infoPtr->csWrite); return TRUE; } /* *---------------------------------------------------------------------- * * SerialInputProc -- * * Reads input from the IO channel into the buffer given. Returns count * of how many bytes were actually read, and an error indication. * * Results: * A count of how many bytes were read is returned and an error * indication is returned in an output argument. * * Side effects: * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int SerialInputProc( ClientData instanceData, /* Serial state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ int *errorCode) /* Where to store error code. */ { SerialInfo *infoPtr = (SerialInfo *) instanceData; DWORD bytesRead = 0; COMSTAT cStat; *errorCode = 0; /* * Check if there is a CommError pending from SerialCheckProc */ if (infoPtr->error & SERIAL_READ_ERRORS) { goto commError; } /* * Look for characters already pending in windows queue. This is the * mainly restored good old code from Tcl8.0 */ if (ClearCommError(infoPtr->handle, &infoPtr->error, &cStat)) { /* * Check for errors here, but not in the evSetup/Check procedures. */ if (infoPtr->error & SERIAL_READ_ERRORS) { goto commError; } if (infoPtr->flags & SERIAL_ASYNC) { /* * NON_BLOCKING mode: Avoid blocking by reading more bytes than * available in input buffer. */ if (cStat.cbInQue > 0) { if ((DWORD) bufSize > cStat.cbInQue) { bufSize = cStat.cbInQue; } } else { errno = *errorCode = EAGAIN; return -1; } } else { /* * BLOCKING mode: Tcl trys to read a full buffer of 4 kBytes here. */ if (cStat.cbInQue > 0) { if ((DWORD) bufSize > cStat.cbInQue) { bufSize = cStat.cbInQue; } } else { bufSize = 1; } } } if (bufSize == 0) { return bytesRead = 0; } /* * Perform blocking read. Doesn't block in non-blocking mode, because we * checked the number of available bytes. */ if (blockingRead(infoPtr, (LPVOID) buf, (DWORD) bufSize, &bytesRead, &infoPtr->osRead) == FALSE) { TclWinConvertError(GetLastError()); *errorCode = errno; return -1; } return bytesRead; commError: infoPtr->lastError = infoPtr->error; /* save last error code */ infoPtr->error = 0; /* reset error code */ *errorCode = EIO; /* to return read-error only once */ return -1; } /* *---------------------------------------------------------------------- * * SerialOutputProc -- * * Writes the given output on the IO channel. Returns count of how many * characters were actually written, and an error indication. * * Results: * A count of how many characters were written is returned and an error * indication is returned in an output argument. * * Side effects: * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int SerialOutputProc( ClientData instanceData, /* Serial state. */ CONST char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ { SerialInfo *infoPtr = (SerialInfo *) instanceData; DWORD bytesWritten, timeout; *errorCode = 0; /* * At EXIT Tcl trys to flush all open channels in blocking mode. We avoid * blocking output after ExitProc or CloseHandler(chan) has been called by * checking the corrresponding variables. */ if (!initialized || TclInExit()) { return toWrite; } /* * Check if there is a CommError pending from SerialCheckProc */ if (infoPtr->error & SERIAL_WRITE_ERRORS) { infoPtr->lastError = infoPtr->error; /* save last error code */ infoPtr->error = 0; /* reset error code */ errno = EIO; goto error; } timeout = (infoPtr->flags & SERIAL_ASYNC) ? 0 : INFINITE; if (WaitForSingleObject(infoPtr->evWritable, timeout) == WAIT_TIMEOUT) { /* * The writer thread is blocked waiting for a write to complete and * the channel is in non-blocking mode. */ errno = EWOULDBLOCK; goto error1; } /* |
︙ | ︙ | |||
1046 1047 1048 1049 1050 1051 1052 | EnterCriticalSection(&infoPtr->csWrite); infoPtr->writeQueue += toWrite; LeaveCriticalSection(&infoPtr->csWrite); if (infoPtr->flags & SERIAL_ASYNC) { /* | | | | 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 | EnterCriticalSection(&infoPtr->csWrite); infoPtr->writeQueue += toWrite; LeaveCriticalSection(&infoPtr->csWrite); if (infoPtr->flags & SERIAL_ASYNC) { /* * The serial is non-blocking, so copy the data into the output buffer * and restart the writer thread. */ if (toWrite > infoPtr->writeBufLen) { /* * Reallocate the buffer to be large enough to hold the data. */ |
︙ | ︙ | |||
1069 1070 1071 1072 1073 1074 1075 | infoPtr->toWrite = toWrite; ResetEvent(infoPtr->evWritable); SetEvent(infoPtr->evStartWriter); bytesWritten = (DWORD) toWrite; } else { /* | | | > | > | | | | | | | | < | | | | | | | | | | | 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 | infoPtr->toWrite = toWrite; ResetEvent(infoPtr->evWritable); SetEvent(infoPtr->evStartWriter); bytesWritten = (DWORD) toWrite; } else { /* * In the blocking case, just try to write the buffer directly. This * avoids an unnecessary copy. */ if (!blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite, &bytesWritten, &infoPtr->osWrite)) { goto writeError; } if (bytesWritten != (DWORD) toWrite) { /* * Write timeout. */ infoPtr->lastError |= CE_PTO; errno = EIO; goto error; } } return (int) bytesWritten; writeError: TclWinConvertError(GetLastError()); error: /* * Reset the output queue counter on error during blocking output */ /* * EnterCriticalSection(&infoPtr->csWrite); * infoPtr->writeQueue = 0; * LeaveCriticalSection(&infoPtr->csWrite); */ error1: *errorCode = errno; return -1; } /* *---------------------------------------------------------------------- * * SerialEventProc -- * * This function is invoked by Tcl_ServiceEvent when a file event reaches * the front of the event queue. This procedure invokes Tcl_NotifyChannel * on the serial. * * Results: * Returns 1 if the event was handled, meaning it should be removed from * the queue. Returns 0 if the event was not handled, meaning it should * stay on the queue. The only time the event isn't handled is if the * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the notifier callback does. * *---------------------------------------------------------------------- */ static int SerialEventProc( Tcl_Event *evPtr, /* Event to service. */ int flags) /* Flags that indicate what events to handle, such as * TCL_FILE_EVENTS. */ { SerialEvent *serialEvPtr = (SerialEvent *)evPtr; SerialInfo *infoPtr; int mask; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return 0; } /* * Search through the list of watched serials for the one whose handle * matches the event. We do this rather than simply dereferencing the * handle in the event so that serials can be deleted while the event is * in the queue. */ for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (serialEvPtr->infoPtr == infoPtr) { infoPtr->flags &= ~(SERIAL_PENDING); break; } } /* * Remove stale events. */ if (!infoPtr) { return 1; } /* * Check to see if the serial is readable. Note that we can't tell if a * serial is writable, so we always report it as being writable unless we * have detected EOF. */ mask = 0; if (infoPtr->watchMask & TCL_WRITABLE) { if (infoPtr->writable) { mask |= TCL_WRITABLE; infoPtr->writable = 0; |
︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 | } /* *---------------------------------------------------------------------- * * SerialWatchProc -- * | | < | | | | | | 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 | } /* *---------------------------------------------------------------------- * * SerialWatchProc -- * * Called by the notifier to set up to watch for events on this channel. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void SerialWatchProc( ClientData instanceData, /* Serial state. */ int mask) /* What events to watch for, OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { SerialInfo **nextPtrPtr, *ptr; SerialInfo *infoPtr = (SerialInfo *) instanceData; int oldMask = infoPtr->watchMask; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Since the file is always ready for events, we set the block time so we * will poll. */ infoPtr->watchMask = mask & infoPtr->validMask; if (infoPtr->watchMask) { if (!oldMask) { infoPtr->nextPtr = tsdPtr->firstSerialPtr; tsdPtr->firstSerialPtr = infoPtr; |
︙ | ︙ | |||
1256 1257 1258 1259 1260 1261 1262 | } /* *---------------------------------------------------------------------- * * SerialGetHandleProc -- * | | | | | | | < | | | < | > | | | | | > | > > | | | | | < > > > > > > | > | | | | | | | | | | < | > > > > > > > > > > | | < < < < < < < < | | | < | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * SerialGetHandleProc -- * * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a * command serial port based channel. * * Results: * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no * handle for the specified direction. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int SerialGetHandleProc( ClientData instanceData, /* The serial state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ ClientData *handlePtr) /* Where to store the handle. */ { SerialInfo *infoPtr = (SerialInfo *) instanceData; *handlePtr = (ClientData) infoPtr->handle; return TCL_OK; } /* *---------------------------------------------------------------------- * * SerialWriterThread -- * * This function runs in a separate thread and writes data onto a serial. * * Results: * Always returns 0. * * Side effects: * Signals the main thread when an output operation is completed. May * cause the main thread to wake up by posting a message. * *---------------------------------------------------------------------- */ static DWORD WINAPI SerialWriterThread(LPVOID arg) { SerialInfo *infoPtr = (SerialInfo *)arg; DWORD bytesWritten, toWrite, waitResult; char *buf; OVERLAPPED myWrite; /* Have an own OVERLAPPED in this thread. */ HANDLE wEvents[2]; /* * The stop event takes precedence by being first in the list. */ wEvents[0] = infoPtr->evStopWriter; wEvents[1] = infoPtr->evStartWriter; for (;;) { /* * Wait for the main thread to signal before attempting to write. */ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); if (waitResult != (WAIT_OBJECT_0 + 1)) { /* * The start event was not signaled. It might be the stop event or * an error, so exit. */ break; } buf = infoPtr->writeBuf; toWrite = infoPtr->toWrite; myWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); /* * Loop until all of the bytes are written or an error occurs. */ while (toWrite > 0) { /* * Check for pending writeError. Ignore all write operations until * the user has been notified. */ if (infoPtr->writeError) { break; } if (blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite, &bytesWritten, &myWrite) == FALSE) { infoPtr->writeError = GetLastError(); break; } if (bytesWritten != toWrite) { /* * Write timeout. */ infoPtr->writeError = ERROR_WRITE_FAULT; break; } toWrite -= bytesWritten; buf += bytesWritten; } CloseHandle(myWrite.hEvent); /* * Signal the main thread by signalling the evWritable event and then * waking up the notifier thread. */ SetEvent(infoPtr->evWritable); /* * Alert the foreground thread. Note that we need to treat this like a * critical section so the foreground thread does not terminate this * thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&serialMutex); if (infoPtr->threadId != NULL) { /* * TIP #218: When in flight ignore the event, no one will receive * it anyway. */ Tcl_ThreadAlert(infoPtr->threadId); } Tcl_MutexUnlock(&serialMutex); } return 0; } /* *---------------------------------------------------------------------- * * TclWinSerialReopen -- * * Reopens the serial port with the OVERLAPPED FLAG set * * Results: * Returns the new handle, or INVALID_HANDLE_VALUE. Normally there * shouldn't be any error, because the same channel has previously been * succeesfully opened. * * Side effects: * May close the original handle * *---------------------------------------------------------------------- */ HANDLE TclWinSerialReopen(handle, name, access) HANDLE handle; CONST TCHAR *name; DWORD access; { ThreadSpecificData *tsdPtr; tsdPtr = SerialInit(); /* * Multithreaded I/O needs the overlapped flag set otherwise * ClearCommError blocks under Windows NT/2000 until serial output is * finished */ if (CloseHandle(handle) == FALSE) { return INVALID_HANDLE_VALUE; } handle = (*tclWinProcs->createFileProc)(name, access, 0, 0, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0); return handle; } /* *---------------------------------------------------------------------- * * TclWinOpenSerialChannel -- * * Constructs a Serial port channel for the specified standard OS handle. * This is a helper function to break up the construction of channels * into File, Console, or Serial. * * Results: * Returns the new channel, or NULL. * * Side effects: * May open the channel * *---------------------------------------------------------------------- */ Tcl_Channel TclWinOpenSerialChannel(handle, channelName, permissions) HANDLE handle; char *channelName; int permissions; { SerialInfo *infoPtr; DWORD id; SerialInit(); infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo)); memset(infoPtr, 0, sizeof(SerialInfo)); infoPtr->validMask = permissions; infoPtr->handle = handle; infoPtr->channel = (Tcl_Channel) NULL; infoPtr->readable = 0; infoPtr->writable = 1; infoPtr->toWrite = infoPtr->writeQueue = 0; infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME; infoPtr->lastEventTime = 0; infoPtr->lastError = infoPtr->error = 0; infoPtr->threadId = Tcl_GetCurrentThread(); infoPtr->sysBufRead = 4096; infoPtr->sysBufWrite = 4096; /* * Use the pointer to keep the channel names unique, in case the handles * are shared between multiple channels (stdin/stdout). */ wsprintfA(channelName, "file%lx", (int) infoPtr); infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName, (ClientData) infoPtr, permissions); SetupComm(handle, infoPtr->sysBufRead, infoPtr->sysBufWrite); PurgeComm(handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR); /* * Default is blocking. */ SetCommTimeouts(handle, &no_timeout); if (permissions & TCL_READABLE) { infoPtr->osRead.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); } if (permissions & TCL_WRITABLE) { /* * Initially the channel is writable and the writeThread is idle. */ infoPtr->osWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); infoPtr->evWritable = CreateEvent(NULL, TRUE, TRUE, NULL); infoPtr->evStartWriter = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->evStopWriter = CreateEvent(NULL, FALSE, FALSE, NULL); InitializeCriticalSection(&infoPtr->csWrite); infoPtr->writeThread = CreateThread(NULL, 256, SerialWriterThread, infoPtr, 0, &id); } /* * Files have default translation of AUTO and ^Z eof char, which means * that a ^Z will be accepted as EOF when reading. */ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); return infoPtr->channel; } /* *---------------------------------------------------------------------- * * SerialErrorStr -- * * Converts a Win32 serial error code to a list of readable errors. * * Results: * None. * * Side effects: * Generates readable errors in the supplied DString. * *---------------------------------------------------------------------- */ static void SerialErrorStr(error, dsPtr) DWORD error; /* Win32 serial error code. */ Tcl_DString *dsPtr; /* Where to store string. */ { if (error & CE_RXOVER) { Tcl_DStringAppendElement(dsPtr, "RXOVER"); } if (error & CE_OVERRUN) { Tcl_DStringAppendElement(dsPtr, "OVERRUN"); } if (error & CE_RXPARITY) { Tcl_DStringAppendElement(dsPtr, "RXPARITY"); } if (error & CE_FRAME) { Tcl_DStringAppendElement(dsPtr, "FRAME"); } if (error & CE_BREAK) { Tcl_DStringAppendElement(dsPtr, "BREAK"); } if (error & CE_TXFULL) { Tcl_DStringAppendElement(dsPtr, "TXFULL"); } if (error & CE_PTO) { /* PTO used to signal WRITE-TIMEOUT */ Tcl_DStringAppendElement(dsPtr, "TIMEOUT"); } if (error & ~((DWORD) (SERIAL_READ_ERRORS | SERIAL_WRITE_ERRORS))) { char buf[TCL_INTEGER_SPACE + 1]; wsprintfA(buf, "%d", error); Tcl_DStringAppendElement(dsPtr, buf); |
︙ | ︙ | |||
1591 1592 1593 1594 1595 1596 1597 | * Appends modem status flag strings to the given DString. * *---------------------------------------------------------------------- */ static void SerialModemStatusStr(status, dsPtr) | | | | | | 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 | * Appends modem status flag strings to the given DString. * *---------------------------------------------------------------------- */ static void SerialModemStatusStr(status, dsPtr) DWORD status; /* Win32 modem status. */ Tcl_DString *dsPtr; /* Where to store string. */ { Tcl_DStringAppendElement(dsPtr, "CTS"); Tcl_DStringAppendElement(dsPtr, (status & MS_CTS_ON) ? "1" : "0"); Tcl_DStringAppendElement(dsPtr, "DSR"); Tcl_DStringAppendElement(dsPtr, (status & MS_DSR_ON) ? "1" : "0"); Tcl_DStringAppendElement(dsPtr, "RING"); Tcl_DStringAppendElement(dsPtr, (status & MS_RING_ON) ? "1" : "0"); Tcl_DStringAppendElement(dsPtr, "DCD"); Tcl_DStringAppendElement(dsPtr, (status & MS_RLSD_ON) ? "1" : "0"); } /* *---------------------------------------------------------------------- * * SerialSetOptionProc -- * * Sets an option on a channel. * * Results: * A standard Tcl result. Also sets the interp's result on error if * interp is not NULL. * * Side effects: * May modify an option on a device. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
1639 1640 1641 1642 1643 1644 1645 | Tcl_DString ds; CONST TCHAR *native; int argc; CONST char **argv; infoPtr = (SerialInfo *) instanceData; | | | | | | 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 | Tcl_DString ds; CONST TCHAR *native; int argc; CONST char **argv; infoPtr = (SerialInfo *) instanceData; /* * Parse options. This would be far easier if we had Tcl_Objs to work with * as that would let us use Tcl_GetIndexFromObj()... */ len = strlen(optionName); vlen = strlen(value); /* * Option -mode baud,parity,databits,stopbits */ if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { if (interp) { Tcl_AppendResult(interp, "can't get comm state", (char *)NULL); |
︙ | ︙ | |||
1671 1672 1673 1674 1675 1676 1677 | Tcl_AppendResult(interp, "bad value for -mode: should be baud,parity,data,stop", (char *) NULL); } return TCL_ERROR; } | > | > > | | < | | > | > | 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 | Tcl_AppendResult(interp, "bad value for -mode: should be baud,parity,data,stop", (char *) NULL); } return TCL_ERROR; } /* * Default settings for serial communications. */ dcb.fBinary = TRUE; dcb.fErrorChar = FALSE; dcb.fNull = FALSE; dcb.fAbortOnError = FALSE; if (!SetCommState(infoPtr->handle, &dcb)) { if (interp) { Tcl_AppendResult(interp, "can't set comm state", (char *)NULL); } return TCL_ERROR; } return TCL_OK; } /* * Option -handshake none|xonxoff|rtscts|dtrdsr */ if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { if (interp) { Tcl_AppendResult(interp, "can't get comm state", (char *)NULL); } return TCL_ERROR; } /* * Reset all handshake options. DTR and RTS are ON by default. */ dcb.fOutX = dcb.fInX = FALSE; dcb.fOutxCtsFlow = dcb.fOutxDsrFlow = dcb.fDsrSensitivity = FALSE; dcb.fDtrControl = DTR_CONTROL_ENABLE; dcb.fRtsControl = RTS_CONTROL_ENABLE; dcb.fTXContinueOnXoff = FALSE; /* * Adjust the handshake limits. Yes, the XonXoff limits seem to * influence even hardware handshake. */ dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2); dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4); if (strnicmp(value, "NONE", vlen) == 0) { /* * Leave all handshake options disabled. */ } else if (strnicmp(value, "XONXOFF", vlen) == 0) { dcb.fOutX = dcb.fInX = TRUE; } else if (strnicmp(value, "RTSCTS", vlen) == 0) { dcb.fOutxCtsFlow = TRUE; dcb.fRtsControl = RTS_CONTROL_HANDSHAKE; } else if (strnicmp(value, "DTRDSR", vlen) == 0) { dcb.fOutxDsrFlow = TRUE; |
︙ | ︙ | |||
1745 1746 1747 1748 1749 1750 1751 | Tcl_AppendResult(interp, "can't set comm state", (char *)NULL); } return TCL_ERROR; } return TCL_OK; } | | > | | < > | > > > | | | > | | | | | > | | | | | > | | | | | > | > < < < | > > | | | > > | | | | 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 | Tcl_AppendResult(interp, "can't set comm state", (char *)NULL); } return TCL_ERROR; } return TCL_OK; } /* * Option -xchar {\x11 \x13} */ if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { if (interp) { Tcl_AppendResult(interp, "can't get comm state", (char *)NULL); } return TCL_ERROR; } if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } if (argc == 2) { dcb.XonChar = argv[0][0]; dcb.XoffChar = argv[1][0]; ckfree((char *) argv); } else { if (interp) { Tcl_AppendResult(interp, "bad value for -xchar: ", "should be a list of two elements", (char *) NULL); } ckfree((char *) argv); return TCL_ERROR; } if (!SetCommState(infoPtr->handle, &dcb)) { if (interp) { Tcl_AppendResult(interp, "can't set comm state", (char *)NULL); } return TCL_ERROR; } return TCL_OK; } /* * Option -ttycontrol {DTR 1 RTS 0 BREAK 0} */ if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { int i, result = TCL_OK; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } if ((argc % 2) == 1) { if (interp) { Tcl_AppendResult(interp, "bad value for -ttycontrol: ", "should be a list of signal,value pairs", (char *) NULL); } ckfree((char *) argv); return TCL_ERROR; } for (i = 0; i < argc - 1; i += 2) { if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) { result = TCL_ERROR; break; } if (strnicmp(argv[i], "DTR", strlen(argv[i])) == 0) { if (!EscapeCommFunction(infoPtr->handle, flag ? (DWORD) SETDTR : (DWORD) CLRDTR)) { if (interp) { Tcl_AppendResult(interp, "can't set DTR signal", (char *) NULL); } result = TCL_ERROR; break; } } else if (strnicmp(argv[i], "RTS", strlen(argv[i])) == 0) { if (!EscapeCommFunction(infoPtr->handle, flag ? (DWORD) SETRTS : (DWORD) CLRRTS)) { if (interp) { Tcl_AppendResult(interp, "can't set RTS signal", (char *) NULL); } result = TCL_ERROR; break; } } else if (strnicmp(argv[i], "BREAK", strlen(argv[i])) == 0) { if (!EscapeCommFunction(infoPtr->handle, flag ? (DWORD) SETBREAK : (DWORD) CLRBREAK)) { if (interp) { Tcl_AppendResult(interp, "can't set BREAK signal", (char *) NULL); } result = TCL_ERROR; break; } } else { if (interp) { Tcl_AppendResult(interp, "bad signal for -ttycontrol: ", "must be DTR, RTS or BREAK", (char *) NULL); } result = TCL_ERROR; break; } } ckfree((char *) argv); return result; } /* * Option -sysbuffer {read_size write_size} * Option -sysbuffer read_size */ if ((len > 1) && (strncmp(optionName, "-sysbuffer", len) == 0)) { /* * -sysbuffer 4096 or -sysbuffer {64536 4096} */ size_t inSize = (size_t) -1, outSize = (size_t) -1; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } if (argc == 1) { inSize = atoi(argv[0]); outSize = infoPtr->sysBufWrite; } else if (argc == 2) { inSize = atoi(argv[0]); outSize = atoi(argv[1]); } ckfree((char *) argv); if ((inSize <= 0) || (outSize <= 0)) { if (interp) { Tcl_AppendResult(interp, "bad value for -sysbuffer: ", "should be a list of one or two integers > 0", (char *) NULL); } return TCL_ERROR; } if (!SetupComm(infoPtr->handle, inSize, outSize)) { if (interp) { Tcl_AppendResult(interp, "can't setup comm buffers", (char *) NULL); } return TCL_ERROR; } infoPtr->sysBufRead = inSize; infoPtr->sysBufWrite = outSize; /* * Adjust the handshake limits. Yes, the XonXoff limits seem to * influence even hardware handshake. */ if (!GetCommState(infoPtr->handle, &dcb)) { if (interp) { Tcl_AppendResult(interp, "can't get comm state", (char *) NULL); } |
︙ | ︙ | |||
1905 1906 1907 1908 1909 1910 1911 | (char *) NULL); } return TCL_ERROR; } return TCL_OK; } | | | 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 | (char *) NULL); } return TCL_ERROR; } return TCL_OK; } /* * Option -pollinterval msec */ if ((len > 1) && (strncmp(optionName, "-pollinterval", len) == 0)) { if (Tcl_GetInt(interp, value, &(infoPtr->blockTime)) != TCL_OK ) { return TCL_ERROR; } |
︙ | ︙ | |||
1940 1941 1942 1943 1944 1945 1946 | return TCL_ERROR; } return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, | | | | | | | | | | | | | 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 | return TCL_ERROR; } return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, "mode handshake pollinterval sysbuffer timeout ttycontrol xchar"); } /* *---------------------------------------------------------------------- * * SerialGetOptionProc -- * * Gets a mode associated with an IO channel. If the optionName arg is * non NULL, retrieves the value of that option. If the optionName arg is * NULL, retrieves a list of alternating option names and values for the * given channel. * * Results: * A standard Tcl result. Also sets the supplied DString to the string * value of the option(s) returned. * * Side effects: * The string returned by this function is in static storage and may be * reused at any time subsequent to the call. * *---------------------------------------------------------------------- */ static int SerialGetOptionProc(instanceData, interp, optionName, dsPtr) ClientData instanceData; /* File state. */ Tcl_Interp *interp; /* For error reporting - can be NULL. */ CONST char *optionName; /* Option to get. */ Tcl_DString *dsPtr; /* Where to store value(s). */ { SerialInfo *infoPtr; DCB dcb; size_t len; int valid = 0; /* Flag if valid option parsed. */ infoPtr = (SerialInfo *) instanceData; if (optionName == NULL) { len = 0; } else { len = strlen(optionName); } /* * Get option -mode */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-mode"); } if (len==0 || (len>2 && (strncmp(optionName, "-mode", len) == 0))) { char parity; |
︙ | ︙ | |||
2017 2018 2019 2020 2021 2022 2023 | wsprintfA(buf, "%d,%c,%d,%s", dcb.BaudRate, parity, dcb.ByteSize, stop); Tcl_DStringAppendElement(dsPtr, buf); } /* | | | | | 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 | wsprintfA(buf, "%d,%c,%d,%s", dcb.BaudRate, parity, dcb.ByteSize, stop); Tcl_DStringAppendElement(dsPtr, buf); } /* * Get option -pollinterval */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-pollinterval"); } if (len==0 || (len>1 && strncmp(optionName, "-pollinterval", len)==0)) { char buf[TCL_INTEGER_SPACE + 1]; valid = 1; wsprintfA(buf, "%d", infoPtr->blockTime); Tcl_DStringAppendElement(dsPtr, buf); } /* * Get option -sysbuffer */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-sysbuffer"); Tcl_DStringStartSublist(dsPtr); } if (len==0 || (len>1 && strncmp(optionName, "-sysbuffer", len) == 0)) { char buf[TCL_INTEGER_SPACE + 1]; valid = 1; wsprintfA(buf, "%d", infoPtr->sysBufRead); Tcl_DStringAppendElement(dsPtr, buf); wsprintfA(buf, "%d", infoPtr->sysBufWrite); Tcl_DStringAppendElement(dsPtr, buf); } if (len == 0) { Tcl_DStringEndSublist(dsPtr); } /* * Get option -xchar */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-xchar"); Tcl_DStringStartSublist(dsPtr); } if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) { |
︙ | ︙ | |||
2080 2081 2082 2083 2084 2085 2086 | Tcl_DStringAppendElement(dsPtr, buf); } if (len == 0) { Tcl_DStringEndSublist(dsPtr); } /* | | > | | > | | | | > | | | 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 | Tcl_DStringAppendElement(dsPtr, buf); } if (len == 0) { Tcl_DStringEndSublist(dsPtr); } /* * Get option -lasterror * * Option is readonly and returned by [fconfigure chan -lasterror] but not * returned by unnamed [fconfigure chan]. */ if (len>1 && strncmp(optionName, "-lasterror", len)==0) { valid = 1; SerialErrorStr(infoPtr->lastError, dsPtr); } /* * get option -queue * * Option is readonly and returned by [fconfigure chan -queue]. */ if (len>1 && strncmp(optionName, "-queue", len)==0) { char buf[TCL_INTEGER_SPACE + 1]; COMSTAT cStat; DWORD error; int inBuffered, outBuffered, count; valid = 1; /* * Query the pending data in Tcl's internal queues. */ inBuffered = Tcl_InputBuffered(infoPtr->channel); outBuffered = Tcl_OutputBuffered(infoPtr->channel); /* * Query the number of bytes in our output queue: * 1. The bytes pending in the output thread * 2. The bytes in the system drivers buffer * The writer thread should not interfere this action. */ EnterCriticalSection(&infoPtr->csWrite); ClearCommError( infoPtr->handle, &error, &cStat ); count = (int)cStat.cbOutQue + infoPtr->writeQueue; LeaveCriticalSection(&infoPtr->csWrite); wsprintfA(buf, "%d", inBuffered + cStat.cbInQue); Tcl_DStringAppendElement(dsPtr, buf); wsprintfA(buf, "%d", outBuffered + count); Tcl_DStringAppendElement(dsPtr, buf); } /* * get option -ttystatus * * Option is readonly and returned by [fconfigure chan -ttystatus] but not * returned by unnamed [fconfigure chan]. */ if (len>4 && strncmp(optionName, "-ttystatus", len)==0) { DWORD status; if (!GetCommModemStatus(infoPtr->handle, &status)) { if (interp) { |
︙ | ︙ | |||
2154 2155 2156 2157 2158 2159 2160 | if (valid) { return TCL_OK; } else { return Tcl_BadChannelOption(interp, optionName, "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); } } | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | if (valid) { return TCL_OK; } else { return Tcl_BadChannelOption(interp, optionName, "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); } } /* *---------------------------------------------------------------------- * * SerialThreadActionProc -- * * Insert or remove any thread local refs to this channel. * * Results: * None. * * Side effects: * Changes thread local list of valid channels. * *---------------------------------------------------------------------- */ static void SerialThreadActionProc(instanceData, action) ClientData instanceData; int action; { SerialInfo *infoPtr = (SerialInfo *) instanceData; /* * We do not access firstSerialPtr in the thread structures. This is not * for all serials managed by the thread, but only those we are watching. * Removal of the filevent handlers before transfer thus takes care of * this structure. */ Tcl_MutexLock(&serialMutex); if (action == TCL_CHANNEL_THREAD_INSERT) { /* * We can't copy the thread information from the channel when the * channel is created. At this time the channel back pointer has not * been set yet. However in that case the threadId has already been * set by TclpCreateCommandChannel itself, so the structure is still * good. */ SerialInit(); if (infoPtr->channel != NULL) { infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel); } } else { infoPtr->threadId = NULL; } Tcl_MutexUnlock(&serialMutex); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinSock.c.
|
| | | | | | | > > < | | | < > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | /* * tclWinSock.c -- * * This file contains Windows-specific socket related code. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinSock.c,v 1.44.2.2 2005/08/02 18:17:20 dgp Exp $ */ #include "tclWinInt.h" /* * Make sure to remove the redirection defines set in tclWinPort.h that is in * use in other sections of the core, except for us. */ #undef getservbyname #undef getsockopt #undef ntohs #undef setsockopt /* * The following variable is used to tell whether this module has been * initialized. */ static int initialized = 0; TCL_DECLARE_MUTEX(socketMutex) /* * The following variable holds the network name of this host. */ static TclInitProcessGlobalValueProc InitializeHostName; static ProcessGlobalValue hostName = {0, 0, NULL, NULL, InitializeHostName, NULL, NULL}; /* * Mingw, Cygwin and OpenWatcom may not have LPFN_* typedefs. */ #ifdef HAVE_NO_LPFN_DECLS typedef SOCKET (PASCAL FAR *LPFN_ACCEPT)(SOCKET s, struct sockaddr FAR * addr, int FAR * addrlen); typedef int (PASCAL FAR *LPFN_BIND)(SOCKET s, const struct sockaddr FAR *addr, int namelen); typedef int (PASCAL FAR *LPFN_CLOSESOCKET)(SOCKET s); typedef int (PASCAL FAR *LPFN_CONNECT)(SOCKET s, const struct sockaddr FAR *name, int namelen); typedef struct hostent FAR * (PASCAL FAR *LPFN_GETHOSTBYADDR) (const char FAR *addr, int addrlen, int addrtype); typedef struct hostent FAR * (PASCAL FAR *LPFN_GETHOSTBYNAME) (const char FAR * name); typedef int (PASCAL FAR *LPFN_GETHOSTNAME)(char FAR * name, int namelen); typedef int (PASCAL FAR *LPFN_GETPEERNAME)(SOCKET sock, struct sockaddr FAR *name, int FAR *namelen); typedef struct servent FAR * (PASCAL FAR *LPFN_GETSERVBYNAME) (const char FAR * name, const char FAR * proto); typedef int (PASCAL FAR *LPFN_GETSOCKNAME)(SOCKET sock, struct sockaddr FAR *name, int FAR *namelen); typedef int (PASCAL FAR *LPFN_GETSOCKOPT)(SOCKET s, int level, int optname, char FAR * optval, int FAR *optlen); typedef u_short (PASCAL FAR *LPFN_HTONS)(u_short hostshort); typedef unsigned long (PASCAL FAR *LPFN_INET_ADDR) (const char FAR * cp); typedef char FAR * (PASCAL FAR *LPFN_INET_NTOA) (struct in_addr in); typedef int (PASCAL FAR *LPFN_IOCTLSOCKET)(SOCKET s, long cmd, u_long FAR *argp); typedef int (PASCAL FAR *LPFN_LISTEN)(SOCKET s, int backlog); typedef u_short (PASCAL FAR *LPFN_NTOHS)(u_short netshort); typedef int (PASCAL FAR *LPFN_RECV)(SOCKET s, char FAR * buf, int len, int flags); typedef int (PASCAL FAR *LPFN_SELECT)(int nfds, fd_set FAR * readfds, fd_set FAR * writefds, fd_set FAR * exceptfds, const struct timeval FAR * timeout); typedef int (PASCAL FAR *LPFN_SEND)(SOCKET s, const char FAR * buf, int len, int flags); typedef int (PASCAL FAR *LPFN_SETSOCKOPT)(SOCKET s, int level, int optname, const char FAR * optval, int optlen); typedef SOCKET (PASCAL FAR *LPFN_SOCKET)(int af, int type, int protocol); typedef int (PASCAL FAR *LPFN_WSAASYNCSELECT)(SOCKET s, HWND hWnd, u_int wMsg, long lEvent); typedef int (PASCAL FAR *LPFN_WSACLEANUP)(void); typedef int (PASCAL FAR *LPFN_WSAGETLASTERROR)(void); typedef int (PASCAL FAR *LPFN_WSASTARTUP)(WORD wVersionRequired, LPWSADATA lpWSAData); #endif /* * The following structure contains pointers to all of the WinSock API entry * points used by Tcl. It is initialized by InitSockets. Since we dynamically * load the Winsock DLL on demand, we must use this function table to refer to * functions in the winsock API. */ static struct { HMODULE hModule; /* Handle to WinSock library. */ /* Winsock 1.1 functions */ LPFN_ACCEPT accept; |
︙ | ︙ | |||
126 127 128 129 130 131 132 | LPFN_SEND send; LPFN_SETSOCKOPT setsockopt; LPFN_SOCKET socket; LPFN_WSAASYNCSELECT WSAAsyncSelect; LPFN_WSACLEANUP WSACleanup; LPFN_WSAGETLASTERROR WSAGetLastError; LPFN_WSASTARTUP WSAStartup; | < | | | < | | | | | < | | | < | | | < | | | < | | > | | | | | | | | | | | | | | | | < | | | < | | | | | | | | | | | | | < | | < | | | | < < < | < | | > > > > > > > > > > | | < < < < < < | > > | | | | | < | | | | 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 | LPFN_SEND send; LPFN_SETSOCKOPT setsockopt; LPFN_SOCKET socket; LPFN_WSAASYNCSELECT WSAAsyncSelect; LPFN_WSACLEANUP WSACleanup; LPFN_WSAGETLASTERROR WSAGetLastError; LPFN_WSASTARTUP WSAStartup; } winSock; /* * The following defines declare the messages used on socket windows. */ #define SOCKET_MESSAGE WM_USER+1 #define SOCKET_SELECT WM_USER+2 #define SOCKET_TERMINATE WM_USER+3 #define SELECT TRUE #define UNSELECT FALSE /* * The following structure is used to store the data associated with each * socket. */ typedef struct SocketInfo { Tcl_Channel channel; /* Channel associated with this socket. */ SOCKET socket; /* Windows SOCKET handle. */ int flags; /* Bit field comprised of the flags described * below. */ int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE, * FD_CLOSE, FD_ACCEPT and FD_CONNECT that * indicate which events are interesting. */ int readyEvents; /* OR'ed combination of FD_READ, FD_WRITE, * FD_CLOSE, FD_ACCEPT and FD_CONNECT that * indicate which events have occurred. */ int selectEvents; /* OR'ed combination of FD_READ, FD_WRITE, * FD_CLOSE, FD_ACCEPT and FD_CONNECT that * indicate which events are currently being * selected. */ int acceptEventCount; /* Count of the current number of FD_ACCEPTs * that have arrived and not yet processed. */ Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ ClientData acceptProcData; /* The data for the accept proc. */ int lastError; /* Error code from last message. */ struct SocketInfo *nextPtr; /* The next socket on the per-thread socket * list. */ } SocketInfo; /* * The following structure is what is added to the Tcl event queue when a * socket event occurs. */ typedef struct SocketEvent { Tcl_Event header; /* Information that is standard for all * events. */ SOCKET socket; /* Socket descriptor that is ready. Used to * find the SocketInfo structure for the file * (can't point directly to the SocketInfo * structure because it could go away while * the event is queued). */ } SocketEvent; /* * This defines the minimum buffersize maintained by the kernel. */ #define TCP_BUFFER_SIZE 4096 /* * The following macros may be used to set the flags field of a SocketInfo * structure. */ #define SOCKET_ASYNC (1<<0) /* The socket is in blocking mode. */ #define SOCKET_EOF (1<<1) /* A zero read happened on the * socket. */ #define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async connect. */ #define SOCKET_PENDING (1<<3) /* A message has been sent for this * socket */ typedef struct ThreadSpecificData { HWND hwnd; /* Handle to window for socket messages. */ HANDLE socketThread; /* Thread handling the window */ Tcl_ThreadId threadId; /* Parent thread. */ HANDLE readyEvent; /* Event indicating that a socket event is * ready. Also used to indicate that the * socketThread has been initialized and has * started. */ HANDLE socketListLock; /* Win32 Event to lock the socketList */ SocketInfo *socketList; /* Every open socket in this thread has an * entry on this list. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; static WNDCLASS windowClass; /* * Static functions defined in this file. */ static SocketInfo * CreateSocket(Tcl_Interp *interp, int port, CONST char *host, int server, CONST char *myaddr, int myport, int async); static int CreateSocketAddress(LPSOCKADDR_IN sockaddrPtr, CONST char *host, int port); static void InitSockets(void); static SocketInfo * NewSocketInfo(SOCKET socket); static void SocketExitHandler(ClientData clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static int SocketsEnabled(void); static void TcpAccept(SocketInfo *infoPtr); static int WaitForSocketEvent(SocketInfo *infoPtr, int events, int *errorCodePtr); static DWORD WINAPI SocketThread(LPVOID arg); static void TcpThreadActionProc(ClientData instanceData, int action); static Tcl_EventCheckProc SocketCheckProc; static Tcl_EventProc SocketEventProc; static Tcl_EventSetupProc SocketSetupProc; static Tcl_ExitProc SocketThreadExitHandler; static Tcl_DriverBlockModeProc TcpBlockProc; static Tcl_DriverCloseProc TcpCloseProc; static Tcl_DriverSetOptionProc TcpSetOptionProc; static Tcl_DriverGetOptionProc TcpGetOptionProc; static Tcl_DriverInputProc TcpInputProc; static Tcl_DriverOutputProc TcpOutputProc; static Tcl_DriverWatchProc TcpWatchProc; static Tcl_DriverGetHandleProc TcpGetHandleProc; /* * This structure describes the channel type structure for TCP socket * based IO. */ static Tcl_ChannelType tcpChannelType = { "tcp", /* Type name. */ TCL_CHANNEL_VERSION_4, /* v4 channel */ TcpCloseProc, /* Close proc. */ TcpInputProc, /* Input proc. */ TcpOutputProc, /* Output proc. */ NULL, /* Seek proc. */ TcpSetOptionProc, /* Set option proc. */ TcpGetOptionProc, /* Get option proc. */ TcpWatchProc, /* Set up notifier to watch this channel. */ TcpGetHandleProc, /* Get an OS handle from channel. */ NULL, /* close2proc. */ TcpBlockProc, /* Set socket into (non-)blocking mode. */ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc */ TcpThreadActionProc, /* thread action proc */ }; /* *---------------------------------------------------------------------- * * InitSockets -- * * Initialize the socket module. Attempts to load the wsock32.dll library * and set up the winSock function table. If successful, registers the * event window for the socket notifier code. * * Assumes Mutex is held. * * Results: * None. * * Side effects: * Dynamically loads wsock32.dll, and registers a new window class and * creates a window for use in asynchronous socket notification. * *---------------------------------------------------------------------- */ static void InitSockets() { DWORD id; WSADATA wsaData; DWORD err; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); if (!initialized) { initialized = 1; Tcl_CreateExitHandler(SocketExitHandler, (ClientData) NULL); winSock.hModule = LoadLibraryA("wsock32.dll"); if (winSock.hModule == NULL) { return; } /* * Initialize the function table. */ winSock.accept = (LPFN_ACCEPT) GetProcAddress(winSock.hModule, "accept"); winSock.bind = (LPFN_BIND) |
︙ | ︙ | |||
381 382 383 384 385 386 387 | GetProcAddress(winSock.hModule, "WSAAsyncSelect"); winSock.WSACleanup = (LPFN_WSACLEANUP) GetProcAddress(winSock.hModule, "WSACleanup"); winSock.WSAGetLastError = (LPFN_WSAGETLASTERROR) GetProcAddress(winSock.hModule, "WSAGetLastError"); winSock.WSAStartup = (LPFN_WSASTARTUP) GetProcAddress(winSock.hModule, "WSAStartup"); | | | | < | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 | GetProcAddress(winSock.hModule, "WSAAsyncSelect"); winSock.WSACleanup = (LPFN_WSACLEANUP) GetProcAddress(winSock.hModule, "WSACleanup"); winSock.WSAGetLastError = (LPFN_WSAGETLASTERROR) GetProcAddress(winSock.hModule, "WSAGetLastError"); winSock.WSAStartup = (LPFN_WSASTARTUP) GetProcAddress(winSock.hModule, "WSAStartup"); /* * Now check that all fields are properly initialized. If not, return * zero to indicate that we failed to initialize properly. */ if ((winSock.accept == NULL) || (winSock.bind == NULL) || (winSock.closesocket == NULL) || (winSock.connect == NULL) || (winSock.gethostbyname == NULL) || (winSock.gethostbyaddr == NULL) || (winSock.gethostname == NULL) || |
︙ | ︙ | |||
413 414 415 416 417 418 419 | (winSock.select == NULL) || (winSock.send == NULL) || (winSock.setsockopt == NULL) || (winSock.socket == NULL) || (winSock.WSAAsyncSelect == NULL) || (winSock.WSACleanup == NULL) || (winSock.WSAGetLastError == NULL) || | | < | | | | | | | | | | | | | | | | 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 | (winSock.select == NULL) || (winSock.send == NULL) || (winSock.setsockopt == NULL) || (winSock.socket == NULL) || (winSock.WSAAsyncSelect == NULL) || (winSock.WSACleanup == NULL) || (winSock.WSAGetLastError == NULL) || (winSock.WSAStartup == NULL)) { goto unloadLibrary; } /* * Create the async notification window with a new class. We must * create a new class to avoid a Windows 95 bug that causes us to get * the wrong message number for socket events if the message window is * a subclass of a static control. */ windowClass.style = 0; windowClass.cbClsExtra = 0; windowClass.cbWndExtra = 0; windowClass.hInstance = TclWinGetTclInstance(); windowClass.hbrBackground = NULL; windowClass.lpszMenuName = NULL; windowClass.lpszClassName = "TclSocket"; windowClass.lpfnWndProc = SocketProc; windowClass.hIcon = NULL; windowClass.hCursor = NULL; if (!RegisterClassA(&windowClass)) { TclWinConvertError(GetLastError()); goto unloadLibrary; } /* * Initialize the winsock library and check the interface version * actually loaded. We only ask for the 1.1 interface and do require * that it not be less than 1.1. */ #define WSA_VERSION_MAJOR 1 #define WSA_VERSION_MINOR 1 #define WSA_VERSION_REQD MAKEWORD(WSA_VERSION_MAJOR, WSA_VERSION_MINOR) if ((err = winSock.WSAStartup(WSA_VERSION_REQD, &wsaData)) != 0) { TclWinConvertWSAError(err); goto unloadLibrary; } /* * Note the byte positions are swapped for the comparison, so that * 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101 (1.1). * We want the comparison to be 0x0200 < 0x0101. */ if (MAKEWORD(HIBYTE(wsaData.wVersion), LOBYTE(wsaData.wVersion)) < MAKEWORD(WSA_VERSION_MINOR, WSA_VERSION_MAJOR)) { TclWinConvertWSAError(WSAVERNOTSUPPORTED); winSock.WSACleanup(); goto unloadLibrary; |
︙ | ︙ | |||
484 485 486 487 488 489 490 | if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->socketList = NULL; tsdPtr->hwnd = NULL; tsdPtr->threadId = Tcl_GetCurrentThread(); | | | | | < | | < | | | 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 | if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->socketList = NULL; tsdPtr->hwnd = NULL; tsdPtr->threadId = Tcl_GetCurrentThread(); tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL); tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0, &id); SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); if (tsdPtr->socketThread == NULL) { goto unloadLibrary; } /* * Wait for the thread to signal that the window has been created and * is ready to go. Timeout after twenty seconds. */ if (WaitForSingleObject(tsdPtr->readyEvent, 20000) == WAIT_TIMEOUT) { goto unloadLibrary; } if (tsdPtr->hwnd == NULL) { goto unloadLibrary; } Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); Tcl_CreateThreadExitHandler(SocketThreadExitHandler, NULL); } return; unloadLibrary: if (tsdPtr != NULL && tsdPtr->hwnd != NULL) { SocketThreadExitHandler(0); } FreeLibrary(winSock.hModule); winSock.hModule = NULL; return; } |
︙ | ︙ | |||
573 574 575 576 577 578 579 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void SocketExitHandler(clientData) | | | | > < | | | | > | | | | | | | | | | | | | 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 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void SocketExitHandler(clientData) ClientData clientData; /* Not used. */ { Tcl_MutexLock(&socketMutex); if (winSock.hModule) { /* * Make sure the socket event handling window is cleaned-up for, at * most, this thread. */ SocketThreadExitHandler(clientData); UnregisterClass("TclSocket", TclWinGetTclInstance()); winSock.WSACleanup(); FreeLibrary(winSock.hModule); winSock.hModule = NULL; } initialized = 0; Tcl_MutexUnlock(&socketMutex); } /* *---------------------------------------------------------------------- * * SocketThreadExitHandler -- * * Callback invoked during thread clean up to delete the socket event * source. * * Results: * None. * * Side effects: * Delete the event source. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void SocketThreadExitHandler(clientData) ClientData clientData; /* Not used. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); if (tsdPtr != NULL && tsdPtr->socketThread != NULL) { DWORD exitCode; GetExitCodeThread(tsdPtr->socketThread, &exitCode); if (exitCode == STILL_ACTIVE) { PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0); /* * Wait for the thread to close. This ensures that we are * completely cleaned up before we leave this function. If * Tcl_Finalize was called from DllMain, the thread is in a paused * state so we need to timeout and continue. */ WaitForSingleObject(tsdPtr->socketThread, 100); } CloseHandle(tsdPtr->socketThread); tsdPtr->socketThread = NULL; CloseHandle(tsdPtr->readyEvent); CloseHandle(tsdPtr->socketListLock); Tcl_DeleteThreadExitHandler(SocketThreadExitHandler, NULL); Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL); } } /* *---------------------------------------------------------------------- * * TclpHasSockets -- * * This function determines whether sockets are available on the current * system and returns an error in interp if they are not. Note that * interp may be NULL. * * Results: * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an * error in interp (if non-NULL). * * Side effects: * If not already prepared, initializes the TSD structure and socket * message handling thread associated to the calling thread for the * subsystem of the driver. * *---------------------------------------------------------------------- */ int TclpHasSockets(interp) Tcl_Interp *interp; |
︙ | ︙ | |||
686 687 688 689 690 691 692 | } /* *---------------------------------------------------------------------- * * SocketSetupProc -- * | | | | 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 | } /* *---------------------------------------------------------------------- * * SocketSetupProc -- * * This function is invoked before Tcl_DoOneEvent blocks waiting for an * event. * * Results: * None. * * Side effects: * Adjusts the block time if needed. * |
︙ | ︙ | |||
710 711 712 713 714 715 716 | SocketInfo *infoPtr; Tcl_Time blockTime = { 0, 0 }; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } | | | | | | | 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 | SocketInfo *infoPtr; Tcl_Time blockTime = { 0, 0 }; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } /* * Check to see if there is a ready socket. If so, poll. */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->readyEvents & infoPtr->watchEvents) { Tcl_SetMaxBlockTime(&blockTime); break; } } SetEvent(tsdPtr->socketListLock); } /* *---------------------------------------------------------------------- * * SocketCheckProc -- * * This function is called by Tcl_DoOneEvent to check the socket event * source for events. * * Results: * None. * * Side effects: * May queue an event. * |
︙ | ︙ | |||
755 756 757 758 759 760 761 | SocketInfo *infoPtr; SocketEvent *evPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } | | | | | | | | | | | | | | | 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 | SocketInfo *infoPtr; SocketEvent *evPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } /* * Queue events for any ready sockets that don't already have events * queued (caused by persistent states that won't generate WinSock * events). */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if ((infoPtr->readyEvents & infoPtr->watchEvents) && !(infoPtr->flags & SOCKET_PENDING)) { infoPtr->flags |= SOCKET_PENDING; evPtr = (SocketEvent *) ckalloc(sizeof(SocketEvent)); evPtr->header.proc = SocketEventProc; evPtr->socket = infoPtr->socket; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); } } SetEvent(tsdPtr->socketListLock); } /* *---------------------------------------------------------------------- * * SocketEventProc -- * * This function is called by Tcl_ServiceEvent when a socket event * reaches the front of the event queue. This function is responsible for * notifying the generic channel code. * * Results: * Returns 1 if the event was handled, meaning it should be removed from * the queue. Returns 0 if the event was not handled, meaning it should * stay on the queue. The only time the event isn't handled is if the * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the channel callback functions do. * *---------------------------------------------------------------------- */ static int SocketEventProc(evPtr, flags) Tcl_Event *evPtr; /* Event to service. */ int flags; /* Flags that indicate what events to handle, * such as TCL_FILE_EVENTS. */ { SocketInfo *infoPtr; SocketEvent *eventPtr = (SocketEvent *) evPtr; int mask = 0; int events; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return 0; } /* * Find the specified socket on the socket list. */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->socket == eventPtr->socket) { break; } } SetEvent(tsdPtr->socketListLock); |
︙ | ︙ | |||
847 848 849 850 851 852 853 | if (infoPtr->readyEvents & FD_ACCEPT) { TcpAccept(infoPtr); return 1; } /* | | | | | | | | | | | | | | | > | > > | 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 | if (infoPtr->readyEvents & FD_ACCEPT) { TcpAccept(infoPtr); return 1; } /* * Mask off unwanted events and compute the read/write mask so we can * notify the channel. */ events = infoPtr->readyEvents & infoPtr->watchEvents; if (events & FD_CLOSE) { /* * If the socket was closed and the channel is still interested in * read events, then we need to ensure that we keep polling for this * event until someone does something with the channel. Note that we * do this before calling Tcl_NotifyChannel so we don't have to watch * out for the channel being deleted out from under us. This may cause * a redundant trip through the event loop, but it's simpler than * trying to do unwind protection. */ Tcl_Time blockTime = { 0, 0 }; Tcl_SetMaxBlockTime(&blockTime); mask |= TCL_READABLE|TCL_WRITABLE; } else if (events & FD_READ) { fd_set readFds; struct timeval timeout; /* * We must check to see if data is really available, since someone * could have consumed the data in the meantime. Turn off async * notification so select will work correctly. If the socket is still * readable, notify the channel driver, otherwise reset the async * select handler and keep waiting. */ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); FD_ZERO(&readFds); FD_SET(infoPtr->socket, &readFds); timeout.tv_usec = 0; timeout.tv_sec = 0; if (winSock.select(0, &readFds, NULL, NULL, &timeout) != 0) { mask |= TCL_READABLE; } else { infoPtr->readyEvents &= ~(FD_READ); SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); } } if (events & (FD_WRITE | FD_CONNECT)) { mask |= TCL_WRITABLE; if (events & FD_CONNECT && infoPtr->lastError != NO_ERROR) { /* * Connect errors should also fire the readable handler. */ mask |= TCL_READABLE; } } if (mask) { Tcl_NotifyChannel(infoPtr->channel, mask); } |
︙ | ︙ | |||
929 930 931 932 933 934 935 | *---------------------------------------------------------------------- */ static int TcpBlockProc(instanceData, mode) ClientData instanceData; /* The socket to block/un-block. */ int mode; /* TCL_MODE_BLOCKING or | | | | | | | | | < < | | | | | | | | | > | > > < < < < < < < < < < | < | | 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 | *---------------------------------------------------------------------- */ static int TcpBlockProc(instanceData, mode) ClientData instanceData; /* The socket to block/un-block. */ int mode; /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { SocketInfo *infoPtr = (SocketInfo *) instanceData; if (mode == TCL_MODE_NONBLOCKING) { infoPtr->flags |= SOCKET_ASYNC; } else { infoPtr->flags &= ~(SOCKET_ASYNC); } return 0; } /* *---------------------------------------------------------------------- * * TcpCloseProc -- * * This function is called by the generic IO level to perform channel * type specific cleanup on a socket based channel when the channel is * closed. * * Results: * 0 if successful, the value of errno if failed. * * Side effects: * Closes the socket. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TcpCloseProc(instanceData, interp) ClientData instanceData; /* The socket to close. */ Tcl_Interp *interp; /* Unused. */ { SocketInfo *infoPtr = (SocketInfo *) instanceData; /* TIP #218 */ int errorCode = 0; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Check that WinSock is initialized; do not call it if not, to prevent * system crashes. This can happen at exit time if the exit handler for * WinSock ran before other exit handlers that want to use sockets. */ if (SocketsEnabled()) { /* * Clean up the OS socket handle. The default Windows setting for a * socket is SO_DONTLINGER, which does a graceful shutdown in the * background. */ if (winSock.closesocket(infoPtr->socket) == SOCKET_ERROR) { TclWinConvertWSAError((DWORD) winSock.WSAGetLastError()); errorCode = Tcl_GetErrno(); } } /* * TIP #218. Removed the code removing the structure from the global * socket list. This is now done by the thread action callbacks, and only * there. This happens before this code is called. We can free without * fear of damaging the list. */ ckfree((char *) infoPtr); return errorCode; } /* *---------------------------------------------------------------------- * * NewSocketInfo -- * * This function allocates and initializes a new SocketInfo structure. * * Results: * Returns a newly allocated SocketInfo. * * Side effects: * None, except for allocation of memory. * *---------------------------------------------------------------------- */ static SocketInfo * NewSocketInfo(socket) SOCKET socket; |
︙ | ︙ | |||
1045 1046 1047 1048 1049 1050 1051 | infoPtr->readyEvents = 0; infoPtr->selectEvents = 0; infoPtr->acceptEventCount = 0; infoPtr->acceptProc = NULL; infoPtr->acceptProcData = NULL; infoPtr->lastError = 0; | > > > > > | | < < | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | > | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | 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 | infoPtr->readyEvents = 0; infoPtr->selectEvents = 0; infoPtr->acceptEventCount = 0; infoPtr->acceptProc = NULL; infoPtr->acceptProcData = NULL; infoPtr->lastError = 0; /* * TIP #218. Removed the code inserting the new structure into the global * list. This is now handled in the thread action callbacks, and only * there. */ infoPtr->nextPtr = NULL; return infoPtr; } /* *---------------------------------------------------------------------- * * CreateSocket -- * * This function opens a new socket and initializes the SocketInfo * structure. * * Results: * Returns a new SocketInfo, or NULL with an error in interp. * * Side effects: * None, except for allocation of memory. * *---------------------------------------------------------------------- */ static SocketInfo * CreateSocket(interp, port, host, server, myaddr, myport, async) Tcl_Interp *interp; /* For error reporting; can be NULL. */ int port; /* Port number to open. */ CONST char *host; /* Name of host on which to open port. */ int server; /* 1 if socket should be a server socket, else * 0 for a client socket. */ CONST char *myaddr; /* Optional client-side address */ int myport; /* Optional client-side port */ int async; /* If nonzero, connect client socket * asynchronously. */ { u_long flag = 1; /* Indicates nonblocking mode. */ int asyncConnect = 0; /* Will be 1 if async connect is in * progress. */ SOCKADDR_IN sockaddr; /* Socket address */ SOCKADDR_IN mysockaddr; /* Socket address for client */ SOCKET sock; SocketInfo *infoPtr; /* The returned value. */ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); /* * Check that WinSock is initialized; do not call it if not, to prevent * system crashes. This can happen at exit time if the exit handler for * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { return NULL; } if (!CreateSocketAddress(&sockaddr, host, port)) { goto error; } if ((myaddr != NULL || myport != 0) && !CreateSocketAddress(&mysockaddr, myaddr, myport)) { goto error; } sock = winSock.socket(AF_INET, SOCK_STREAM, 0); if (sock == INVALID_SOCKET) { goto error; } /* * Win-NT has a misfeature that sockets are inherited in child processes * by default. Turn off the inherit bit. */ SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); /* * Set kernel space buffering */ TclSockMinimumBuffers((int) sock, TCP_BUFFER_SIZE); if (server) { /* * Bind to the specified port. Note that we must not call setsockopt * with SO_REUSEADDR because Microsoft allows addresses to be reused * even if they are still in use. * * Bind should not be affected by the socket having already been set * into nonblocking mode. If there is trouble, this is one place to * look for bugs. */ if (winSock.bind(sock, (SOCKADDR *) &sockaddr, sizeof(SOCKADDR_IN)) == SOCKET_ERROR) { goto error; } /* * Set the maximum number of pending connect requests to the max value * allowed on each platform (Win32 and Win32s may be different, and * there may be differences between TCP/IP stacks). */ if (winSock.listen(sock, SOMAXCONN) == SOCKET_ERROR) { goto error; } /* * Add this socket to the global list of sockets. */ infoPtr = NewSocketInfo(sock); /* * Set up the select mask for connection request events. */ infoPtr->selectEvents = FD_ACCEPT; infoPtr->watchEvents |= FD_ACCEPT; } else { /* * Try to bind to a local port, if specified. */ if (myaddr != NULL || myport != 0) { if (winSock.bind(sock, (SOCKADDR *) &mysockaddr, sizeof(SOCKADDR_IN)) == SOCKET_ERROR) { goto error; } } /* * Set the socket into nonblocking mode if the connect should be done * in the background. */ if (async) { if (winSock.ioctlsocket(sock, (long) FIONBIO, &flag) == SOCKET_ERROR) { goto error; } } /* * Attempt to connect to the remote socket. */ if (winSock.connect(sock, (SOCKADDR *) &sockaddr, sizeof(SOCKADDR_IN)) == SOCKET_ERROR) { TclWinConvertWSAError((DWORD) winSock.WSAGetLastError()); if (Tcl_GetErrno() != EWOULDBLOCK) { goto error; } /* * The connection is progressing in the background. */ asyncConnect = 1; } /* * Add this socket to the global list of sockets. */ infoPtr = NewSocketInfo(sock); /* * Set up the select mask for read/write events. If the connect * attempt has not completed, include connect events. */ infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; if (asyncConnect) { infoPtr->flags |= SOCKET_ASYNC_CONNECT; infoPtr->selectEvents |= FD_CONNECT; } } /* * Register for interest in events in the select mask. Note that this * automatically places the socket into non-blocking mode. */ winSock.ioctlsocket(sock, (long) FIONBIO, &flag); SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); return infoPtr; error: TclWinConvertWSAError((DWORD) winSock.WSAGetLastError()); if (interp != NULL) { Tcl_AppendResult(interp, "couldn't open socket: ", Tcl_PosixError(interp), (char *) NULL); } if (sock != INVALID_SOCKET) { winSock.closesocket(sock); } return NULL; } /* *---------------------------------------------------------------------- * * CreateSocketAddress -- * * This function initializes a sockaddr structure for a host and port. * * Results: * 1 if the host was valid, 0 if the host could not be converted to an IP * address. * * Side effects: * Fills in the *sockaddrPtr structure. * *---------------------------------------------------------------------- */ static int CreateSocketAddress(sockaddrPtr, host, port) LPSOCKADDR_IN sockaddrPtr; /* Socket address */ CONST char *host; /* Host. NULL implies INADDR_ANY */ int port; /* Port number */ { struct hostent *hostent; /* Host database entry */ struct in_addr addr; /* For 64/32 bit madness */ /* * Check that WinSock is initialized; do not call it if not, to prevent * system crashes. This can happen at exit time if the exit handler for * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { Tcl_SetErrno(EFAULT); return 0; } ZeroMemory(sockaddrPtr, sizeof(SOCKADDR_IN)); sockaddrPtr->sin_family = AF_INET; sockaddrPtr->sin_port = winSock.htons((u_short) (port & 0xFFFF)); if (host == NULL) { addr.s_addr = INADDR_ANY; } else { addr.s_addr = winSock.inet_addr(host); if (addr.s_addr == INADDR_NONE) { hostent = winSock.gethostbyname(host); if (hostent != NULL) { memcpy(&addr, hostent->h_addr, (size_t) hostent->h_length); } else { #ifdef EHOSTUNREACH Tcl_SetErrno(EHOSTUNREACH); #else #ifdef ENXIO Tcl_SetErrno(ENXIO); #endif #endif return 0; /* Error. */ } } } /* * NOTE: On 64 bit machines the assignment below is rumored to not do the * right thing. Please report errors related to this if you observe * incorrect behavior on 64 bit machines such as DEC Alphas. Should we * modify this code to do an explicit memcpy? */ sockaddrPtr->sin_addr.s_addr = addr.s_addr; return 1; /* Success. */ } /* *---------------------------------------------------------------------- * * WaitForSocketEvent -- * |
︙ | ︙ | |||
1349 1350 1351 1352 1353 1354 1355 | WaitForSocketEvent(infoPtr, events, errorCodePtr) SocketInfo *infoPtr; /* Information about this socket. */ int events; /* Events to look for. */ int *errorCodePtr; /* Where to store errors? */ { int result = 1; int oldMode; | | | | < > | | | | | | | | | | | 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 | WaitForSocketEvent(infoPtr, events, errorCodePtr) SocketInfo *infoPtr; /* Information about this socket. */ int events; /* Events to look for. */ int *errorCodePtr; /* Where to store errors? */ { int result = 1; int oldMode; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); /* * Be sure to disable event servicing so we are truly modal. */ oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); /* * Reset WSAAsyncSelect so we have a fresh set of events pending. */ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); while (1) { if (infoPtr->lastError) { *errorCodePtr = infoPtr->lastError; result = 0; break; } else if (infoPtr->readyEvents & events) { break; } else if (infoPtr->flags & SOCKET_ASYNC) { *errorCodePtr = EWOULDBLOCK; result = 0; break; } /* * Wait until something happens. */ WaitForSingleObject(tsdPtr->readyEvent, INFINITE); } (void) Tcl_SetServiceMode(oldMode); return result; } /* *---------------------------------------------------------------------- * * Tcl_OpenTcpClient -- * * Opens a TCP client socket and creates a channel around it. * * Results: * The channel or NULL if failed. An error message is returned in the * interpreter on failure. * * Side effects: * Opens a client socket and creates a new channel. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async) Tcl_Interp *interp; /* For error reporting; can be NULL. */ int port; /* Port number to open. */ CONST char *host; /* Host on which to open port. */ CONST char *myaddr; /* Client-side address */ int myport; /* Client-side port */ int async; /* If nonzero, should connect client socket * asynchronously. */ { SocketInfo *infoPtr; char channelName[16 + TCL_INTEGER_SPACE]; if (TclpHasSockets(interp) != TCL_OK) { return NULL; } |
︙ | ︙ | |||
1441 1442 1443 1444 1445 1446 1447 | wsprintfA(channelName, "sock%d", infoPtr->socket); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation", "auto crlf") == TCL_ERROR) { | | | | | | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 | wsprintfA(channelName, "sock%d", infoPtr->socket); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation", "auto crlf") == TCL_ERROR) { Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); return (Tcl_Channel) NULL; } if (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "") == TCL_ERROR) { Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); return (Tcl_Channel) NULL; } return infoPtr->channel; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 | *---------------------------------------------------------------------- * * Tcl_OpenTcpServer -- * * Opens a TCP server socket and creates a channel around it. * * Results: | | | | < | | | > | | | 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 | *---------------------------------------------------------------------- * * Tcl_OpenTcpServer -- * * Opens a TCP server socket and creates a channel around it. * * Results: * The channel or NULL if failed. An error message is returned in the * interpreter on failure. * * Side effects: * Opens a server socket and creates a new channel. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_OpenTcpServer(interp, port, host, acceptProc, acceptProcData) Tcl_Interp *interp; /* For error reporting - may be NULL. */ int port; /* Port number to open. */ CONST char *host; /* Name of local host. */ Tcl_TcpAcceptProc *acceptProc; /* Callback for accepting connections from new * clients. */ ClientData acceptProcData; /* Data for the callback. */ { SocketInfo *infoPtr; char channelName[16 + TCL_INTEGER_SPACE]; if (TclpHasSockets(interp) != TCL_OK) { return NULL; } |
︙ | ︙ | |||
1559 1560 1561 1562 1563 1564 1565 | wsprintfA(channelName, "sock%d", infoPtr->socket); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, (ClientData) infoPtr, 0); if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "") == TCL_ERROR) { | | | > | | < | | | | | | | | | 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 | wsprintfA(channelName, "sock%d", infoPtr->socket); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, (ClientData) infoPtr, 0); if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "") == TCL_ERROR) { Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); return (Tcl_Channel) NULL; } return infoPtr->channel; } /* *---------------------------------------------------------------------- * * TcpAccept -- * * Accept a TCP socket connection. This is called by SocketEventProc and * it in turns calls the registered accept function. * * Results: * None. * * Side effects: * Invokes the accept proc which may invoke arbitrary Tcl code. * *---------------------------------------------------------------------- */ static void TcpAccept(infoPtr) SocketInfo *infoPtr; /* Socket to accept. */ { SOCKET newSocket; SocketInfo *newInfoPtr; SOCKADDR_IN addr; int len; char channelName[16 + TCL_INTEGER_SPACE]; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); /* * Accept the incoming connection request. */ len = sizeof(SOCKADDR_IN); newSocket = winSock.accept(infoPtr->socket, (SOCKADDR *)&addr, &len); /* * Clear the ready mask so we can detect the next connection request. * Note that connection requests are level triggered, so if there is a * request already pending, a new event will be generated. */ if (newSocket == INVALID_SOCKET) { infoPtr->acceptEventCount = 0; infoPtr->readyEvents &= ~(FD_ACCEPT); return; } /* * It is possible that more than one FD_ACCEPT has been sent, so an extra * count must be kept. Decrement the count, and reset the readyEvent bit * if the count is no longer > 0. */ infoPtr->acceptEventCount--; if (infoPtr->acceptEventCount <= 0) { infoPtr->readyEvents &= ~(FD_ACCEPT); } /* * Win-NT has a misfeature that sockets are inherited in child processes * by default. Turn off the inherit bit. */ SetHandleInformation((HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0); /* * Add this socket to the global list of sockets. */ newInfoPtr = NewSocketInfo(newSocket); |
︙ | ︙ | |||
1664 1665 1666 1667 1668 1669 1670 | if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "") == TCL_ERROR) { Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel); return; } /* | | | < | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | 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 | if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "") == TCL_ERROR) { Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel); return; } /* * Invoke the accept callback function. */ if (infoPtr->acceptProc != NULL) { (infoPtr->acceptProc) (infoPtr->acceptProcData, newInfoPtr->channel, winSock.inet_ntoa(addr.sin_addr), winSock.ntohs(addr.sin_port)); } } /* *---------------------------------------------------------------------- * * TcpInputProc -- * * This function is called by the generic IO level to read data from a * socket based channel. * * Results: * The number of bytes read or -1 on error. * * Side effects: * Consumes input from the socket. * *---------------------------------------------------------------------- */ static int TcpInputProc(instanceData, buf, toRead, errorCodePtr) ClientData instanceData; /* The socket state. */ char *buf; /* Where to store data. */ int toRead; /* Maximum number of bytes to read. */ int *errorCodePtr; /* Where to store error codes. */ { SocketInfo *infoPtr = (SocketInfo *) instanceData; int bytesRead; DWORD error; ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); *errorCodePtr = 0; /* * Check that WinSock is initialized; do not call it if not, to prevent * system crashes. This can happen at exit time if the exit handler for * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { *errorCodePtr = EFAULT; return -1; } /* * First check to see if EOF was already detected, to prevent calling the * socket stack after the first time EOF is detected. */ if (infoPtr->flags & SOCKET_EOF) { return 0; } /* * Check to see if the socket is connected before trying to read. */ if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) && ! WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { return -1; } /* * No EOF, and it is connected, so try to read more from the socket. Note * that we clear the FD_READ bit because read events are level triggered * so a new event will be generated if there is still data available to be * read. We have to simulate blocking behavior here since we are always * using non-blocking sockets. */ while (1) { SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); bytesRead = winSock.recv(infoPtr->socket, buf, toRead, 0); infoPtr->readyEvents &= ~(FD_READ); /* * Check for end-of-file condition or successful read. */ if (bytesRead == 0) { infoPtr->flags |= SOCKET_EOF; } if (bytesRead != SOCKET_ERROR) { break; } /* * If an error occurs after the FD_CLOSE has arrived, then ignore the * error and report an EOF. */ if (infoPtr->readyEvents & FD_CLOSE) { infoPtr->flags |= SOCKET_EOF; bytesRead = 0; break; } /* * Check for error condition or underflow in non-blocking case. */ error = winSock.WSAGetLastError(); if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) { TclWinConvertWSAError(error); *errorCodePtr = Tcl_GetErrno(); bytesRead = -1; break; } /* * In the blocking case, wait until the file becomes readable or * closed and try again. */ if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) { bytesRead = -1; break; } } SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); return bytesRead; } /* *---------------------------------------------------------------------- * * TcpOutputProc -- * * This function is called by the generic IO level to write data to a * socket based channel. * * Results: * The number of bytes written or -1 on failure. * * Side effects: * Produces output on the socket. * *---------------------------------------------------------------------- */ static int TcpOutputProc(instanceData, buf, toWrite, errorCodePtr) ClientData instanceData; /* The socket state. */ CONST char *buf; /* Where to get data. */ int toWrite; /* Maximum number of bytes to write. */ int *errorCodePtr; /* Where to store error codes. */ { SocketInfo *infoPtr = (SocketInfo *) instanceData; int bytesWritten; DWORD error; ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); *errorCodePtr = 0; /* * Check that WinSock is initialized; do not call it if not, to prevent * system crashes. This can happen at exit time if the exit handler for * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { *errorCodePtr = EFAULT; return -1; } /* * Check to see if the socket is connected before trying to write. */ if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) && ! WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { return -1; } while (1) { SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); bytesWritten = winSock.send(infoPtr->socket, buf, toWrite, 0); if (bytesWritten != SOCKET_ERROR) { /* * Since Windows won't generate a new write event until we hit an * overflow condition, we need to force the event loop to poll * until the condition changes. */ if (infoPtr->watchEvents & FD_WRITE) { Tcl_Time blockTime = { 0, 0 }; Tcl_SetMaxBlockTime(&blockTime); } break; } /* * Check for error condition or overflow. In the event of overflow, we * need to clear the FD_WRITE flag so we can detect the next writable * event. Note that Windows only sends a new writable event after a * send fails with WSAEWOULDBLOCK. */ error = winSock.WSAGetLastError(); if (error == WSAEWOULDBLOCK) { infoPtr->readyEvents &= ~(FD_WRITE); if (infoPtr->flags & SOCKET_ASYNC) { *errorCodePtr = EWOULDBLOCK; bytesWritten = -1; break; } } else { TclWinConvertWSAError(error); *errorCodePtr = Tcl_GetErrno(); bytesWritten = -1; break; } /* * In the blocking case, wait until the file becomes writable or * closed and try again. */ if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) { bytesWritten = -1; break; } } SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); return bytesWritten; } /* *---------------------------------------------------------------------- * * TcpSetOptionProc -- |
︙ | ︙ | |||
1943 1944 1945 1946 1947 1948 1949 | SocketInfo *infoPtr; SOCKET sock; /* BOOL val = FALSE; int boolVar, rtn; */ /* | | | | < | | 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 | SocketInfo *infoPtr; SOCKET sock; /* BOOL val = FALSE; int boolVar, rtn; */ /* * Check that WinSock is initialized; do not call it if not, to prevent * system crashes. This can happen at exit time if the exit handler for * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { if (interp) { Tcl_AppendResult(interp, "winsock is not initialized", NULL); } return TCL_ERROR; } infoPtr = (SocketInfo *) instanceData; sock = infoPtr->socket; /* if (!stricmp(optionName, "-keepalive")) { |
︙ | ︙ | |||
2005 2006 2007 2008 2009 2010 2011 | } /* *---------------------------------------------------------------------- * * TcpGetOptionProc -- * | | | | | < | | | < | | | | | | | < | | | | < | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | < | | | | < | | | < | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * TcpGetOptionProc -- * * Computes an option value for a TCP socket based channel, or a list of * all options and their values. * * Note: This code is based on code contributed by John Haxby. * * Results: * A standard Tcl result. The value of the specified option or a list of * all options and their values is returned in the supplied DString. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TcpGetOptionProc(instanceData, interp, optionName, dsPtr) ClientData instanceData; /* Socket state. */ Tcl_Interp *interp; /* For error reporting - can be NULL */ CONST char *optionName; /* Name of the option to retrieve the value * for, or NULL to get all options and their * values. */ Tcl_DString *dsPtr; /* Where to store the computed value; * initialized by caller. */ { SocketInfo *infoPtr; SOCKADDR_IN sockname; SOCKADDR_IN peername; struct hostent *hostEntPtr; SOCKET sock; int size = sizeof(SOCKADDR_IN); size_t len = 0; char buf[TCL_INTEGER_SPACE]; /* * Check that WinSock is initialized; do not call it if not, to prevent * system crashes. This can happen at exit time if the exit handler for * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { if (interp) { Tcl_AppendResult(interp, "winsock is not initialized", NULL); } return TCL_ERROR; } infoPtr = (SocketInfo *) instanceData; sock = (int) infoPtr->socket; if (optionName != (char *) NULL) { len = strlen(optionName); } if ((len > 1) && (optionName[1] == 'e') && (strncmp(optionName, "-error", len) == 0)) { int optlen; DWORD err; int ret; optlen = sizeof(int); ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR, (char *)&err, &optlen); if (ret == SOCKET_ERROR) { err = winSock.WSAGetLastError(); } if (err) { TclWinConvertWSAError(err); Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); } return TCL_OK; } if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { if (winSock.getpeername(sock, (LPSOCKADDR) &peername, &size) == 0) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } Tcl_DStringAppendElement(dsPtr, winSock.inet_ntoa(peername.sin_addr)); if (peername.sin_addr.s_addr == 0) { hostEntPtr = (struct hostent *) NULL; } else { hostEntPtr = winSock.gethostbyaddr( (char *) &(peername.sin_addr), sizeof(peername.sin_addr), AF_INET); } if (hostEntPtr != (struct hostent *) NULL) { Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); } else { Tcl_DStringAppendElement(dsPtr, winSock.inet_ntoa(peername.sin_addr)); } TclFormatInt(buf, winSock.ntohs(peername.sin_port)); Tcl_DStringAppendElement(dsPtr, buf); if (len == 0) { Tcl_DStringEndSublist(dsPtr); } else { return TCL_OK; } } else { /* * getpeername failed - but if we were asked for all the options * (len==0), don't flag an error at that point because it could be * an fconfigure request on a server socket (which have no peer). * {Copied from unix/tclUnixChan.c} */ if (len) { TclWinConvertWSAError((DWORD) winSock.WSAGetLastError()); if (interp) { Tcl_AppendResult(interp, "can't get peername: ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } } } if ((len == 0) || ((len > 1) && (optionName[1] == 's') && (strncmp(optionName, "-sockname", len) == 0))) { if (winSock.getsockname(sock, (LPSOCKADDR) &sockname, &size) == 0) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-sockname"); Tcl_DStringStartSublist(dsPtr); } Tcl_DStringAppendElement(dsPtr, winSock.inet_ntoa(sockname.sin_addr)); if (sockname.sin_addr.s_addr == 0) { hostEntPtr = (struct hostent *) NULL; } else { hostEntPtr = winSock.gethostbyaddr( (char *) &(sockname.sin_addr), sizeof(peername.sin_addr), AF_INET); } if (hostEntPtr != (struct hostent *) NULL) { Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); } else { Tcl_DStringAppendElement(dsPtr, winSock.inet_ntoa(sockname.sin_addr)); } TclFormatInt(buf, winSock.ntohs(sockname.sin_port)); Tcl_DStringAppendElement(dsPtr, buf); if (len == 0) { Tcl_DStringEndSublist(dsPtr); } else { return TCL_OK; } } else { if (interp) { TclWinConvertWSAError((DWORD) winSock.WSAGetLastError()); Tcl_AppendResult(interp, "can't get sockname: ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } } /* if (len == 0 || !strncmp(optionName, "-keepalive", len)) { int optlen; BOOL opt = FALSE; if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-keepalive"); } optlen = sizeof(BOOL); winSock.getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen); if (opt) { Tcl_DStringAppendElement(dsPtr, "1"); } else { Tcl_DStringAppendElement(dsPtr, "0"); } if (len > 0) { return TCL_OK; } } if (len == 0 || !strncmp(optionName, "-nagle", len)) { int optlen; BOOL opt = FALSE; if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-nagle"); } optlen = sizeof(BOOL); winSock.getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, &optlen); if (opt) { Tcl_DStringAppendElement(dsPtr, "0"); } else { Tcl_DStringAppendElement(dsPtr, "1"); } if (len > 0) { return TCL_OK; } } */ if (len > 0) { /*return Tcl_BadChannelOption(interp, optionName, "peername sockname keepalive nagle");*/ return Tcl_BadChannelOption(interp, optionName, "peername sockname"); } return TCL_OK; } /* *---------------------------------------------------------------------- * * TcpWatchProc -- * * Informs the channel driver of the events that the generic channel code * wishes to receive on this socket. * * Results: * None. * * Side effects: * May cause the notifier to poll if any of the specified conditions are * already true. * *---------------------------------------------------------------------- */ static void TcpWatchProc(instanceData, mask) ClientData instanceData; /* The socket state. */ int mask; /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { SocketInfo *infoPtr = (SocketInfo *) instanceData; /* * Update the watch events mask. Only if the socket is not a server * socket. Fix for SF Tcl Bug #557878. */ if (!infoPtr->acceptProc) { infoPtr->watchEvents = 0; if (mask & TCL_READABLE) { infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT); } if (mask & TCL_WRITABLE) { infoPtr->watchEvents |= (FD_WRITE|FD_CLOSE|FD_CONNECT); } /* * If there are any conditions already set, then tell the notifier to * poll rather than block. */ if (infoPtr->readyEvents & infoPtr->watchEvents) { Tcl_Time blockTime = { 0, 0 }; Tcl_SetMaxBlockTime(&blockTime); } } |
︙ | ︙ | |||
2327 2328 2329 2330 2331 2332 2333 | static DWORD WINAPI SocketThread(LPVOID arg) { MSG msg; ThreadSpecificData *tsdPtr = (ThreadSpecificData *)(arg); | | | | | | | 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 | static DWORD WINAPI SocketThread(LPVOID arg) { MSG msg; ThreadSpecificData *tsdPtr = (ThreadSpecificData *)(arg); tsdPtr->hwnd = CreateWindow("TclSocket", "TclSocket", WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg); /* * Signal the main thread that the window has been created and that the * socket thread is ready to go. */ SetEvent(tsdPtr->readyEvent); if (tsdPtr->hwnd == NULL) { return 1; } /* * Process all messages on the socket window until WM_QUIT. */ |
︙ | ︙ | |||
2358 2359 2360 2361 2362 2363 2364 | /* *---------------------------------------------------------------------- * * SocketProc -- * | | | < | | | 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 | /* *---------------------------------------------------------------------- * * SocketProc -- * * This function is called when WSAAsyncSelect has been used to register * interest in a socket event, and the event has occurred. * * Results: * 0 on success. * * Side effects: * The flags for the given socket are updated to reflect the event that * occured. * *---------------------------------------------------------------------- */ static LRESULT CALLBACK SocketProc(hwnd, message, wParam, lParam) HWND hwnd; |
︙ | ︙ | |||
2390 2391 2392 2393 2394 2395 2396 | #ifdef _WIN64 (ThreadSpecificData *) GetWindowLongPtr(hwnd, GWLP_USERDATA); #else (ThreadSpecificData *) GetWindowLong(hwnd, GWL_USERDATA); #endif switch (message) { | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | < | < > | < | | < > > | | < > > | < < | < | | > > | | < | > > > > > > | < | < < < | > > > > | > > | | | < | > > | > | > | > > > | | | | | | | | < | | | | | < > | | | | < | | | | < > | < < | | < | | < | | | > | > > > > > | > > > > | > > > > | > > > > | > | < < | | | < < | | | | | | | | | > | | | | | | | | < < < | < < | | | < < < < > | < < < < < < < < < | < < < < < < < < < < < < | | < < | < | < < < | | < < < | < | < < | < < < < | | < | < < < < | 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 | #ifdef _WIN64 (ThreadSpecificData *) GetWindowLongPtr(hwnd, GWLP_USERDATA); #else (ThreadSpecificData *) GetWindowLong(hwnd, GWL_USERDATA); #endif switch (message) { default: return DefWindowProc(hwnd, message, wParam, lParam); break; case WM_CREATE: /* * store the initial tsdPtr, it's from a different thread, so it's not * directly accessible, but needed. */ #ifdef _WIN64 SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) ((LPCREATESTRUCT)lParam)->lpCreateParams); #else SetWindowLong(hwnd, GWL_USERDATA, (LONG) ((LPCREATESTRUCT)lParam)->lpCreateParams); #endif break; case WM_DESTROY: PostQuitMessage(0); break; case SOCKET_MESSAGE: event = WSAGETSELECTEVENT(lParam); error = WSAGETSELECTERROR(lParam); socket = (SOCKET) wParam; /* * Find the specified socket on the socket list and update its * eventState flag. */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->socket == socket) { /* * Update the socket state. */ /* * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event * happens, then clear the FD_ACCEPT count. Otherwise, * increment the count if the current event is an FD_ACCEPT. */ if (event & FD_CLOSE) { infoPtr->acceptEventCount = 0; infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); } else if (event & FD_ACCEPT) { infoPtr->acceptEventCount++; } if (event & FD_CONNECT) { /* * The socket is now connected, clear the async connect * flag. */ infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); /* * Remember any error that occurred so we can report * connection failures. */ if (error != ERROR_SUCCESS) { TclWinConvertWSAError((DWORD) error); infoPtr->lastError = Tcl_GetErrno(); } } if (infoPtr->flags & SOCKET_ASYNC_CONNECT) { infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); if (error != ERROR_SUCCESS) { TclWinConvertWSAError((DWORD) error); infoPtr->lastError = Tcl_GetErrno(); } infoPtr->readyEvents |= FD_WRITE; } infoPtr->readyEvents |= event; /* * Wake up the Main Thread. */ SetEvent(tsdPtr->readyEvent); Tcl_ThreadAlert(tsdPtr->threadId); break; } } SetEvent(tsdPtr->socketListLock); break; case SOCKET_SELECT: infoPtr = (SocketInfo *) lParam; if (wParam == SELECT) { winSock.WSAAsyncSelect(infoPtr->socket, hwnd, SOCKET_MESSAGE, infoPtr->selectEvents); } else { /* * Clear the selection mask */ winSock.WSAAsyncSelect(infoPtr->socket, hwnd, 0, 0); } break; case SOCKET_TERMINATE: DestroyWindow(hwnd); break; } return 0; } /* *---------------------------------------------------------------------- * * Tcl_GetHostName -- * * Returns the name of the local host. * * Results: * A string containing the network name for this machine. The caller must * not modify or free this string. * * Side effects: * Caches the name to return for future calls. * *---------------------------------------------------------------------- */ CONST char * Tcl_GetHostName() { return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); } /* *---------------------------------------------------------------------- * * InitializeHostName -- * * This routine sets the process global value of the name of the local * host on which the process is running. * * Results: * None. * *---------------------------------------------------------------------- */ void InitializeHostName(valuePtr, lengthPtr, encodingPtr) char **valuePtr; int *lengthPtr; Tcl_Encoding *encodingPtr; { WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1]; DWORD length = sizeof(wbuf) / sizeof(WCHAR); Tcl_DString ds; if ((*tclWinProcs->getComputerNameProc)(wbuf, &length) != 0) { /* * Convert string from native to UTF then change to lowercase. */ Tcl_UtfToLower(Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds)); } else if (TclpHasSockets(NULL) == TCL_OK) { /* * Buffer length of 255 copied slavishly from previous version of this * routine. Presumably there's a more "correct" macro value for a * properly sized buffer for a gethostname() call. Maintainers are * welcome to supply it. */ Tcl_DStringInit(&ds); Tcl_DStringSetLength(&ds, 255); if (winSock.gethostname(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)) == 0) { Tcl_DStringSetLength(&ds, 0); } } *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); *lengthPtr = Tcl_DStringLength(&ds); *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1); memcpy((VOID *) *valuePtr, (VOID *) Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1); Tcl_DStringFree(&ds); } /* *---------------------------------------------------------------------- * * TclWinGetSockOpt, et al. -- * * These functions are wrappers that let us bind the WinSock API * dynamically so we can run on systems that don't have the wsock32.dll. * We need wrappers for these interfaces because they are called from the * generic Tcl code. * * Results: * As defined for each function. * * Side effects: * As defined for each function. * *---------------------------------------------------------------------- */ int TclWinGetSockOpt(SOCKET s, int level, int optname, char * optval, int FAR *optlen) { /* * Check that WinSock is initialized; do not call it if not, to prevent * system crashes. This can happen at exit time if the exit handler for * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { return SOCKET_ERROR; } return winSock.getsockopt(s, level, optname, optval, optlen); } int TclWinSetSockOpt(SOCKET s, int level, int optname, const char * optval, int optlen) { /* * Check that WinSock is initialized; do not call it if not, to prevent * system crashes. This can happen at exit time if the exit handler for * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { return SOCKET_ERROR; } return winSock.setsockopt(s, level, optname, optval, optlen); } u_short TclWinNToHS(u_short netshort) { /* * Check that WinSock is initialized; do not call it if not, to prevent * system crashes. This can happen at exit time if the exit handler for * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { return (u_short) -1; } return winSock.ntohs(netshort); } struct servent * TclWinGetServByName(const char * name, const char * proto) { /* * Check that WinSock is initialized; do not call it if not, to prevent * system crashes. This can happen at exit time if the exit handler for * WinSock ran before other exit handlers that want to use sockets. */ if (!SocketsEnabled()) { return (struct servent *) NULL; } return winSock.getservbyname(name, proto); } /* *---------------------------------------------------------------------- * * TcpThreadActionProc -- * * Insert or remove any thread local refs to this channel. * * Results: * None. * * Side effects: * Changes thread local list of valid channels. * *---------------------------------------------------------------------- */ static void TcpThreadActionProc (instanceData, action) ClientData instanceData; int action; { ThreadSpecificData *tsdPtr; SocketInfo *infoPtr = (SocketInfo *) instanceData; int notifyCmd; if (action == TCL_CHANNEL_THREAD_INSERT) { /* * Ensure that socket subsystem is initialized in this thread, or else * sockets will not work. */ Tcl_MutexLock(&socketMutex); InitSockets(); Tcl_MutexUnlock(&socketMutex); tsdPtr = TCL_TSD_INIT(&dataKey); WaitForSingleObject(tsdPtr->socketListLock, INFINITE); infoPtr->nextPtr = tsdPtr->socketList; tsdPtr->socketList = infoPtr; SetEvent(tsdPtr->socketListLock); notifyCmd = SELECT; } else { SocketInfo **nextPtrPtr; int removed = 0; tsdPtr = TCL_TSD_INIT(&dataKey); /* * TIP #218, Bugfix: All access to socketList has to be protected by * the lock. */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL; nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { if ((*nextPtrPtr) == infoPtr) { (*nextPtrPtr) = infoPtr->nextPtr; removed = 1; break; } } SetEvent(tsdPtr->socketListLock); /* * This could happen if the channel was created in one thread and then * moved to another without updating the thread local data in each * thread. */ if (!removed) { Tcl_Panic("file info ptr not on thread channel list"); } notifyCmd = UNSELECT; } /* * Ensure that, or stop, notifications for the socket occur in this * thread. */ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) notifyCmd, (LPARAM) infoPtr); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinThrd.c.
|
| | | | | | | | | | | | | | | < | | | | | | | | | | | > > > > > > > > > > > > > > | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | /* * tclWinThread.c -- * * This file implements the Windows-specific thread operations. * * Copyright (c) 1998 by Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinThrd.c,v 1.34.2.6 2005/08/15 18:14:16 dgp Exp $ */ #include "tclWinInt.h" #include <fcntl.h> #include <io.h> #include <sys/stat.h> /* * This is the master lock used to serialize access to other serialization * data structures. */ static CRITICAL_SECTION masterLock; static int init = 0; #define MASTER_LOCK TclpMasterLock() #define MASTER_UNLOCK TclpMasterUnlock() /* * This is the master lock used to serialize initialization and finalization * of Tcl as a whole. */ static CRITICAL_SECTION initLock; /* * allocLock is used by Tcl's version of malloc for synchronization. For * obvious reasons, cannot use any dyamically allocated storage. */ #ifdef TCL_THREADS static CRITICAL_SECTION allocLock; static Tcl_Mutex allocLockPtr = (Tcl_Mutex) &allocLock; static int allocOnce = 0; #endif /* TCL_THREADS */ /* * The joinLock serializes Create- and ExitThread. This is necessary to * prevent a race where a new joinable thread exits before the creating thread * had the time to create the necessary data structures in the emulation * layer. */ static CRITICAL_SECTION joinLock; /* * Condition variables are implemented with a combination of a per-thread * Windows Event and a per-condition waiting queue. The idea is that each * thread has its own Event that it waits on when it is doing a ConditionWait; * it uses the same event for all condition variables because it only waits on * one at a time. Each condition variable has a queue of waiting threads, and * a mutex used to serialize access to this queue. * * Special thanks to David Nichols and Jim Davidson for advice on the * Condition Variable implementation. */ /* * The per-thread event and queue pointers. */ #ifdef TCL_THREADS typedef struct ThreadSpecificData { HANDLE condEvent; /* Per-thread condition event */ struct ThreadSpecificData *nextPtr; /* Queue pointers */ struct ThreadSpecificData *prevPtr; int flags; /* See flags below */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #endif /* TCL_THREADS */ /* * State bits for the thread. * WIN_THREAD_UNINIT Uninitialized. Must be zero because of the way * ThreadSpecificData is created. * WIN_THREAD_RUNNING Running, not waiting. * WIN_THREAD_BLOCKED Waiting, or trying to wait. * WIN_THREAD_DEAD Dying - no per-thread event anymore. */ #define WIN_THREAD_UNINIT 0x0 #define WIN_THREAD_RUNNING 0x1 #define WIN_THREAD_BLOCKED 0x2 #define WIN_THREAD_DEAD 0x4 /* * The per condition queue pointers and the Mutex used to serialize access to * the queue. */ typedef struct WinCondition { CRITICAL_SECTION condLock; /* Lock to serialize queuing on the * condition. */ struct ThreadSpecificData *firstPtr; /* Queue pointers */ struct ThreadSpecificData *lastPtr; } WinCondition; /* * Additions by AOL for specialized thread memory allocator. */ #ifdef USE_THREAD_ALLOC static int once; static DWORD tlsKey; typedef struct allocMutex { Tcl_Mutex tlock; CRITICAL_SECTION wlock; } allocMutex; #endif /* USE_THREAD_ALLOC */ /* *---------------------------------------------------------------------- * * TclpThreadCreate -- * * This procedure creates a new thread. * * Results: * TCL_OK if the thread could be created. The thread ID is returned in a * parameter. * * Side effects: * A new thread is created. * *---------------------------------------------------------------------- */ int TclpThreadCreate(idPtr, proc, clientData, stackSize, flags) Tcl_ThreadId *idPtr; /* Return, the ID of the thread. */ Tcl_ThreadCreateProc proc; /* Main() function of the thread. */ ClientData clientData; /* The one argument to Main(). */ int stackSize; /* Size of stack for the new thread. */ int flags; /* Flags controlling behaviour of the * new thread. */ { HANDLE tHandle; EnterCriticalSection(&joinLock); #if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) tHandle = (HANDLE) _beginthreadex(NULL, (unsigned) stackSize, proc, clientData, 0, (unsigned *)idPtr); #else tHandle = CreateThread(NULL, (DWORD) stackSize, (LPTHREAD_START_ROUTINE) proc, (LPVOID) clientData, (DWORD) 0, (LPDWORD)idPtr); #endif if (tHandle == NULL) { LeaveCriticalSection(&joinLock); return TCL_ERROR; } else { if (flags & TCL_THREAD_JOINABLE) { TclRememberJoinableThread(*idPtr); } /* * The only purpose of this is to decrement the reference count so the * OS resources will be reaquired when the thread closes. */ |
︙ | ︙ | |||
186 187 188 189 190 191 192 | * waited upon. * *---------------------------------------------------------------------- */ int Tcl_JoinThread(threadId, result) | | | | < | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 | * waited upon. * *---------------------------------------------------------------------- */ int Tcl_JoinThread(threadId, result) Tcl_ThreadId threadId; /* Id of the thread to wait upon */ int *result; /* Reference to the storage the result of the * thread we wait upon will be written into. */ { return TclJoinThread(threadId, result); } /* *---------------------------------------------------------------------- * * TclpThreadExit -- * |
︙ | ︙ | |||
215 216 217 218 219 220 221 | */ void TclpThreadExit(status) int status; { EnterCriticalSection(&joinLock); | | | 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 | */ void TclpThreadExit(status) int status; { EnterCriticalSection(&joinLock); TclSignalExitThread(Tcl_GetCurrentThread(), status); LeaveCriticalSection(&joinLock); #if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) _endthreadex((unsigned) status); #else ExitThread((DWORD) status); #endif |
︙ | ︙ | |||
244 245 246 247 248 249 250 | * *---------------------------------------------------------------------- */ Tcl_ThreadId Tcl_GetCurrentThread() { | | | | | | | | | > | | | 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 | * *---------------------------------------------------------------------- */ Tcl_ThreadId Tcl_GetCurrentThread() { return (Tcl_ThreadId) GetCurrentThreadId(); } /* *---------------------------------------------------------------------- * * TclpInitLock * * This procedure is used to grab a lock that serializes initialization * and finalization of Tcl. On some platforms this may also initialize * the mutex used to serialize creation of more mutexes and thread local * storage keys. * * Results: * None. * * Side effects: * Acquire the initialization mutex. * *---------------------------------------------------------------------- */ void TclpInitLock() { if (!init) { /* * There is a fundamental race here that is solved by creating the * first Tcl interpreter in a single threaded environment. Once the * interpreter has been created, it is safe to create more threads * that create interpreters in parallel. */ init = 1; InitializeCriticalSection(&joinLock); InitializeCriticalSection(&initLock); InitializeCriticalSection(&masterLock); } EnterCriticalSection(&initLock); } /* *---------------------------------------------------------------------- * * TclpInitUnlock * * This procedure is used to release a lock that serializes * initialization and finalization of Tcl. * * Results: * None. * * Side effects: * Release the initialization mutex. * |
︙ | ︙ | |||
312 313 314 315 316 317 318 | } /* *---------------------------------------------------------------------- * * TclpMasterLock * | | | | | | | | | > | | | 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 | } /* *---------------------------------------------------------------------- * * TclpMasterLock * * This procedure is used to grab a lock that serializes creation of * mutexes, condition variables, and thread local storage keys. * * This lock must be different than the initLock because the initLock is * held during creation of syncronization objects. * * Results: * None. * * Side effects: * Acquire the master mutex. * *---------------------------------------------------------------------- */ void TclpMasterLock() { if (!init) { /* * There is a fundamental race here that is solved by creating the * first Tcl interpreter in a single threaded environment. Once the * interpreter has been created, it is safe to create more threads * that create interpreters in parallel. */ init = 1; InitializeCriticalSection(&joinLock); InitializeCriticalSection(&initLock); InitializeCriticalSection(&masterLock); } EnterCriticalSection(&masterLock); } /* *---------------------------------------------------------------------- * * TclpMasterUnlock * * This procedure is used to release a lock that serializes creation and * deletion of synchronization objects. * * Results: * None. * * Side effects: * Release the master mutex. * |
︙ | ︙ | |||
373 374 375 376 377 378 379 | } /* *---------------------------------------------------------------------- * * Tcl_GetAllocMutex * | | | | | | | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 | } /* *---------------------------------------------------------------------- * * Tcl_GetAllocMutex * * This procedure returns a pointer to a statically initialized mutex for * use by the memory allocator. The alloctor must use this lock, because * all other locks are allocated... * * Results: * A pointer to a mutex that is suitable for passing to Tcl_MutexLock and * Tcl_MutexUnlock. * * Side effects: * None. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
406 407 408 409 410 411 412 | } /* *---------------------------------------------------------------------- * * TclpFinalizeLock * | | | | | | > > | > > > > > > | > > < | | < | < | | | 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 | } /* *---------------------------------------------------------------------- * * TclpFinalizeLock * * This procedure is used to destroy all private resources used in this * file. * * Results: * None. * * Side effects: * Destroys everything private. TclpInitLock must be held entering this * function. * *---------------------------------------------------------------------- */ void TclFinalizeLock() { MASTER_LOCK; DeleteCriticalSection(&joinLock); /* * Destroy the critical section that we are holding! */ DeleteCriticalSection(&masterLock); init = 0; #ifdef TCL_THREADS if (allocOnce) { DeleteCriticalSection(&allocLock); allocOnce = 0; } #endif LeaveCriticalSection(&initLock); /* * Destroy the critical section that we were holding. */ DeleteCriticalSection(&initLock); } #ifdef TCL_THREADS /* locally used prototype */ static void FinalizeConditionEvent(ClientData data); /* *---------------------------------------------------------------------- * * Tcl_MutexLock -- * * This procedure is invoked to lock a mutex. This is a self initializing * mutex that is automatically finalized during Tcl_Finalize. * * Results: * None. * * Side effects: * May block the current thread. The mutex is aquired when this returns. * *---------------------------------------------------------------------- */ void Tcl_MutexLock(mutexPtr) Tcl_Mutex *mutexPtr; /* The lock */ { CRITICAL_SECTION *csPtr; if (*mutexPtr == NULL) { MASTER_LOCK; /* * Double inside master lock check to avoid a race. */ if (*mutexPtr == NULL) { csPtr = (CRITICAL_SECTION *) ckalloc(sizeof(CRITICAL_SECTION)); InitializeCriticalSection(csPtr); *mutexPtr = (Tcl_Mutex)csPtr; TclRememberMutex(mutexPtr); } MASTER_UNLOCK; } csPtr = *((CRITICAL_SECTION **)mutexPtr); |
︙ | ︙ | |||
516 517 518 519 520 521 522 | } /* *---------------------------------------------------------------------- * * TclpFinalizeMutex -- * | | | | 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 | } /* *---------------------------------------------------------------------- * * TclpFinalizeMutex -- * * This procedure is invoked to clean up one mutex. This is only safe to * call at the end of time. * * Results: * None. * * Side effects: * The mutex list is deallocated. * |
︙ | ︙ | |||
543 544 545 546 547 548 549 | *mutexPtr = NULL; } } /* *---------------------------------------------------------------------- * | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | 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 | *mutexPtr = NULL; } } /* *---------------------------------------------------------------------- * * Tcl_ConditionWait -- * * This procedure is invoked to wait on a condition variable. The mutex * is atomically released as part of the wait, and automatically grabbed * when the condition is signaled. * * The mutex must be held when this procedure is called. * * Results: * None. * * Side effects: * May block the current thread. The mutex is aquired when this returns. * Will allocate memory for a HANDLE and initialize this the first time * this Tcl_Condition is used. * *---------------------------------------------------------------------- */ void Tcl_ConditionWait(condPtr, mutexPtr, timePtr) Tcl_Condition *condPtr; /* Really (WinCondition **) */ |
︙ | ︙ | |||
780 781 782 783 784 785 786 | * No more per-thread event on which to wait. */ return; } /* | | | < | | | | | < | | | 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 | * No more per-thread event on which to wait. */ return; } /* * Self initialize the two parts of the condition. The per-condition and * per-thread parts need to be handled independently. */ if (tsdPtr->flags == WIN_THREAD_UNINIT) { MASTER_LOCK; /* * Create the per-thread event and queue pointers. */ if (tsdPtr->flags == WIN_THREAD_UNINIT) { tsdPtr->condEvent = CreateEvent(NULL, TRUE /* manual reset */, FALSE /* non signaled */, NULL); tsdPtr->nextPtr = NULL; tsdPtr->prevPtr = NULL; tsdPtr->flags = WIN_THREAD_RUNNING; doExit = 1; } MASTER_UNLOCK; if (doExit) { /* * Create a per-thread exit handler to clean up the condEvent. We * must be careful to do this outside the Master Lock because * Tcl_CreateThreadExitHandler uses its own ThreadSpecificData, * and initializing that may drop back into the Master Lock. */ Tcl_CreateThreadExitHandler(FinalizeConditionEvent, (ClientData) tsdPtr); } } if (*condPtr == NULL) { MASTER_LOCK; |
︙ | ︙ | |||
842 843 844 845 846 847 848 | if (timePtr == NULL) { wtime = INFINITE; } else { wtime = timePtr->sec * 1000 + timePtr->usec / 1000; } /* | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < | > | > > | | < > | | | | | | | < < > > > > > > | | | | < | < > > | > | < < < | | | | < | | | > > > > > > > > > | 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 | if (timePtr == NULL) { wtime = INFINITE; } else { wtime = timePtr->sec * 1000 + timePtr->usec / 1000; } /* * Queue the thread on the condition, using the per-condition lock for * serialization. */ tsdPtr->flags = WIN_THREAD_BLOCKED; tsdPtr->nextPtr = NULL; EnterCriticalSection(&winCondPtr->condLock); tsdPtr->prevPtr = winCondPtr->lastPtr; /* A: */ winCondPtr->lastPtr = tsdPtr; if (tsdPtr->prevPtr != NULL) { tsdPtr->prevPtr->nextPtr = tsdPtr; } if (winCondPtr->firstPtr == NULL) { winCondPtr->firstPtr = tsdPtr; } /* * Unlock the caller's mutex and wait for the condition, or a timeout. * There is a minor issue here in that we don't count down the timeout if * we get notified, but another thread grabs the condition before we do. * In that race condition we'll wait again for the full timeout. Timed * waits are dubious anyway. Either you have the locking protocol wrong * and are masking a deadlock, or you are using conditions to pause your * thread. */ LeaveCriticalSection(csPtr); timeout = 0; while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) { ResetEvent(tsdPtr->condEvent); LeaveCriticalSection(&winCondPtr->condLock); if (WaitForSingleObject(tsdPtr->condEvent, wtime) == WAIT_TIMEOUT) { timeout = 1; } EnterCriticalSection(&winCondPtr->condLock); } /* * Be careful on timeouts because the signal might arrive right around the * time limit and someone else could have taken us off the queue. */ if (timeout) { if (tsdPtr->flags & WIN_THREAD_RUNNING) { timeout = 0; } else { /* * When dequeuing, we can leave the tsdPtr->nextPtr and * tsdPtr->prevPtr with dangling pointers because they are * reinitialilzed w/out reading them when the thread is enqueued * later. */ if (winCondPtr->firstPtr == tsdPtr) { winCondPtr->firstPtr = tsdPtr->nextPtr; } else { tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; } if (winCondPtr->lastPtr == tsdPtr) { winCondPtr->lastPtr = tsdPtr->prevPtr; } else { tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; } tsdPtr->flags = WIN_THREAD_RUNNING; } } LeaveCriticalSection(&winCondPtr->condLock); EnterCriticalSection(csPtr); } /* *---------------------------------------------------------------------- * * Tcl_ConditionNotify -- * * This procedure is invoked to signal a condition variable. * * The mutex must be held during this call to avoid races, but this * interface does not enforce that. * * Results: * None. * * Side effects: * May unblock another thread. * *---------------------------------------------------------------------- */ void Tcl_ConditionNotify(condPtr) Tcl_Condition *condPtr; { WinCondition *winCondPtr; ThreadSpecificData *tsdPtr; if (*condPtr != NULL) { winCondPtr = *((WinCondition **)condPtr); /* * Loop through all the threads waiting on the condition and notify * them (i.e., broadcast semantics). The queue manipulation is guarded * by the per-condition coordinating mutex. */ EnterCriticalSection(&winCondPtr->condLock); while (winCondPtr->firstPtr != NULL) { tsdPtr = winCondPtr->firstPtr; winCondPtr->firstPtr = tsdPtr->nextPtr; if (winCondPtr->lastPtr == tsdPtr) { winCondPtr->lastPtr = NULL; } tsdPtr->flags = WIN_THREAD_RUNNING; tsdPtr->nextPtr = NULL; tsdPtr->prevPtr = NULL; /* Not strictly necessary, see A: */ SetEvent(tsdPtr->condEvent); } LeaveCriticalSection(&winCondPtr->condLock); } else { /* * No-one has used the condition variable, so there are no waiters. */ } } /* *---------------------------------------------------------------------- * * FinalizeConditionEvent -- * * This procedure is invoked to clean up the per-thread event used to * implement condition waiting. This is only safe to call at the end of * time. * * Results: * None. * * Side effects: * The per-thread event is closed. * *---------------------------------------------------------------------- */ static void FinalizeConditionEvent(data) ClientData data; { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) data; tsdPtr->flags = WIN_THREAD_DEAD; CloseHandle(tsdPtr->condEvent); } /* *---------------------------------------------------------------------- * * TclpFinalizeCondition -- * * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * * This assumes the Master Lock is held. * * Results: * None. * * Side effects: * The condition variable is deallocated. * *---------------------------------------------------------------------- */ void TclpFinalizeCondition(condPtr) Tcl_Condition *condPtr; { WinCondition *winCondPtr = *(WinCondition **)condPtr; /* * Note - this is called long after the thread-local storage is reclaimed. * The per-thread condition waiting event is reclaimed earlier in a * per-thread exit handler, which is called before thread local storage is * reclaimed. */ if (winCondPtr != NULL) { DeleteCriticalSection(&winCondPtr->condLock); ckfree((char *)winCondPtr); *condPtr = NULL; } } /* * Additions by AOL for specialized thread memory allocator. */ #ifdef USE_THREAD_ALLOC Tcl_Mutex * TclpNewAllocMutex(void) { struct allocMutex *lockPtr; lockPtr = malloc(sizeof(struct allocMutex)); if (lockPtr == NULL) { Tcl_Panic("could not allocate lock"); } lockPtr->tlock = (Tcl_Mutex) &lockPtr->wlock; InitializeCriticalSection(&lockPtr->wlock); return &lockPtr->tlock; } void TclpFreeAllocMutex(mutex) Tcl_Mutex *mutex; /* The alloc mutex to free. */ { allocMutex *lockPtr = (allocMutex *) mutex; if (!lockPtr) { return; } DeleteCriticalSection(&lockPtr->wlock); free(lockPtr); } void * TclpGetAllocCache(void) { VOID *result; if (!once) { /* * We need to make sure that TclpFreeAllocCache is called on each * thread that calls this, but only on threads that call this. */ tlsKey = TlsAlloc(); once = 1; if (tlsKey == TLS_OUT_OF_INDEXES) { Tcl_Panic("could not allocate thread local storage"); } } result = TlsGetValue(tlsKey); if ((result == NULL) && (GetLastError() != NO_ERROR)) { Tcl_Panic("TlsGetValue failed from TclpGetAllocCache!"); } return result; } void TclpSetAllocCache(void *ptr) { BOOL success; success = TlsSetValue(tlsKey, ptr); if (!success) { Tcl_Panic("TlsSetValue failed from TclpSetAllocCache!"); } } void TclpFreeAllocCache(void *ptr) { BOOL success; if (ptr != NULL) { /* * Called by us in TclpFinalizeThreadData when a thread exits and * destroys the tsd key which stores allocator caches. */ TclFreeAllocCache(ptr); success = TlsSetValue(tlsKey, NULL); if (!success) { panic("TlsSetValue failed from TclpFreeAllocCache!"); } } else if (once) { /* * Called by us in TclFinalizeThreadAlloc() during the library * finalization initiated from Tcl_Finalize() */ success = TlsFree(tlsKey); if (!success) { Tcl_Panic("TlsFree failed from TclpFreeAllocCache!"); } once = 0; /* reset for next time. */ } } #endif /* USE_THREAD_ALLOC */ #endif /* TCL_THREADS */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to win/tclWinTime.c.
1 2 3 | /* * tclWinTime.c -- * | | | | | | | | | | > | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | /* * tclWinTime.c -- * * Contains Windows specific versions of Tcl functions that obtain time * values from the operating system. * * Copyright 1995-1998 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinTime.c,v 1.28.2.2 2005/08/02 18:17:21 dgp Exp $ */ #include "tclInt.h" #define SECSPERDAY (60L * 60L * 24L) #define SECSPERYEAR (SECSPERDAY * 365L) #define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY) /* * Number of samples over which to estimate the performance counter. */ #define SAMPLES 64 /* * The following arrays contain the day of year for the last day of each * month, where index 1 is January. */ static int normalDays[] = { -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364 }; static int leapDays[] = { |
︙ | ︙ | |||
43 44 45 46 47 48 49 | static Tcl_ThreadDataKey dataKey; /* * Data for managing high-resolution timers. */ typedef struct TimeInfo { | < | < < | | < | | < | < | | < | | < < | | | | | | | | < > | | | < < | 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 | static Tcl_ThreadDataKey dataKey; /* * Data for managing high-resolution timers. */ typedef struct TimeInfo { CRITICAL_SECTION cs; /* Mutex guarding this structure. */ int initialized; /* Flag == 1 if this structure is * initialized. */ int perfCounterAvailable; /* Flag == 1 if the hardware has a performance * counter. */ HANDLE calibrationThread; /* Handle to the thread that keeps the virtual * clock calibrated. */ HANDLE readyEvent; /* System event used to trigger the requesting * thread when the clock calibration procedure * is initialized for the first time. */ HANDLE exitEvent; /* Event to signal out of an exit handler to * tell the calibration loop to terminate. */ LARGE_INTEGER nominalFreq; /* Nominal frequency of the system performance * counter, that is, the value returned from * QueryPerformanceFrequency. */ /* * The following values are used for calculating virtual time. Virtual * time is always equal to: * lastFileTime + (current perf counter - lastCounter) * * 10000000 / curCounterFreq * and lastFileTime and lastCounter are updated any time that virtual time * is returned to a caller. */ ULARGE_INTEGER fileTimeLastCall; LARGE_INTEGER perfCounterLastCall; LARGE_INTEGER curCounterFreq; /* * Data used in developing the estimate of performance counter frequency */ Tcl_WideUInt fileTimeSample[SAMPLES]; /* Last 64 samples of system time. */ Tcl_WideInt perfCounterSample[SAMPLES]; /* Last 64 samples of performance counter. */ int sampleNo; /* Current sample number. */ } TimeInfo; static TimeInfo timeInfo = { { NULL }, 0, 0, (HANDLE) NULL, |
︙ | ︙ | |||
121 122 123 124 125 126 127 | 0 }; /* * Declarations for functions defined later in this file. */ | | | | | | < | < < < | | > > > > | > > > > > > > | | | > | | | | < | | > | | | | < | | | | | | | < | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | < > | | < | | | | | | | | | | | < | | | | | | | | | | | | | | > | | | | | | < > | | < | | | < | < | | | | | < < < | > | | | | < | < < < | | | | | | | | < | < | | | < | < | < | | < | | | | | | | | | > | | < | | | | | | | | | | > | | | | > | | > | | | | 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 | 0 }; /* * Declarations for functions defined later in this file. */ static struct tm * ComputeGMT(const time_t *tp); static void StopCalibration(ClientData clientData); static DWORD WINAPI CalibrationThread(LPVOID arg); static void UpdateTimeEachSecond(void); static void ResetCounterSamples(Tcl_WideUInt fileTime, Tcl_WideInt perfCounter, Tcl_WideInt perfFreq); static Tcl_WideInt AccumulateSample(Tcl_WideInt perfCounter, Tcl_WideUInt fileTime); static void NativeScaleTime(Tcl_Time* timebuf, ClientData clientData); static void NativeGetTime(Tcl_Time* timebuf, ClientData clientData); /* * TIP #233 (Virtualized Time): Data for the time hooks, if any. */ Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime; Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime; ClientData tclTimeClientData = NULL; /* *---------------------------------------------------------------------- * * TclpGetSeconds -- * * This procedure returns the number of seconds from the epoch. On most * Unix systems the epoch is Midnight Jan 1, 1970 GMT. * * Results: * Number of seconds from the epoch. * * Side effects: * None. * *---------------------------------------------------------------------- */ unsigned long TclpGetSeconds() { Tcl_Time t; (*tclGetTimeProcPtr) (&t, tclTimeClientData); /* Tcl_GetTime inlined. */ return t.sec; } /* *---------------------------------------------------------------------- * * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution * clock available on the system. There are no guarantees on what the * resolution will be. In Tcl we will call this value a "click". The * start time is also system dependant. * * Results: * Number of clicks from some start time. * * Side effects: * None. * *---------------------------------------------------------------------- */ unsigned long TclpGetClicks() { /* * Use the Tcl_GetTime abstraction to get the time in microseconds, as * nearly as we can, and return it. */ Tcl_Time now; /* Current Tcl time */ unsigned long retval; /* Value to return */ (*tclGetTimeProcPtr) (&now, tclTimeClientData); /* Tcl_GetTime inlined */ retval = (now.sec * 1000000) + now.usec; return retval; } /* *---------------------------------------------------------------------- * * TclpGetTimeZone -- * * Determines the current timezone. The method varies wildly between * different Platform implementations, so its hidden in this function. * * Results: * Minutes west of GMT. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclpGetTimeZone(currentTime) unsigned long currentTime; { int timeZone; tzset(); timeZone = timezone / 60; return timeZone; } /* *---------------------------------------------------------------------- * * Tcl_GetTime -- * * Gets the current system time in seconds and microseconds since the * beginning of the epoch: 00:00 UCT, January 1, 1970. * * Results: * Returns the current time in timePtr. * * Side effects: * On the first call, initializes a set of static variables to keep track * of the base value of the performance counter, the corresponding wall * clock (obtained through ftime) and the frequency of the performance * counter. Also spins a thread whose function is to wake up periodically * and monitor these values, adjusting them as necessary to correct for * drift in the performance counter's oscillator. * *---------------------------------------------------------------------- */ void Tcl_GetTime(timePtr) Tcl_Time *timePtr; /* Location to store time information. */ { (*tclGetTimeProcPtr) (timePtr, tclTimeClientData); } /* *---------------------------------------------------------------------- * * NativeScaleTime -- * * TIP #233: Scale from virtual time to the real-time. For native scaling * the relationship is 1:1 and nothing has to be done. * * Results: * Scales the time in timePtr. * * Side effects: * See above. * *---------------------------------------------------------------------- */ static void NativeScaleTime(timePtr, clientData) Tcl_Time *timePtr; ClientData clientData; { /* * Native scale is 1:1. Nothing is done. */ } /* *---------------------------------------------------------------------- * * NativeGetTime -- * * TIP #233: Gets the current system time in seconds and microseconds * since the beginning of the epoch: 00:00 UCT, January 1, 1970. * * Results: * Returns the current time in timePtr. * * Side effects: * On the first call, initializes a set of static variables to keep track * of the base value of the performance counter, the corresponding wall * clock (obtained through ftime) and the frequency of the performance * counter. Also spins a thread whose function is to wake up periodically * and monitor these values, adjusting them as necessary to correct for * drift in the performance counter's oscillator. * *---------------------------------------------------------------------- */ static void NativeGetTime(timePtr, clientData) Tcl_Time *timePtr; ClientData clientData; { struct timeb t; int useFtime = 1; /* Flag == TRUE if we need to fall back on * ftime rather than using the perf counter. */ /* * Initialize static storage on the first trip through. * * Note: Outer check for 'initialized' is a performance win since it * avoids an extra mutex lock in the common case. */ if (!timeInfo.initialized) { TclpInitLock(); if (!timeInfo.initialized) { timeInfo.perfCounterAvailable = QueryPerformanceFrequency(&timeInfo.nominalFreq); /* * Some hardware abstraction layers use the CPU clock in place of * the real-time clock as a performance counter reference. This * results in: * - inconsistent results among the processors on * multi-processor systems. * - unpredictable changes in performance counter frequency on * "gearshift" processors such as Transmeta and SpeedStep. * * There seems to be no way to test whether the performance * counter is reliable, but a useful heuristic is that if its * frequency is 1.193182 MHz or 3.579545 MHz, it's derived from a * colorburst crystal and is therefore the RTC rather than the * TSC. * * A sloppier but serviceable heuristic is that the RTC crystal is * normally less than 15 MHz while the TSC crystal is virtually * assured to be greater than 100 MHz. Since Win98SE appears to * fiddle with the definition of the perf counter frequency * (perhaps in an attempt to calibrate the clock?), we use the * latter rule rather than an exact match. * * We also assume (perhaps questionably) that the vendors have * gotten their act together on Win64, so bypass all this rubbish * on that platform. */ #if !defined(_WIN64) if (timeInfo.perfCounterAvailable /* * The following lines would do an exact match on crystal * frequency: * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)1193182 * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)3579545 */ && timeInfo.nominalFreq.QuadPart > (Tcl_WideInt) 15000000){ /* * As an exception, if every logical processor on the system * is on the same chip, we use the performance counter anyway, * presuming that everyone's TSC is locked to the same * oscillator. */ SYSTEM_INFO systemInfo; unsigned int regs[4]; GetSystemInfo(&systemInfo); if (TclWinCPUID(0, regs) == TCL_OK && regs[1] == 0x756e6547 /* "Genu" */ && regs[3] == 0x49656e69 /* "ineI" */ && regs[2] == 0x6c65746e /* "ntel" */ && TclWinCPUID(1, regs) == TCL_OK && ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */ || ((regs[0] & 0x00F00000) /* Extended family */ && (regs[3] & 0x10000000))) /* Hyperthread */ && (((regs[1]&0x00FF0000) >> 16)/* CPU count */ == systemInfo.dwNumberOfProcessors)) { timeInfo.perfCounterAvailable = TRUE; } else { timeInfo.perfCounterAvailable = FALSE; } } #endif /* above code is Win32 only */ /* * If the performance counter is available, start a thread to * calibrate it. */ if (timeInfo.perfCounterAvailable) { DWORD id; InitializeCriticalSection(&timeInfo.cs); timeInfo.readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); timeInfo.exitEvent = CreateEvent(NULL, FALSE, FALSE, NULL); timeInfo.calibrationThread = CreateThread(NULL, 256, CalibrationThread, (LPVOID) NULL, 0, &id); SetThreadPriority(timeInfo.calibrationThread, THREAD_PRIORITY_HIGHEST); /* * Wait for the thread just launched to start running, and * create an exit handler that kills it so that it doesn't * outlive unloading tclXX.dll */ WaitForSingleObject(timeInfo.readyEvent, INFINITE); CloseHandle(timeInfo.readyEvent); Tcl_CreateExitHandler(StopCalibration, (ClientData) NULL); } timeInfo.initialized = TRUE; } TclpInitUnlock(); } if (timeInfo.perfCounterAvailable && timeInfo.curCounterFreq.QuadPart!=0) { /* * Query the performance counter and use it to calculate the current * time. */ LARGE_INTEGER curCounter; /* Current performance counter. */ Tcl_WideInt curFileTime;/* Current estimated time, expressed as 100-ns * ticks since the Windows epoch. */ static LARGE_INTEGER posixEpoch; /* Posix epoch expressed as 100-ns ticks since * the windows epoch. */ Tcl_WideInt usecSincePosixEpoch; /* Current microseconds since Posix epoch. */ posixEpoch.LowPart = 0xD53E8000; posixEpoch.HighPart = 0x019DB1DE; EnterCriticalSection(&timeInfo.cs); QueryPerformanceCounter(&curCounter); /* * If it appears to be more than 1.1 seconds since the last trip * through the calibration loop, the performance counter may have * jumped forward. (See MSDN Knowledge Base article Q274323 for a * description of the hardware problem that makes this test * necessary.) If the counter jumps, we don't want to use it directly. * Instead, we must return system time. Eventually, the calibration * loop should recover. */ if (curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart < 11 * timeInfo.curCounterFreq.QuadPart / 10) { curFileTime = timeInfo.fileTimeLastCall.QuadPart + ((curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart) * 10000000 / timeInfo.curCounterFreq.QuadPart); timeInfo.fileTimeLastCall.QuadPart = curFileTime; timeInfo.perfCounterLastCall.QuadPart = curCounter.QuadPart; usecSincePosixEpoch = (curFileTime - posixEpoch.QuadPart) / 10; timePtr->sec = (time_t) (usecSincePosixEpoch / 1000000); timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); useFtime = 0; } LeaveCriticalSection(&timeInfo.cs); } if (useFtime) { /* * High resolution timer is not available. Just use ftime. */ ftime(&t); timePtr->sec = t.time; timePtr->usec = t.millitm * 1000; } } /* *---------------------------------------------------------------------- * * StopCalibration -- * * Turns off the calibration thread in preparation for exiting the * process. * * Results: * None. * * Side effects: * Sets the 'exitEvent' event in the 'timeInfo' structure to ask the * thread in question to exit, and waits for it to do so. * *---------------------------------------------------------------------- */ static void StopCalibration(ClientData unused) /* Client data is unused */ { SetEvent(timeInfo.exitEvent); /* * If Tcl_Finalize was called from DllMain, the calibration thread is in a * paused state so we need to timeout and continue. */ WaitForSingleObject(timeInfo.calibrationThread, 100); CloseHandle(timeInfo.exitEvent); CloseHandle(timeInfo.calibrationThread); } /* *---------------------------------------------------------------------- * * TclpGetTZName -- * |
︙ | ︙ | |||
505 506 507 508 509 510 511 | ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); char *name = tsdPtr->tzName; /* * tzset() under Borland doesn't seem to set up tzname[] at all. * tzset() under MSVC has the following weird observed behavior: * First time we call "clock format [clock seconds] -format %Z -gmt 1" | | | | | | < | | | 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 | ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); char *name = tsdPtr->tzName; /* * tzset() under Borland doesn't seem to set up tzname[] at all. * tzset() under MSVC has the following weird observed behavior: * First time we call "clock format [clock seconds] -format %Z -gmt 1" * we get "GMT", but on all subsequent calls we get the current time * ezone string, even though env(TZ) is GMT and the variable _timezone * is 0. */ name[0] = '\0'; zone = getenv("TZ"); if (zone != NULL) { /* * TZ is of form "NST-4:30NDT", where "NST" would be the name of the * standard time zone for this area, "-4:30" is the offset from GMT in * hours, and "NDT is the name of the daylight savings time zone in * this area. The offset and DST strings are optional. */ len = strlen(zone); if (len > 3) { len = 3; } if (dst != 0) { |
︙ | ︙ | |||
547 548 549 550 551 552 553 | } Tcl_ExternalToUtf(NULL, NULL, zone, len, 0, NULL, name, sizeof(tsdPtr->tzName), NULL, NULL, NULL); } if (name[0] == '\0') { if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_UNKNOWN) { /* | | | > | | | | 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 | } Tcl_ExternalToUtf(NULL, NULL, zone, len, 0, NULL, name, sizeof(tsdPtr->tzName), NULL, NULL, NULL); } if (name[0] == '\0') { if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_UNKNOWN) { /* * MSDN: On NT this is returned if DST is not used in the current * TZ */ dst = 0; } encoding = Tcl_GetEncoding(NULL, "unicode"); Tcl_ExternalToUtf(NULL, encoding, (char *) ((dst) ? tz.DaylightName : tz.StandardName), -1, 0, NULL, name, sizeof(tsdPtr->tzName), NULL, NULL, NULL); Tcl_FreeEncoding(encoding); } return name; } /* *---------------------------------------------------------------------- * * TclpGetDate -- * * This function converts between seconds and struct tm. If useGMT is * true, then the returned date will be in Greenwich Mean Time (GMT). * Otherwise, it will be in the local time zone. * * Results: * Returns a static tm structure. * * Side effects: * None. * |
︙ | ︙ | |||
591 592 593 594 595 596 597 | struct tm *tmPtr; time_t time; if (!useGMT) { tzset(); /* | | | | | | | | > | | | | > | < > > > | | | < | 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 | struct tm *tmPtr; time_t time; if (!useGMT) { tzset(); /* * If we are in the valid range, let the C run-time library handle it. * Otherwise we need to fake it. Note that this algorithm ignores * daylight savings time before the epoch. */ /* * Hm, Borland's localtime manages to return NULL under certain * circumstances (e.g. wintime.test, test 1.2). Nobody tests for this, * since 'localtime' isn't supposed to do this, possibly leading to * crashes. * * Patch: We only call this function if we are at least one day into * the epoch, else we handle it ourselves (like we do for times < 0). * H. Giese, June 2003 */ #ifdef __BORLANDC__ #define LOCALTIME_VALIDITY_BOUNDARY SECSPERDAY #else #define LOCALTIME_VALIDITY_BOUNDARY 0 #endif if (*t >= LOCALTIME_VALIDITY_BOUNDARY) { return TclpLocaltime(t); } time = *t - timezone; /* * If we aren't near to overflowing the long, just add the bias and * use the normal calculation. Otherwise we will need to adjust the * result at the end. */ if (*t < (LONG_MAX - 2*SECSPERDAY) && *t > (LONG_MIN + 2*SECSPERDAY)) { tmPtr = ComputeGMT(&time); } else { tmPtr = ComputeGMT(t); tzset(); /* |
︙ | ︙ | |||
671 672 673 674 675 676 677 | } /* *---------------------------------------------------------------------- * * ComputeGMT -- * | | | | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 | } /* *---------------------------------------------------------------------- * * ComputeGMT -- * * This function computes GMT given the number of seconds since the epoch * (midnight Jan 1 1970). * * Results: * Returns a (per thread) statically allocated struct tm. * * Side effects: * Updates the values of the static struct tm. * |
︙ | ︙ | |||
712 713 714 715 716 717 718 | if (rem < 0) { tmp--; rem += SECSPER4YEAR; } /* | | | | | 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 | if (rem < 0) { tmp--; rem += SECSPER4YEAR; } /* * Compute the year after 1900 by taking the 4 year span and adjusting for * the remainder. This works because 2000 is a leap year, and 1900/2100 * are out of the range. */ tmp = (tmp * 4) + 70; isLeap = 0; if (rem >= SECSPERYEAR) { /* 1971, etc. */ tmp++; rem -= SECSPERYEAR; |
︙ | ︙ | |||
736 737 738 739 740 741 742 | isLeap = 1; } } } tmPtr->tm_year = tmp; /* | | | > | 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 | isLeap = 1; } } } tmPtr->tm_year = tmp; /* * Compute the day of year and leave the seconds in the current day in the * remainder. */ tmPtr->tm_yday = rem / SECSPERDAY; rem %= SECSPERDAY; /* * Compute the time of day. */ tmPtr->tm_hour = rem / 3600; rem %= 3600; tmPtr->tm_min = rem / 60; tmPtr->tm_sec = rem % 60; /* * Compute the month and day of month. */ days = (isLeap) ? leapDays : normalDays; for (tmp = 1; days[tmp] < tmPtr->tm_yday; tmp++) { /* empty body */ } tmPtr->tm_mon = --tmp; tmPtr->tm_mday = tmPtr->tm_yday - days[tmp]; /* * Compute day of week. Epoch started on a Thursday. */ |
︙ | ︙ | |||
783 784 785 786 787 788 789 | } /* *---------------------------------------------------------------------- * * CalibrationThread -- * | | | | | | | | | | | | > | > | | | | | | | | > | > | | > | | | | < | < | < | | < | < | | < | | < | | | | | | | | | | | < | | | < | | | | | | < < | < | | | | | | | | | | | | | | | | | | | < | | > | | < | | > | | | < | | | | | | < | < | | | | | | | < | | | | | | < | | | < | | < < < < < < > | > | | | | | | | > | | | < | | < | | > | | | | | | > | > | | < | | | | < | | | > | | | | | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } /* *---------------------------------------------------------------------- * * CalibrationThread -- * * Thread that manages calibration of the hi-resolution time derived from * the performance counter, to keep it synchronized with the system * clock. * * Parameters: * arg - Client data from the CreateThread call. This parameter points to * the static TimeInfo structure. * * Return value: * None. This thread embeds an infinite loop. * * Side effects: * At an interval of 1s, this thread performs virtual time discipline. * * Note: When this thread is entered, TclpInitLock has been called to * safeguard the static storage. There is therefore no synchronization in the * body of this procedure. * *---------------------------------------------------------------------- */ static DWORD WINAPI CalibrationThread(LPVOID arg) { FILETIME curFileTime; DWORD waitResult; /* * Get initial system time and performance counter. */ GetSystemTimeAsFileTime(&curFileTime); QueryPerformanceCounter(&timeInfo.perfCounterLastCall); QueryPerformanceFrequency(&timeInfo.curCounterFreq); timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime; timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime; ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart, timeInfo.perfCounterLastCall.QuadPart, timeInfo.curCounterFreq.QuadPart); /* * Wake up the calling thread. When it wakes up, it will release the * initialization lock. */ SetEvent(timeInfo.readyEvent); /* * Run the calibration once a second. */ while (timeInfo.perfCounterAvailable) { /* * If the exitEvent is set, break out of the loop. */ waitResult = WaitForSingleObjectEx(timeInfo.exitEvent, 1000, FALSE); if (waitResult == WAIT_OBJECT_0) { break; } UpdateTimeEachSecond(); } /* lint */ return (DWORD) 0; } /* *---------------------------------------------------------------------- * * UpdateTimeEachSecond -- * * Callback from the waitable timer in the clock calibration thread that * updates system time. * * Parameters: * info - Pointer to the static TimeInfo structure * * Results: * None. * * Side effects: * Performs virtual time calibration discipline. * *---------------------------------------------------------------------- */ static void UpdateTimeEachSecond() { LARGE_INTEGER curPerfCounter; /* Current value returned from * QueryPerformanceCounter. */ FILETIME curSysTime; /* Current system time. */ LARGE_INTEGER curFileTime; /* File time at the time this callback was * scheduled. */ Tcl_WideInt estFreq; /* Estimated perf counter frequency. */ Tcl_WideInt vt0; /* Tcl time right now. */ Tcl_WideInt vt1; /* Tcl time one second from now. */ Tcl_WideInt tdiff; /* Difference between system clock and Tcl * time. */ Tcl_WideInt driftFreq; /* Frequency needed to drift virtual time into * step over 1 second. */ /* * Sample performance counter and system time. */ QueryPerformanceCounter(&curPerfCounter); GetSystemTimeAsFileTime(&curSysTime); curFileTime.LowPart = curSysTime.dwLowDateTime; curFileTime.HighPart = curSysTime.dwHighDateTime; EnterCriticalSection(&timeInfo.cs); /* * We devide by timeInfo.curCounterFreq.QuadPart in several places. That * value should always be positive on a correctly functioning system. But * it is good to be defensive about such matters. So if something goes * wrong and the value does goes to zero, we clear the * timeInfo.perfCounterAvailable in order to cause the calibration thread * to shut itself down, then return without additional processing. */ if (timeInfo.curCounterFreq.QuadPart == 0){ LeaveCriticalSection(&timeInfo.cs); timeInfo.perfCounterAvailable = 0; return; } /* * Several things may have gone wrong here that have to be checked for. * (1) The performance counter may have jumped. * (2) The system clock may have been reset. * * In either case, we'll need to reinitialize the circular buffer with * samples relative to the current system time and the NOMINAL performance * frequency (not the actual, because the actual has probably run slow in * the first case). Our estimated frequency will be the nominal frequency. * * Store the current sample into the circular buffer of samples, and * estimate the performance counter frequency. */ estFreq = AccumulateSample(curPerfCounter.QuadPart, (Tcl_WideUInt) curFileTime.QuadPart); /* * We want to adjust things so that time appears to be continuous. * Virtual file time, right now, is * * vt0 = 10000000 * (curPerfCounter - perfCounterLastCall) * / curCounterFreq * + fileTimeLastCall * * Ideally, we would like to drift the clock into place over a period of 2 * sec, so that virtual time 2 sec from now will be * * vt1 = 20000000 + curFileTime * * The frequency that we need to use to drift the counter back into place * is estFreq * 20000000 / (vt1 - vt0) */ vt0 = 10000000 * (curPerfCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart) / timeInfo.curCounterFreq.QuadPart + timeInfo.fileTimeLastCall.QuadPart; vt1 = 20000000 + curFileTime.QuadPart; /* * If we've gotten more than a second away from system time, then drifting * the clock is going to be pretty hopeless. Just let it jump. Otherwise, * compute the drift frequency and fill in everything. */ tdiff = vt0 - curFileTime.QuadPart; if (tdiff > 10000000 || tdiff < -10000000) { timeInfo.fileTimeLastCall.QuadPart = curFileTime.QuadPart; timeInfo.curCounterFreq.QuadPart = estFreq; } else { driftFreq = estFreq * 20000000 / (vt1 - vt0); if (driftFreq > 1003*estFreq/1000) { driftFreq = 1003*estFreq/1000; } else if (driftFreq < 997*estFreq/1000) { driftFreq = 997*estFreq/1000; } timeInfo.fileTimeLastCall.QuadPart = vt0; timeInfo.curCounterFreq.QuadPart = driftFreq; } timeInfo.perfCounterLastCall.QuadPart = curPerfCounter.QuadPart; LeaveCriticalSection(&timeInfo.cs); } /* *---------------------------------------------------------------------- * * ResetCounterSamples -- * * Fills the sample arrays in 'timeInfo' with dummy values that will * yield the current performance counter and frequency. * * Results: * None. * * Side effects: * The array of samples is filled in so that it appears that there are * SAMPLES samples at one-second intervals, separated by precisely the * given frequency. * *---------------------------------------------------------------------- */ static void ResetCounterSamples( Tcl_WideUInt fileTime, /* Current file time */ Tcl_WideInt perfCounter, /* Current performance counter */ Tcl_WideInt perfFreq) /* Target performance frequency */ { int i; for (i=SAMPLES-1 ; i>=0 ; --i) { timeInfo.perfCounterSample[i] = perfCounter; timeInfo.fileTimeSample[i] = fileTime; perfCounter -= perfFreq; fileTime -= 10000000; } timeInfo.sampleNo = 0; } /* *---------------------------------------------------------------------- * * AccumulateSample -- * * Updates the circular buffer of performance counter and system time * samples with a new data point. * * Results: * None. * * Side effects: * The new data point replaces the oldest point in the circular buffer, * and the descriptive statistics are updated to accumulate the new * point. * * Several things may have gone wrong here that have to be checked for. * (1) The performance counter may have jumped. * (2) The system clock may have been reset. * * In either case, we'll need to reinitialize the circular buffer with samples * relative to the current system time and the NOMINAL performance frequency * (not the actual, because the actual has probably run slow in the first * case). */ static Tcl_WideInt AccumulateSample(Tcl_WideInt perfCounter, Tcl_WideUInt fileTime) { Tcl_WideUInt workFTSample; /* File time sample being removed from or * added to the circular buffer. */ Tcl_WideInt workPCSample; /* Performance counter sample being removed * from or added to the circular buffer. */ Tcl_WideUInt lastFTSample; /* Last file time sample recorded */ Tcl_WideInt lastPCSample; /* Last performance counter sample recorded */ Tcl_WideInt FTdiff; /* Difference between last FT and current */ Tcl_WideInt PCdiff; /* Difference between last PC and current */ Tcl_WideInt estFreq; /* Estimated performance counter frequency */ /* * Test for jumps and reset the samples if we have one. */ if (timeInfo.sampleNo == 0) { lastPCSample = timeInfo.perfCounterSample[timeInfo.sampleNo + SAMPLES - 1]; lastFTSample = timeInfo.fileTimeSample[timeInfo.sampleNo + SAMPLES - 1]; } else { lastPCSample = timeInfo.perfCounterSample[timeInfo.sampleNo - 1]; lastFTSample = timeInfo.fileTimeSample[timeInfo.sampleNo - 1]; } PCdiff = perfCounter - lastPCSample; FTdiff = fileTime - lastFTSample; if (PCdiff < timeInfo.nominalFreq.QuadPart * 9 / 10 || PCdiff > timeInfo.nominalFreq.QuadPart * 11 / 10 || FTdiff < 9000000 || FTdiff > 11000000) { ResetCounterSamples(fileTime, perfCounter, timeInfo.nominalFreq.QuadPart); return timeInfo.nominalFreq.QuadPart; } else { /* * Estimate the frequency. */ workPCSample = timeInfo.perfCounterSample[timeInfo.sampleNo]; workFTSample = timeInfo.fileTimeSample[timeInfo.sampleNo]; estFreq = 10000000 * (perfCounter - workPCSample) / (fileTime - workFTSample); timeInfo.perfCounterSample[timeInfo.sampleNo] = perfCounter; timeInfo.fileTimeSample[timeInfo.sampleNo] = (Tcl_WideInt) fileTime; /* * Advance the sample number. */ if (++timeInfo.sampleNo >= SAMPLES) { timeInfo.sampleNo = 0; } return estFreq; } } /* *---------------------------------------------------------------------- * * TclpGmtime -- * * Wrapper around the 'gmtime' library function to make it thread safe. * * Results: * Returns a pointer to a 'struct tm' in thread-specific data. * * Side effects: * Invokes gmtime or gmtime_r as appropriate. * *---------------------------------------------------------------------- */ struct tm * TclpGmtime(timePtr) CONST time_t *timePtr; /* Pointer to the number of seconds since the * local system's epoch */ { /* * The MS implementation of gmtime is thread safe because it returns the * time in a block of thread-local storage, and Windows does not provide a * Posix gmtime_r function. */ return gmtime(timePtr); } /* *---------------------------------------------------------------------- * * TclpLocaltime -- * * Wrapper around the 'localtime' library function to make it thread * safe. * * Results: * Returns a pointer to a 'struct tm' in thread-specific data. * * Side effects: * Invokes localtime or localtime_r as appropriate. * *---------------------------------------------------------------------- */ struct tm * TclpLocaltime(timePtr) CONST time_t *timePtr; /* Pointer to the number of seconds since the * local system's epoch */ { /* * The MS implementation of localtime is thread safe because it returns * the time in a block of thread-local storage, and Windows does not * provide a Posix localtime_r function. */ return localtime(timePtr); } /* *---------------------------------------------------------------------- * * Tcl_SetTimeProc -- * * TIP #233 (Virtualized Time): Registers two handlers for the * virtualization of Tcl's access to time information. * * Results: * None. * * Side effects: * Remembers the handlers, alters core behaviour. * *---------------------------------------------------------------------- */ void Tcl_SetTimeProc(getProc, scaleProc, clientData) Tcl_GetTimeProc *getProc; Tcl_ScaleTimeProc *scaleProc; ClientData clientData; { tclGetTimeProcPtr = getProc; tclScaleTimeProcPtr = scaleProc; tclTimeClientData = clientData; } /* *---------------------------------------------------------------------- * * Tcl_QueryTimeProc -- * * TIP #233 (Virtualized Time): Query which time handlers are registered. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_QueryTimeProc(getProc, scaleProc, clientData) Tcl_GetTimeProc ** getProc; Tcl_ScaleTimeProc **scaleProc; ClientData *clientData; { if (getProc) { *getProc = tclGetTimeProcPtr; } if (scaleProc) { *scaleProc = tclScaleTimeProcPtr; } if (clientData) { *clientData = tclTimeClientData; } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |